%YTAR% Header 2013-03-21T23:23:02
%FILE% add_phai_spectra.i
/* Function add_phai_spectra */

/*************************************************

 Add two or more PHAI spectra

  add_p1spectra alias add_phai_spectra
*************************************************/

func add_phai_spectra( list, outfile, silent= )
/* DOCUMENT add_phai_spectra, list_of_filenames, outfilename, silent=

   Assumes extension #1

*/
{
   local ancrfile, ndum;

   kwds_init;
   kwds_set,"COMMENT","Including these files:";
   n = numberof(list);

   rate_sum = [];
   rate_sum_err2 = [];
   expo_sum = 0.0;
   arf_sum = [];
   for( i = 1; i <= n; i++ ) {
      if(!silent)write,"Extracting spectrum from "+list(i)+" ...";
      if( !file_test(list(i)) ) {
         write,"Did not find "+list(i)+", skip and continue ...";
         continue;
      }
      res = rd_phai_spectrum( list(i) );

      rate = *res.rate;
      rate_err = *res.stat_err;
      wz = where( rate_err == 0.0 );
      if( numberof(wz) ) rate_err(wz) = 1.e10;
      weight = 1./rate_err^2;
      ancrfile = res.arf;
      respfile = res.rmf;

      if( is_void(rate_sum) ) {
         weight_sum = weight;
         rate_sum = rate*weight;
         rate_sum_err2 = (weight*rate_err)^2;
      } else {
         weight_sum += weight;
         rate_sum += weight*rate;
         rate_sum_err2 += (weight*rate_err)^2;
      }

      //+ e_min = rdfitscol( respfile+"[EBOUNDS]", "e_min" );
      //+ e_max = rdfitscol( respfile+"[EBOUNDS]", "e_max" );

   }

   rate = rate_sum / weight_sum;
   rate_err = sqrt( rate_sum_err2 ) / weight_sum;

   spec2phaii, outfile, rate, rate_err, exposure=1.e4, \
               ancrfile=ancrfile, respfile=respfile,telescop=telescop, \
               instrume=instrume, no_kwds_init=1;

}
add_p1spectra = add_phai_spectra;
%FILE% afits.i
extern afitsdoc;
/* DOCUMENT **************************************
   Package for FITS/SCM format files: afits format
 
   Convert FITS files to a format similar but based entirely
   on ASCII files.

   afits_gethdr
   afits_getfarr
   afits_getcol

   2004-08-23/Niels J. Westergaard

 ***************************************/

/* Function afits_gethdr */

func afits_gethdr(filename)
/* DOCUMENT hdr = afits_gethdr(filename)
     Return the header of an AFITS file
*/

{
   f = open(filename,"r");
   hdr = array(" ",200);
   kount = 0;
   do {
      if( !(line = rdline(f))) break;
      s = strpart(line, 1:2);
      if( s == "//" ) {
         // print,line;
         hdr(++kount) = line;
      }
   } while( s == "//" );
   close, f;
   return hdr(1:kount);
}

/* Function afits_getfarr */

func afits_getfarr(filename)
/* DOCUMENT arr = afits_getfarr(filename)
     Return a float 2D array from an AFITS file
*/

{
   // first get header
   hdr = afits_gethdr(filename);
   dimx = long(scomget( hdr, "NAXIS1"));
   dimy = long(scomget( hdr, "NAXIS2"));
   f = open( filename,"r");

   // skip the header
   do {
      line = rdline(f);
      s = strpart(line, 1:2);
      // if( s == "//" ) print,line;
   } while( s == "//" );

   row = array(float,dimx);
   arr = array(float,dimx,dimy);

   n = sread( line, format="%f", row );
   arr(,1) = row;

   for( i=2; i <= dimy; i++ ) {
      line = rdline(f)
      n = sread( line, format="%f", row );
      arr(,i) = row;
   }
   close, f;
   print,"Returning ", dimx," X ", dimy," array";
   return arr;
}

/* Function afits_getcol */

func afits_getcol(filename, colname)
/* DOCUMENT coldat = afits_getcol(filename,colname)

     Return a column from an AFITS table file

*/

{
   // first get header
   hdr = afits_gethdr(filename);
   tfields = scomget( hdr, "TFIELDS");
   naxis2 = long(scomget( hdr, "NAXIS2"));
   endfield = long(scomget( hdr, "endfield"));
   if( numberof(endfield) != tfields ) {
      print,"Error, inconsistency tfields/endfield";
      return [];
   }
   numfield = long(scomget( hdr, "numfield"));
   nnumf = numberof(numfield);
   if( nnumf > 0 || ( nnumf == 1 && numfield(1) != 0 ) ) {
      if( numberof(numfield) != tfields ) {
         print,"Error, inconsistency tfields/numfield";
         return [];
      }
   } else numfield = array(1,tfields);

   found = 0;
   for(i=1;i<=tfields;i++) {
      typekey = swrite(format="TTYPE%i",i);
      formkey = swrite(format="TFORM%i",i);
      tcolname = strtrim(scomgets( hdr, typekey ));
      tform = strtrim(scomgets( hdr, formkey ));
      if( strtrim(colname) == tcolname ) {
         found = i;
         break;
      }
   }
   if( !found ) {
      print,"Error, no such column found";
      return [];
   }

   is_string = 0;
   nff = numfield(found);

   if( strmatch( tform, "I" ) ) {
      col = array( int, nff, naxis2 );
      vec = array( int, nff );
      fmstr = "%i";
   }
   if( strmatch( tform, "J" ) ) {
      col = array( long, nff, naxis2 );
      vec = array( long, nff );
      fmstr = "%i";
   }
   if( strmatch( tform, "E" ) ) {
      col = array( float, nff, naxis2 );
      vec = array( float, nff );
      fmstr = "%f";
   }
   if( strmatch( tform, "D" ) ) {
      col = array( double, nff, naxis2 );
      vec = array( double, nff );
      fmstr = "%f";
   }
   if( strmatch( tform, "A" ) ) {
      col = array( "", naxis2 );
      is_string = 1;
      fmstr = "%s";
   }

   f = open( filename,"r");
   // skip the header
   do {
      line = rdline(f);
      s = strpart(line, 1:2);
      // if( s == "//" ) print,line;
   } while( s == "//" );

   if( found == 1 ) {
      pos1 = 1;
      pos2 = endfield(1) + 1;
   } else {
      pos1 = endfield(found - 1) + 2;
      pos2 = endfield(found) + 1;
   }
   item = strpart( line, pos1:pos2 );
   if( is_string ) {
      col(1) = strtrim(item);
   } else {
      n = sread( item, format=fmstr, vec );
      col(,1) = vec;
   }

   for( i=2; i <= naxis2; i++ ) {
      line = rdline(f);
      item = strpart( line, pos1:pos2 );
      if( is_string ) {
         col(i) = strtrim(item);
      } else {
         n = sread( item, format=fmstr, vec );
         col(,i) = vec;
      }
   }
   close, f;
   print,"Returning column with ", naxis2," elements";
   if( nff == 1 ) return ( col(1,) );
   else return col;
}
%FILE% aitoff_area.i
func aitoff_area( m, inver= )
{
   dms = dimsof( m );
   dim = dms(2);
   dimh = dms(3);
   ar = array(int,dms);
   if( 2*dimh != dim ) error,"AITOFF_AREA illegal dimensions";
   a = 360. / (1-dim);
   b = 180. - a;
   c = 180. / (dimh - 1);
   d = -90. - c;

   for(i = 1; i <= dim; i++ ) {
   for(j = 1; j <= dimh; j++ ) {
      ax = a * i + b;
      ay = c * j + d;
      v = is_void(rever_aitoff(ax,ay));
      ar(i,j) = inver ? v : !v;
   }}

   return ar;
}
%FILE% ana5.i
func ana5( next= )
{

   if( next ) system,"./next";

   yspan = 50.;

   dolslr = "jmx1_srcl_res.fits+1";
   dolspe = "jmx1_srcl_spe.fits+1";
   filmos = "jmx1_mosaic_spec.fits";

   fhslr = headfits(dolslr);
   nrows = fxpar(fhslr,"naxis2");
   swid = fxpar(fhslr,"swid");

   e_min = rdfitscol(dolslr,"e_min");
   e_max = rdfitscol(dolslr,"e_max");
   eb1 = e_min(4:19,1);
   eb2 = e_max(4:19,1);
   w = eb2 - eb1;

   rate_spe_all = rdfitscol(dolspe,"rate");
   rate_err_spe_all = rdfitscol(dolspe,"stat_err");

   for( src = 1; src <= nrows; src++ ) {
      rate_spe = rate_spe_all(,src);
      rate_err_spe = rate_err_spe_all(,src);
      is = outlier(rate_spe, 50.);
      ise = outlier(rate_err_spe, 50.);
      grow, is, ise;
      rate_spe = rem_elem(rate_spe,is);
      rate_err_spe = rem_elem(rate_err_spe,is);
      wspe = rem_elem(w,is);
      eb1spe = rem_elem(eb1,is);
      eb2spe = rem_elem(eb2,is);

      rate_mos = rdfitscol(filmos+swrite(format="+%i",src),"rate");
      rate_err_mos = rdfitscol(filmos+swrite(format="+%i",src),"stat_err");
      is = outlier(rate_mos, 50.);
      ise = outlier(rate_err_mos, 50.);
      grow, is, ise;
      rate_mos = rem_elem(rate_mos,is);
      rate_err_mos = rem_elem(rate_err_mos,is);
      wmos = rem_elem(w,is);
      eb1mos = rem_elem(eb1,is);
      eb2mos = rem_elem(eb2,is);

      window,src-1;
      yx1 = (rate_spe+rate_err_spe)/wspe;
      yx2 = (rate_mos+rate_err_mos)/wmos;
      wx1 = where( yx1 > 0.0 );
      if( numberof(wx1) ) yx1 = yx1(wx1);
      wx2 = where( yx2 > 0.0 );
      if( numberof(wx2) ) yx2 = yx2(wx2);
      yn1 = (rate_spe-rate_err_spe)/wspe;
      yn2 = (rate_mos-rate_err_mos)/wmos;
      wn1 = where( yn1 > 0.0 );
      if( numberof(wn1) ) yn1 = yn1(wn1);
      wn2 = where( yn2 > 0.0 );
      if( numberof(wn2) ) yn2 = yn2(wn2);
      yavg = sqrt(max(max(yx1),max(yx2))*min(min(yn1),min(yn2)));
      plot_spectrum, eb1spe, eb2spe, rate_spe, rate_err_spe, itype=3, \
              xr=[2.5,35.],yr=yavg*[1./yspan,yspan],color="red", \
              title="JMX1 "+swid;
      oplot_spectrum, eb1mos, eb2mos, rate_mos, rate_err_mos, color="green";
      plotsign;
      annot,mode="i";
      annot,"SRCL-RES",ps=2,symsize=1.5,color="red";
      annot,esc_underscore("mosaic_spec"),ps=2,symsize=1.5,color="green";
      annot,pos=[0.05,0.05],height=12;

   }
}
%FILE% arc_revol_check.i
/******************************************************************
 *
 *    Compare the existing science window directories in the /jemx archive
 *    with the list and mode in the pointing file to check the integrity
 *    of the archive
 *
 *      2010-10-27/NJW
 *
 ************************************************************************/

func arc_revol_check( revol )
/* DOCUMENT arc_revol_check, revol

*/
{
   strscw = swrite(format="%04i",revol);
   point_file = "/r6/jemx/pointings/pointings_"+strscw+"p.dat";
   swidp = rscol(point_file,1,str=1,nomem=1,silent=1);
   mode1 = rscol(point_file,8,str=1,nomem=1,silent=1);
   mode2 = rscol(point_file,9,str=1,nomem=1,silent=1);

   arcdir = "/jemx/arc/rev_2/scw/"+strscw;
   list = file_search("*",arcdir,dir=1);
   list = list(sort(list));
   local swidlist;
   nswidlist = pick_swid_str( list, swidlist );

   list_not_in_point = filter_done( swidp, swidlist );
   nlnip = numberof(list_not_in_point);
   if( nlnip ) {
      write,"SWIDs found in archive but not in pointings:";
      prstrarr, list_not_in_point;
   } else {
      write,"All SWIDs in the archive are also in the pointing file";
   }
   list_not_in_archive = filter_done( swidlist, swidp );
   nlnia = numberof(list_not_in_archive);
   if( nlnia ) {
      write,"SWIDs found in the pointing file but not in the archive:";
      prstrarr, list_not_in_archive;
   } else {
      write,"All SWIDs in the pointing file are also in the archive";
   }

}
%FILE% ascii.i
/*
 * ascii.i --
 *
 *	Reading ascii data from a file.
 *
 * $Id: ascii.i,v 1.2 1996/02/20 12:45:40 eric Exp $
 *
 * Copyright (c) 1996, Eric THIEBAUT (thiebaut@obs.univ-lyon1.fr, Centre de
 * Recherche Astrophysique de Lyon, 9 avenue Charles  Andre,  F-69561 Saint
 * Genis Laval Cedex).
 *
 * This program is free software; you can redistribute it and/or  modify it
 * under the terms of the GNU General Public License  as  published  by the
 * Free Software Foundation; either version 2 of the License,  or  (at your
 * option) any later version.
 *
 * 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.   See  the GNU
 * General Public License for more details (to receive a  copy  of  the GNU
 * General Public License, write to the Free Software Foundation, Inc., 675
 * Mass Ave, Cambridge, MA 02139, USA).
 *
 * ------------------------------------------------------------------------
 * History:
 *	02/20/96: release 1.1
 *	02/20/96 by Eric THIEBAUT: improve performances of asciiRead()
 *	    execution time almost divided by 2, "string.i" no more needed.
 *      02/21/96 D Munro improved performance by a factor of 250 or so.
 */

func asciiRead(file)
/* DOCUMENT data= asciiRead(name)
            data= asciiRead(file)
	read ascii numeric data in columns from file NAME, or the already
	open file FILE.
	The result is a NCOLUMNS-by-NLINES array of doubles.

	Data are read as double values arranged in columns separated
	by any number of spaces or tabs.  Comments starting with a "#"
	or any other character which is not part of a number are ignored
	up to the end-of-line.  Blank lines are ignored.
	The first non-blank/commented line gives the number of values per
	column, for subsequent lines.  Subsequent lines must have the
	same number of columns -- blanks in columns are not permitted,
	use 0.0 instead.  However, minimal error checking is performed,
	and if the data is not really in columns, asciiRead can silently
	fail to interpret your file as you would scanning it by eye.

	The read operation will be much faster if the number of commented
	lines is relatively small.  Blank lines cost nothing, while a line
	containing just a "#" is expensive.

   SEE ALSO: read
*/
{
  /* open the file if it's not already open */
  if (structof(file)==string) file= open(file);

  /* read lines one at a time until the "model" line which
   * determines the number of columns is discovered
   * assume the number of columns is less than 128 */
  x= array(0.0, 128);
  ncols= 0;
  while ((line= rdline(file))) {
    ncols= sread(line, x);
    if (ncols) break;          /* got a line with numbers */
  }
  if (!ncols) return [];

  nrows= 1;
  list= _lst([x(1:ncols)]);
  x= array(0.0, ncols, 10000/ncols + 1);
  for(;;) {
    /* try to grab at least 10000 numbers from the file
     * blank lines will be skipped, but any comments will
     * interrupt the read */
    n= read(file, x);
    if (!n) {
      /* if didn't get any, drop back to reading comments one
       * line at a time until we get some more numbers */
      while ((line= rdline(file))) {
	n= sread(line, x);
	if (n) break;
      }
      if (!line) break;    /* rdline detected end-of-file, n==0 too */
    }
    if (n%ncols) error, "data is not in columns";
    n/= ncols;

    /* grow the list the fast way, adding new values to its head
     * (adding to the tail would make growth an n^2 proposition,
     *  as would using the grow function) */
    list= _cat(x(,1:n), list);
    nrows+= n;
  }

  /* pop chunks off list and reassemble result */
  x= array(0.0, ncols, nrows);
  for (i=nrows ; list ; list=_cdr(list)) {
    n= numberof(_car(list))/ncols;
    x(,i-n+1:i)= _car(list);
    i-= n;
  }

  return x;
}
%FILE% aspec-2.1.i
#include "rmf_funcs.i"
#include "curreg.i"
#include "island.i"

// A struct for the command with parameters

struct s_Command {
   string command;
   pointer rparms;
   pointer iparms;
   pointer sparms;
}

// A struct for the command key words

struct s_Keyword {
   string keyword;
   string keyvalue;
}

// A struct for the regions

struct s_Reg {
   string type;
   string shape;
   double xcen;
   double ycen;
   long area;
   long ncts;
   pointer params;
   pointer imsegment;
   pointer n_outline;
   pointer p_outline;
   pointer x_outline;
   pointer y_outline;
}

Version = "2.1"; // 2012-01-16

void_value = [];

write,"";
write,"         --------------------------------------------------------";
write,"         |   Welcome to the spectral analysis tool: aspec-"+Version+"   |";
write,"         --------------------------------------------------------";
write,"";
write,"aspec is invoked as:  > aspec, event_file_name, ..";
write,"";
write,"   Accepts several event files that will be concatenated.";
write,"   'aspec' is command driven.";
write,"   Entering a '?' will show the command options. After exit 'aspec'";
write,"   can be continued (in the same Yorick session) by simply entering:";
write,"  > aspec";
write,"";
write,"But first choose the telescope:";
write,"      'n' for NuSTAR";
write,"      's' for SXT";
write,"      'o' for other (starts dialogue) :";
write,"";
answer = rdline(prompt=" ... ");
ccc = 1;
if( answer == "n" ) {
   write,"";
   write,"*** This is the NuSTAR verson ***";
   write,"";
   telescop = "NuSTAR";
   if( !file_test("aspec_nustar.par") ) error,"No aspec_nustar.par found in current directory";
   pixel_size = get_par("aspec_nustar.par","pixel_size"); // mm
   n_det_pixels = get_par("aspec_nustar.par","n_det_pixels");
   xdetcen = get_par("aspec_nustar.par","xdetcen"); // pixels
   ydetcen = get_par("aspec_nustar.par","ydetcen"); // pixels
   Rmf_file = get_par("aspec_nustar.par","rmf_file");
   Arf_file = get_par("aspec_nustar.par","arf_file");
   Ebegin = emin_default = get_par("aspec_nustar.par","emin_default"); // keV
   Eend =   emax_default = get_par("aspec_nustar.par","emax_default"); // keV
   pixel_area_cm2 = 0.01 * pixel_size^2;
   region_type = "simple"; // other option is 'detailed'
} else if( answer == "s" ) {
   write,"";
   write,"*** This is the SXT verson ***";
   write,"";
   telescop = "SXT";
   if( !file_test("aspec_sxt.par") ) error,"No aspec_sxt.par found in current directory";
   pixel_size = get_par("aspec_sxt.par","pixel_size"); // mm
   n_det_pixels = get_par("aspec_sxt.par","n_det_pixels");
   xdetcen = get_par("aspec_sxt.par","xdetcen"); // pixels
   ydetcen = get_par("aspec_sxt.par","ydetcen"); // pixels
   Rmf_file = get_par("aspec_sxt.par","rmf_file");
   Arf_file = get_par("aspec_sxt.par","arf_file");
   Ebegin = emin_default = get_par("aspec_sxt.par","emin_default"); // keV
   Eend =   emax_default = get_par("aspec_sxt.par","emax_default"); // keV
   pixel_area_cm2 = 0.01 * pixel_size^2;
   region_type = "simple"; // other option is 'detailed'
} else {
   write,"Not implemented yet";
   ccc = 0;
}
instrume = "MT_RAYOR-4.3";
if( ccc ) {
   write,format=" pixel_size = %.2f mm\n", pixel_size;
   write,format=" n_det_pixels = %i\n", n_det_pixels;
   write,format=" xdetcen    = %.2f pixels\n", xdetcen;
   write,format=" ydetcen    = %.2f pixels\n", ydetcen;
   write,format=" RMF: %s\n", Rmf_file;
   write,format=" ARF: %s\n", Arf_file;
   write,"";
}


func aspec( event_file, .., keep_reg= )
/* DOCUMENT aspec[,event_file][,event_file2, ..][, keep_reg=]

    A package for spectral analysis of X-ray mission event data.
    Enter '?' for a list of commands and '? <command>' for some
    more explanation.

    Giving an event_file will reset and read the event data.
    Keyword 'keep_reg' will except the defined regions from the resetting.

    Calling without an event_file will make it resume operations on
    existing data (if the Yorick session has not been interrupted).

    2010-10-20/NJW
    2010-10-28/NJW updated with normalization of spectra
*/
{

   extern Event_files, Rawx, Rawy, Rawxy, Energy, Nevents;
   extern SRegions, BRegions, Exposure, E_min, E_max, Arfs, Energ_lo, Energ_hi;
   extern Arf_file, Rmf_file, SOceans, BOceans;
   extern Rate_src, Rate_err_src, Rate_bkg, Rate_err_bkg, Spec_norm_factor;
   extern Rate_net_src, Rate_net_err_src, Spec_norm_rule, Spec_norm_text;
   extern Ebegin, Eend, Esel; // Defines current energy interval for image display
                        // and regions

   // coordinate system from first event file
   extern Coords;

  /*   Spec_norm_rule == 1  :  no renormalization i.e. spectrum in source area
   *                     2  :  spectrum per pixel
   *                     3  :  spectrum per cm2
   */
   Spec_norm_rule = 1; // default starting value
   Spec_norm_factor = 1.; // default starting value
   Spec_norm_text = "Normalized to source region area";

   if( !is_void(event_file) ) {
      Event_files = event_file;
      logfilename = get_next_filename("aspec_????.txt");
      lg = open(logfilename,"w");
      while( more_args() ) grow, Event_files, next_arg();
      n_event_files = numberof(Event_files);
   } else { // continue on current events
      if( is_void(Event_files) ) {
         write,"No session to continue ...";
         write,"Syntax:  aspec, eventfile[, eventfile2[, eventfile3, ..]][,keep_reg=]";
         return;
      }
      logfilename = get_next_filename("aspec_????.txt",latest=1);
      lg = open(logfilename,"a");
   }
   write,"Logging file: "+logfilename;
   write,lg,format="\nLog of 'aspec' on %s\n\n", ndate(3);
   erlog = open("aspec.log","w");

   if( !is_void(event_file) ) {
      for( i = 1; i <= n_event_files; i++ ) {
         if( !file_test(Event_files(i)) ) error,"File "+Event_files(i)+" is not found!";
      }
      write,erlog,"##1## resetting";
      if( !keep_reg ) SRegions = BRegions = [];

      write,"Reading "+Event_files(1)+" ...";
      dol = Event_files(1)+"+1";
      Rawx = rdfitscol(dol,"rawx");
      Rawy = rdfitscol(dol,"rawy");
      Energy = rdfitscol(dol,"energy");
      Esel = indgen(numberof(Energy));
      hdr = headfits(dol);
      Exposure = fxpar(hdr,"exposure");
      n_events = fxpar(hdr,"naxis2");
      write,lg,format="Event_file : %s,  %i events\n", Event_files(1), n_events;

      // get the WCS coordinate system
      Coords = s_Coords();
      Coords.flag = 1; // set flag for proper values until a necessary
                       // keyword is missing
      if( !is_void( (q = fxpar(hdr,"ctype1")) ) ) {
         Coords.ctype1 = q;
         if( !is_void( (q = fxpar(hdr,"ctype2")) ) ) Coords.ctype2 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"crpix1")) ) ) Coords.crpix1 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"crpix2")) ) ) Coords.crpix2 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"crval1")) ) ) Coords.crval1 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"crval2")) ) ) Coords.crval2 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"cd1_1")) ) ) Coords.cd1_1 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"cd1_2")) ) ) Coords.cd1_2 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"cd2_1")) ) ) Coords.cd2_1 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"cd2_2")) ) ) Coords.cd2_2 = q;
         else Coords.flag = 0;
      } else Coords.flag = 0;

      if( n_event_files > 1 ) {
         for( i = 2; i <= n_event_files; i++ ) {
            write,"Reading "+Event_files(i)+" ...";
            dol = Event_files(i)+"+1";
            grow, Rawx, rdfitscol(dol,"rawx");
            grow, Rawy, rdfitscol(dol,"rawy");
            grow, Energy, rdfitscol(dol,"energy");
            hdr = headfits(dol);
            exposure = fxpar(hdr,"exposure");
            n_events = fxpar(hdr,"naxis2");
            if( !near( Exposure, exposure, 1. ) ) error,"Wrong exposure in file #"+itoa(i);
            write,lg,format="Event_file : %s,  %i events\n", Event_files(i), n_events;
         }
      }

      Nevents = numberof(Rawx);
      Rawxy = (Rawy - 1)*n_det_pixels + Rawx;
      //+ Rmf_file = "/home/njw/yorick/mraytrace/nustar/test_rmf.fits";
      write,"Using RMF in: "+Rmf_file;
      E_min = rdfitscol(Rmf_file+"[EBOUNDS]","e_min");
      E_max = rdfitscol(Rmf_file+"[EBOUNDS]","e_max");
      write,"Loading ARFs from: "+Arf_file;
      Arfs = rdfitscol(Arf_file+"[SPECRESP]","SPECRESP");
      Energ_lo = rdfitscol(Arf_file+"[SPECRESP]","ENERG_LO")(,1);
      Energ_hi = rdfitscol(Arf_file+"[SPECRESP]","ENERG_HI")(,1);
   }

   im = array(int,n_det_pixels,n_det_pixels);
   for(i=1;i<=Nevents;i++) im(Rawx(i),Rawy(i)) += 1;
   mlogxy,0,0;
   disp,im,title="All events";

   command_string = "";
   while( 1 ) {
      read,format="%[^\n]",prompt="What now? ... ", command_string;
      command_string = strtrim(command_string);
      write,erlog,"##4## command given: "+command_string;
      write,lg,"Command given: "+command_string;
      cans = comparse(command_string);
      cmd = cans.command;

      if( cmd == "x" ) {
         close, lg;
         close, erlog;
         return;
      }

//
// ************************************** info *********************************************************
//
      if( cmd == "info" ) { // cominfo   -  give information on current settings
         cans = comparse(command_string, "i"); // information level
         niparms = numberof(*cans.iparms);

         write,format="Energy range: %.3f - %.3f keV\n", Ebegin, Eend;

//
// ************************************** ebds *********************************************************
//
      } else if( cmd == "ebds" ) { // comebds  -  set energy boundaries
         cans = comparse(command_string, "rr"); // Ebegin and Eend
         nrparms = numberof(*cans.rparms);
         if( nrparms == 0 ) {
            Ebegin = emin_default;
            Eend   = emax_default;
         } else if( nrparms == 1 ) {
            Ebegin = (*cans.rparms)(1);
            Eend   = emax_default;
         } else {
            Ebegin = (*cans.rparms)(1);
            Eend   = (*cans.rparms)(2);
         }
         Esel = where( Energy > Ebegin & Energy < Eend );
         nsel = numberof(Esel);
         write,format="Energy range: %.3f - %.3f keV\n", Ebegin, Eend;
         write,format="       containing %i events\n", nsel;
         dsel = where( E_max > Ebegin & E_min < Eend );
         write,format="       and %i detector energy bins\n", numberof(dsel);

      //   Update image and regions wrt. number of counts

         im = array(int,n_det_pixels,n_det_pixels);
         for(i=1;i<=nsel;i++) im(Rawx(Esel(i)),Rawy(Esel(i))) += 1;
         write,erlog,format="##5## emin emax nsel : %.2f %.2f %i\n", Ebegin, Eend, nsel;

         // update the regions
         nreg = numberof(SRegions);
         if( nreg ) {
            for( i = 1; i <= nreg; i++ ) {
               asel = *SRegions(i).imsegment; // area selection
               SRegions(i).ncts = numberof(whereany(Rawxy(Esel), asel));
               asel = *BRegions(i).imsegment; // area selection
               BRegions(i).ncts = numberof(whereany(Rawxy(Esel), asel));
            }
         }

//
// ************************************** imdisp & lmdisp *********************************************************
//
      } else if( cmd == "imdisp" || cmd == "lmdisp" ) { // comimdisp, comlmdisp   -  display detector image
         cans = comparse(command_string, "r"); // image folding sigma

         rim = double(im);
         if( !is_void(*cans.rparms) ) rim = gfconvol(rim,(*cans.rparms)(1));
         mlogxy,0,0;
         if( cmd == "lmdisp" ) disp,log(1.0+rim);
         else disp,rim;

         // add the regions
         nreg = numberof(SRegions);
         for( i = 1; i <= nreg; i++ ) {
            if( SRegions(i).type == "detailed" ) {
               nout = *SRegions(i).n_outline;
               pout = *SRegions(i).p_outline;
               xout = *SRegions(i).x_outline;
               yout = *SRegions(i).y_outline;
               for( j = 1; j <= numberof(nout); j++ ) {
                  oplot,xout(pout(j):pout(j)-1+nout(j)),yout(pout(j):pout(j)-1+nout(j)),color="green";
               }
            } else {
               reg_params = *SRegions(i).params;
               shape      = SRegions(i).shape;
               if( shape == "c" ) {
                  angles = span(0,2*pi,100);
                  oplot,reg_params(1) + reg_params(3)*cos(angles), \
                        reg_params(2) + reg_params(3)*sin(angles), color="green";
               }
               if( shape == "a" ) {
                  angles = span(0,2*pi,100);
                  oplot,reg_params(1) + reg_params(3)*cos(angles), \
                        reg_params(2) + reg_params(3)*sin(angles), color="green";
                  oplot,reg_params(1) + reg_params(4)*cos(angles), \
                        reg_params(2) + reg_params(4)*sin(angles), color="green";
               }
               if( shape == "b" ) {
                  oplot,[reg_params(1),reg_params(3),reg_params(3),reg_params(1), reg_params(1)], \
                        [reg_params(2),reg_params(2),reg_params(4),reg_params(4), reg_params(2)], \
                        color="green";
               }
            }
            if( BRegions(i).shape != "v" ) {
               if( BRegions(i).type == "detailed" ) {
                  nout = *BRegions(i).n_outline;
                  pout = *BRegions(i).p_outline;
                  xout = *BRegions(i).x_outline;
                  yout = *BRegions(i).y_outline;
                  for( j = 1; j <= numberof(nout); j++ ) {
                     oplot,xout(pout(j):pout(j)-1+nout(j)),yout(pout(j):pout(j)-1+nout(j)),color="red";
                  }
               } else {
                  reg_params = *BRegions(i).params;
                  shape      = BRegions(i).shape;
                  if( shape == "c" ) {
                     angles = span(0,2*pi,100);
                     oplot,reg_params(1) + reg_params(3)*cos(angles), \
                           reg_params(2) + reg_params(3)*sin(angles), color="red";
                  }
                  if( shape == "a" || shape == "d" ) {
                     angles = span(0,2*pi,100);
                     oplot,reg_params(1) + reg_params(3)*cos(angles), \
                           reg_params(2) + reg_params(3)*sin(angles), color="red";
                     oplot,reg_params(1) + reg_params(4)*cos(angles), \
                           reg_params(2) + reg_params(4)*sin(angles), color="red";
                  }
                  if( shape == "b" ) {
                     oplot,[reg_params(1),reg_params(3),reg_params(3),reg_params(1), reg_params(1)], \
                           [reg_params(2),reg_params(2),reg_params(4),reg_params(4), reg_params(2)], \
                           color="red";
                  }
               }
            }
         }
//
// ************************************** imsave *********************************************************
//
      } else if( cmd == "imsave"  ) { // comimsave  -  save detector image to FITS
         cans = comparse(command_string, "s"); // given filename

         if( is_void(*cans.sparms) ) {
            fits_name = get_next_filename("aspec_image_????.fits");
         } else {
            fits_name = (*cans.sparms)(1);
         }
         write,lg,"Writing to: "+fits_name;
         write,"Writing to: "+fits_name;
         kwds_init;
         kwds_set,"DATE",ndate(3),"Date/time of file creation";
         kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
         kwds_set,"E_MIN", Ebegin, "[keV] Lower energy limit";
         kwds_set,"E_MAX", Eend, "[keV] Upper energy limit";
         for( i = 1; i <= numberof(Event_files); i++ ) {
            kwds_set,"EVFILE"+itoa(i),Event_files(i);
         }
         if( Coords.flag) {
            kwds_set,"CTYPE1", Coords.ctype1, "Type of coord.system";
            kwds_set,"CTYPE2", Coords.ctype2, "Type of coord.system";
            kwds_set,"CRPIX1", Coords.crpix1, "Reference pixel position";
            kwds_set,"CRPIX2", Coords.crpix2, "Reference pixel position";
            kwds_set,"CRVAL1", Coords.crval1, "Reference coord value";
            kwds_set,"CRVAL2", Coords.crval2, "Reference coord value";
            kwds_set,"CD1_1", Coords.cd1_1, "Part of transf. matrix";
            kwds_set,"CD1_2", Coords.cd1_2, "Part of transf. matrix";
            kwds_set,"CD2_1", Coords.cd2_1, "Part of transf. matrix";
            kwds_set,"CD2_2", Coords.cd2_2, "Part of transf. matrix";
         }
         kwds_set,"EXTNAME","ASPEC_IMAGE","Name of this extension";
         writefits, fits_name, im;
//
// ************************************** rpos *********************************************************
//
      } else if( cmd == "rpos" ) { // comrpos  -  read position in image
         pos = curmark1( style=0,prompt="Mark the position ... " );
         write,format="Pixel position: %7.3f %7.3f\n", pos(1), pos(2);
         local coord1, coord2;
         skypos_fits, Coords, pos(1), pos(2), coord1, coord2, to_sky=1;
         write,format="Coord position: %7.3 %7.3\n", coord1, coord2;
         write,format="Pixel value : %i counts\n", im(int(pos(1)+0.5),int(pos(2)+0.5));
//
// ************************************** mreg *********************************************************
//
      } else if( cmd == "mreg" ) { // commreg  -  make region pair
         cans = comparse(command_string, "s");
         if( is_void(*cans.sparms) ) {
            s_shape = "c";  // circular region with annulus is the default
            b_shape = "d";  // Annulus with predefined center
         } else {
            shape = (*cans.sparms)(1);
            if( strlen(shape) != 2 ) {
               write,"Parameter must be two-letter string";
               continue;
            }
            s_shape = strpart(shape,1:1);
            b_shape = strpart(shape,2:2);
            if( s_shape != "c" && s_shape != "b" ) {
               write,"Parameter must have c or b as first letter";
               continue;
            }
            if( b_shape != "a" && b_shape != "b" && b_shape != "v" ) {
               write,"Parameter must have a, b, or v as second letter";
               continue;
            }
         }
         // ******  Prepare the regions arrays
         local xcen, ycen, sreg_params, breg_params;
         if( is_void(SRegions) ) {
            //+ 101119 SRegions = s_Reg();
            //+ 101119 BRegions = s_Reg();
            SRegions = array(s_Reg,1);
            BRegions = array(s_Reg,1);
         } else {
            grow, SRegions, s_Reg();
            grow, BRegions, s_Reg();
         }
         nreg = numberof(SRegions);
         // ******  Define the source region
         write,"Define the source region:";
         sel = int(curreg(im,s_shape, xcen, ycen, sreg_params, color="green",thick=2));
         if( region_type != "simple" ) {
            ocean = array(short,n_det_pixels,n_det_pixels);
            ocean(sel) = 1;
            isle = island(ocean);
            c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
            n_outline = int(n_outline);
            p_outline = int(p_outline);
            SRegions(nreg).n_outline = &n_outline;
            SRegions(nreg).p_outline = &p_outline;
            SRegions(nreg).x_outline = &x_outline;
            SRegions(nreg).y_outline = &y_outline;
         }
         SRegions(nreg).type = region_type;
         SRegions(nreg).params = &sreg_params;
         SRegions(nreg).shape = s_shape;
         SRegions(nreg).xcen = xcen;
         SRegions(nreg).ycen = ycen;
         SRegions(nreg).area = numberof(sel);
         SRegions(nreg).imsegment = &sel;
         SRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
         // ******  Define the background region
         if( b_shape == "v" ) { // void i.e. no background but dummy to be defined
            BRegions(nreg).shape = b_shape;
            BRegions(nreg).xcen = xcen;
            BRegions(nreg).ycen = ycen;
            BRegions(nreg).area = 1; // to avoid division by zero
            //+ BRegions(nreg).imsegment = &sel;
            BRegions(nreg).imsegment = &void_value;
            BRegions(nreg).ncts = 0;
            BRegions(nreg).type = region_type;
         } else { // 'a', 'd', or 'b' (annulus or box)
            write,"Define the background region:";
            sel = int(curreg(im, b_shape, xcen, ycen, breg_params, color="red",thick=2));
            if( region_type != "simple" ) {
               ocean = array(short,n_det_pixels,n_det_pixels);
               ocean(sel) = 1;
               isle = island(ocean);
               c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
               n_outline = int(n_outline);
               p_outline = int(p_outline);
               BRegions(nreg).n_outline = &n_outline;
               BRegions(nreg).p_outline = &p_outline;
               BRegions(nreg).x_outline = &x_outline;
               BRegions(nreg).y_outline = &y_outline;
            }
            BRegions(nreg).type = region_type;
            BRegions(nreg).shape = b_shape;
            BRegions(nreg).params = &breg_params;
            BRegions(nreg).xcen = xcen;
            BRegions(nreg).ycen = ycen;
            BRegions(nreg).area = numberof(sel);
            BRegions(nreg).imsegment = &sel;
            BRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
         }

//
// ************************************** dreg *********************************************************
//
      } else if( cmd == "dreg" ) { // comdreg  -  delete region(s)
         cans = comparse(command_string, "i");
         nreg = numberof(SRegions);
         if( nreg == 0 ) {
            write,"No regions have been defined ...";
         } else {
            if( !is_void(*cans.iparms) ) {
               // delete a single region
               i = (*cans.iparms)(1);
               if( i < 1 || i > nreg ) {
                  write,"Requested region is not found ...";
                  continue;
               }
               if( nreg == 1 ) {
                  SRegions = BRegions = [];
               } else {
                  SRegions = rem_elem( SRegions, i );
                  BRegions = rem_elem( BRegions, i );
               }
            } else {
               SRegions = BRegions = [];
            }
         }
//
// ************************************** ireg *********************************************************
//
      } else if( cmd == "ireg" ) { // comireg  -  show region information
         cans = comparse(command_string, "i");
         nreg = numberof(SRegions);
         if( nreg == 0 ) {
            write,"No regions have been defined ...";
         } else {
            i1 = 1; i2 = nreg; // default, show all regions
            if( !is_void(*cans.iparms) ) {
               i1 = i2 = (*cans.iparms)(1);
               if( i1 < 1 || i1 > nreg ) {
                  write,"Requested region is not found ...";
                  i1 = 1; i2 = nreg;
               }
            }
            write,"      #    xcen   ycen     area  shape      ncts";
            for( i = i1; i <= i2; i++ ) {
               write,format="Src: %3i  %6.2f %6.2f %8i    %s %11i\n", \
                  i, SRegions(i).xcen, SRegions(i).ycen, SRegions(i).area, \
                         SRegions(i).shape, SRegions(i).ncts;
               write,format="Bkg: %3i  %6.2f %6.2f %8i    %s %11i\n", \
                  i, BRegions(i).xcen, BRegions(i).ycen, BRegions(i).area, \
                         BRegions(i).shape, BRegions(i).ncts;
               n = SRegions(i).ncts;
               k = BRegions(i).area > 0 ? double(SRegions(i).area)/BRegions(i).area : 1.0;
               b = BRegions(i).ncts;
               dn = sqrt(n + b*(k^2));
               write,format=" Net counts: %.2f +- %.2f\n", n - b*k, dn;
            }
         }
//
// ************************************** sreg *********************************************************
//
      } else if( cmd == "sreg" ) { // comsreg  -  save region information
         nreg = numberof(SRegions);
         cans = comparse(command_string, "i"); // If number > 0 then save that one
                                               // If number == 0 then save all
                                               // If number is not given then save most recent
                                               // In any case a new file will be created
         if( is_void(*cans.iparms) ) {
            n = nreg;
         } else {
            n = (*cans.iparms)(1);
         }
    /*
     *   A region is described by a single row in a FITS files
     */
         local serstr;
         sregfile = get_next_filename("sreg_????.fits", serstr);
         bregfile = "breg_"+serstr+".fits";
         write,"      saving into "+sregfile+" and "+bregfile;
         write,lg,"      saving into "+sregfile+" and "+bregfile;
         if( n == 0 ) { // save all
           // --     source regions
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_SREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of source regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,sregfile,"TYPE",SRegions.type, \
                                "SHAPE",SRegions.shape, \
                                "XCEN",SRegions.xcen, \
                                "YCEN",SRegions.ycen, \
                                "AREA",SRegions.area, \
                                "NCTS",SRegions.ncts, \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            for( i = 1; i <= nreg; i++ ) {
               if( !is_void(*SRegions(i).imsegment) ) {
                  fits_bintable_poke,sregfile+"+1",i,"IMSEGMENT",*SRegions(i).imsegment;
                  if( SRegions(i).type == "detailed" ) {
                     fits_bintable_poke,sregfile+"+1",i,"N_OUTLINE",*SRegions(i).n_outline;
                     fits_bintable_poke,sregfile+"+1",i,"P_OUTLINE",*SRegions(i).p_outline;
                     fits_bintable_poke,sregfile+"+1",i,"X_OUTLINE",*SRegions(i).x_outline;
                     fits_bintable_poke,sregfile+"+1",i,"Y_OUTLINE",*SRegions(i).y_outline;
                  }
                  fits_bintable_poke,sregfile+"+1",i,"PARAMS",*SRegions(i).params;
               }
            }
           // --     background regions
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_BREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of background regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,bregfile,"TYPE",BRegions.type, \
                                "SHAPE",BRegions.shape, \
                                "XCEN",BRegions.xcen, \
                                "YCEN",BRegions.ycen, \
                                "AREA",BRegions.area, \
                                "NCTS",BRegions.ncts, \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            for( i = 1; i <= nreg; i++ ) {
               if( !is_void(*BRegions(i).imsegment) ) {
                  fits_bintable_poke,bregfile+"+1",i,"IMSEGMENT",*BRegions(i).imsegment;
                  if( SRegions(i).type == "detailed" ) {
                     fits_bintable_poke,bregfile+"+1",i,"N_OUTLINE",*BRegions(i).n_outline;
                     fits_bintable_poke,bregfile+"+1",i,"P_OUTLINE",*BRegions(i).p_outline;
                     fits_bintable_poke,bregfile+"+1",i,"X_OUTLINE",*BRegions(i).x_outline;
                     fits_bintable_poke,bregfile+"+1",i,"Y_OUTLINE",*BRegions(i).y_outline;
                  }
                  fits_bintable_poke,sregfile+"+1",i,"PARAMS",*BRegions(i).params;
               }
            }
         } else { // save the specified one
           //  --  the source region
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_SREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a singls source region";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,sregfile,"TYPE",[SRegions(n).type], \
                                "SHAPE",[SRegions(n).shape], \
                                "XCEN",[SRegions(n).xcen], \
                                "YCEN",[SRegions(n).ycen], \
                                "AREA",[SRegions(n).area], \
                                "NCTS",[SRegions(n).ncts], \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            if( !is_void(*SRegions(n).imsegment) ) {
               fits_bintable_poke,sregfile+"+1",1,"IMSEGMENT",*SRegions(n).imsegment;
               if( SRegions(n).type == "detailed" ) {
                  fits_bintable_poke,sregfile+"+1",1,"N_OUTLINE",*SRegions(n).n_outline;
                  fits_bintable_poke,sregfile+"+1",1,"P_OUTLINE",*SRegions(n).p_outline;
                  fits_bintable_poke,sregfile+"+1",1,"X_OUTLINE",*SRegions(n).x_outline;
                  fits_bintable_poke,sregfile+"+1",1,"Y_OUTLINE",*SRegions(n).y_outline;
               }
               fits_bintable_poke,sregfile+"+1",n,"PARAMS",*SRegions(n).params;
            }
           // --  the background region
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_BREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of source regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,bregfile,"TYPE",[BRegions(n).type], \
                                "SHAPE",[BRegions(n).shape], \
                                "XCEN",[BRegions(n).xcen], \
                                "YCEN",[BRegions(n).ycen], \
                                "AREA",[BRegions(n).area], \
                                "NCTS",[BRegions(n).ncts], \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            if( !is_void(*BRegions(n).imsegment) ) {
               fits_bintable_poke,bregfile+"+1",1,"IMSEGMENT",*BRegions(n).imsegment;
               if( SRegions(n).type == "detailed" ) {
                  fits_bintable_poke,bregfile+"+1",1,"N_OUTLINE",*BRegions(n).n_outline;
                  fits_bintable_poke,bregfile+"+1",1,"P_OUTLINE",*BRegions(n).p_outline;
                  fits_bintable_poke,bregfile+"+1",1,"X_OUTLINE",*BRegions(n).x_outline;
                  fits_bintable_poke,bregfile+"+1",1,"Y_OUTLINE",*BRegions(n).y_outline;
               }
               fits_bintable_poke,bregfile+"+1",n,"PARAMS",*BRegions(n).params;
            }
         }
//
// ************************************** lreg *********************************************************
//
      } else if( cmd == "lreg" ) { // comlreg  -  load region information
         nreg = numberof(SRegions);
         //   Command:   lreg NNNN [num]
         cans = comparse(command_string, "si"); // If number > 0 is given then load that one
                                                // If number == 0 then load all in file
                                                // If number is not given then load first
                                                // region in the file
        /*
         *   Check the command and the existence of region files
         */

         if( is_void(*cans.sparms) ) {
            error,"Illegal command for lreg";
         } else {
            serstr = (*cans.sparms)(1);
            lserstr = strlen(serstr);
            if( lserstr != 4 ) error,"Illegal length of str for lreg";
            sregfile = "sreg_"+serstr+".fits";
            if( !file_test(sregfile) ) error,sregfile+" is not found";
            bregfile = "breg_"+serstr+".fits";
            if( !file_test(bregfile) ) error,bregfile+" is not found";
         }

         if( is_void(*cans.iparms) ) {
            n = 1; // 'n' is the row number
         } else {
            n = (*cans.iparms)(1);
         }

         shdr = headfits(sregfile+"+1");
         bhdr = headfits(bregfile+"+1");
         nrows = fxpar( shdr, "naxis2" );
         if( nrows != fxpar( bhdr, "naxis2" ) ) error,"Different number of rows";

         if( n > nrows ) error,"Region number exceeds number of rows";

         // make room for the regions to be loaded

         if( n ) {
            grow, SRegions, array(s_Reg,1);
            grow, BRegions, array(s_Reg,1);
         } else {
            grow, SRegions, array(s_Reg,nrows);
            grow, BRegions, array(s_Reg,nrows);
         }

    /*
     *   A region is described by a single row in a FITS files
     */
         if( n == 0 ) { // load all
           // --     source regions
            type  = rdfitscol(sregfile+"+1","TYPE");
            shape = rdfitscol(sregfile+"+1","SHAPE");
            xcen = rdfitscol(sregfile+"+1","XCEN");
            ycen = rdfitscol(sregfile+"+1","YCEN");
            area = rdfitscol(sregfile+"+1","AREA");
            ncts = rdfitscol(sregfile+"+1","NCTS");
            SRegions(nreg+1:nreg+nrows).type  = type;
            SRegions(nreg+1:nreg+nrows).shape = shape;
            SRegions(nreg+1:nreg+nrows).xcen = xcen;
            SRegions(nreg+1:nreg+nrows).ycen = ycen;
            SRegions(nreg+1:nreg+nrows).area = area;
            SRegions(nreg+1:nreg+nrows).ncts = ncts;
            for( i = 1; i <= nrows; i++ ) {
               d1 = fits_bintable_peek(sregfile+"+1",i,"IMSEGMENT");
               SRegions(nreg+i).imsegment = &d1;
               // update number of counts
               if( !is_void(d1) ) SRegions(nreg+i).ncts = numberof(whereany(Rawxy, d1));
               d1 = fits_bintable_peek(sregfile+"+1",i,"N_OUTLINE");
               SRegions(nreg+i).n_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",i,"P_OUTLINE");
               SRegions(nreg+i).p_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",i,"X_OUTLINE");
               SRegions(nreg+i).x_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",i,"Y_OUTLINE");
               SRegions(nreg+i).y_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",i,"PARAMS");
               SRegions(nreg+i).params = &d1;
            }
           // --     background regions
            type  = rdfitscol(bregfile+"+1","TYPE");
            shape = rdfitscol(bregfile+"+1","SHAPE");
            xcen = rdfitscol(bregfile+"+1","XCEN");
            ycen = rdfitscol(bregfile+"+1","YCEN");
            area = rdfitscol(bregfile+"+1","AREA");
            ncts = rdfitscol(bregfile+"+1","NCTS");
            BRegions(nreg+1:nreg+nrows).type = type;
            BRegions(nreg+1:nreg+nrows).shape = shape;
            BRegions(nreg+1:nreg+nrows).xcen = xcen;
            BRegions(nreg+1:nreg+nrows).ycen = ycen;
            BRegions(nreg+1:nreg+nrows).area = area;
            BRegions(nreg+1:nreg+nrows).ncts = ncts;
            for( i = 1; i <= nrows; i++ ) {
               d1 = fits_bintable_peek(bregfile+"+1",i,"IMSEGMENT");
               BRegions(nreg+i).imsegment = &d1;
               // update number of counts
               if( !is_void(d1) ) BRegions(nreg+i).ncts = numberof(whereany(Rawxy, d1));
               d1 = fits_bintable_peek(bregfile+"+1",i,"N_OUTLINE");
               BRegions(nreg+i).n_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",i,"P_OUTLINE");
               BRegions(nreg+i).p_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",i,"X_OUTLINE");
               BRegions(nreg+i).x_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",i,"Y_OUTLINE");
               BRegions(nreg+i).y_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",i,"PARAMS");
               BRegions(nreg+i).params = &d1;
            }
         } else { // load the specified one(s)
           //  --  the source region
            type  = rdfitscol(sregfile+"+1","TYPE");
            shape = rdfitscol(sregfile+"+1","SHAPE");
            xcen = rdfitscol(sregfile+"+1","XCEN");
            ycen = rdfitscol(sregfile+"+1","YCEN");
            area = rdfitscol(sregfile+"+1","AREA");
            ncts = rdfitscol(sregfile+"+1","NCTS");
            SRegions(nreg+1).type  = type(n);
            SRegions(nreg+1).shape = shape(n);
            SRegions(nreg+1).xcen = xcen(n);
            SRegions(nreg+1).ycen = ycen(n);
            SRegions(nreg+1).area = area(n);
            SRegions(nreg+1).ncts = ncts(n);

            d1 = fits_bintable_peek(sregfile+"+1",n,"IMSEGMENT");
            SRegions(nreg+1).imsegment = &d1;
            // update number of counts
            if( !is_void(d1) ) SRegions(nreg+1).ncts = numberof(whereany(Rawxy, d1));
            d1 = fits_bintable_peek(sregfile+"+1",n,"N_OUTLINE");
            SRegions(nreg+1).n_outline = &d1;
            d1 = fits_bintable_peek(sregfile+"+1",n,"P_OUTLINE");
            SRegions(nreg+1).p_outline = &d1;
            d1 = fits_bintable_peek(sregfile+"+1",n,"X_OUTLINE");
            SRegions(nreg+1).x_outline = &d1;
            d1 = fits_bintable_peek(sregfile+"+1",n,"Y_OUTLINE");
            SRegions(nreg+1).y_outline = &d1;
            d1 = fits_bintable_peek(sregfile+"+1",n,"PARAMS");
            SRegions(nreg+1).params = &d1;

           // --  the background region
            type  = rdfitscol(bregfile+"+1","TYPE");
            shape = rdfitscol(bregfile+"+1","SHAPE");
            xcen = rdfitscol(bregfile+"+1","XCEN");
            ycen = rdfitscol(bregfile+"+1","YCEN");
            area = rdfitscol(bregfile+"+1","AREA");
            ncts = rdfitscol(bregfile+"+1","NCTS");
            BRegions(nreg+1).type = type(n);
            BRegions(nreg+1).shape = shape(n);
            BRegions(nreg+1).xcen = xcen(n);
            BRegions(nreg+1).ycen = ycen(n);
            BRegions(nreg+1).area = area(n);
            BRegions(nreg+1).ncts = ncts(n);

            d1 = fits_bintable_peek(bregfile+"+1",n,"IMSEGMENT");
            BRegions(nreg+1).imsegment = &d1;
            // update number of counts
            if( !is_void(d1) ) BRegions(nreg+1).ncts = numberof(whereany(Rawxy, d1));
            d1 = fits_bintable_peek(bregfile+"+1",n,"N_OUTLINE");
            BRegions(nreg+1).n_outline = &d1;
            d1 = fits_bintable_peek(bregfile+"+1",n,"P_OUTLINE");
            BRegions(nreg+1).p_outline = &d1;
            d1 = fits_bintable_peek(bregfile+"+1",n,"X_OUTLINE");
            BRegions(nreg+1).x_outline = &d1;
            d1 = fits_bintable_peek(bregfile+"+1",n,"Y_OUTLINE");
            BRegions(nreg+1).y_outline = &d1;
            d1 = fits_bintable_peek(bregfile+"+1",n,"PARAMS");
            BRegions(nreg+1).params = &d1;
         }
//
// ************************************** ps *********************************************************
//
      } else if( cmd == "ps" ) { // comps - dump plot to ps file
         cans = comparse(command_string, "s");
         plotsign;
         plotname,"Spectrum by aspec";
         zps,outfile=(*cans.sparms)(1),noc=1;
//
// ************************************** ss *********************************************************
//
      } else if( cmd == "ss" ) { // comss - save spectrum and background
         bb = comparse(command_string,"ssss");
         nbb = numberof(*bb.sparms);
         ireg = 0;
         ignbkg = 0; // ignore background
         if( nbb ) {
            for( i = 1; i <= nbb; i++ ) {
               kbb = keyparse((*bb.sparms)(i));
               if( is_void(kbb) ) {
                  cans = comparse(command_string, "i");
                  ireg = (*cans.iparms)(i);
                  write,"Setting ireg ("+itoa(ireg)+") from simple value ...";
               } else {
                  if( kbb.keyword == "ignbkg" ) {
                     ignbkg = kbb.keyvalue;
                     write,"Setting ignbkg ("+itoa(ignbkg)+") from keyword ...";
                  }
                  if( kbb.keyword == "reg" ) {
                     ireg = kbb.keyvalue;
                     write,"Setting ireg ("+itoa(ireg)+") from keyword ...";
                  }
               }
            }
         }
         nreg = numberof(SRegions);
         if( ireg == 0 ) ireg = nreg;
         write,lg,"Extracting spectrum for region # ",+itoa(ireg);

         //  Extract the spectrum

         s_sel = whereany(Rawxy, *SRegions(ireg).imsegment);
         b_sel = BRegions(ireg).shape == "v" ? [] : whereany(Rawxy, *BRegions(ireg).imsegment);
         if( ignbkg ) b_sel = [];
         specbinning, Energy(s_sel), E_min, E_max, Rate_src, Rate_err_src, exposure=Exposure;
         if( is_void(b_sel) ) {
            Rate_bkg = Rate_err_bkg = Rate_src*0;
         } else {
            specbinning, Energy(b_sel), E_min, E_max, Rate_bkg, Rate_err_bkg, exposure=Exposure;
         }
         corf = float(SRegions(ireg).area)/BRegions(ireg).area;
         Rate_bkg *= corf;    // normalize to source area
         Rate_err_bkg *= corf;
         Rate_net_src = Rate_src - Rate_bkg;
         Rate_net_err_src = sqrt(Rate_err_src^2 + Rate_err_bkg^2);

         //  Renormalize the spectrum

         if( Spec_norm_rule == 2 ) { // per pixel
            Spec_norm_factor = 1.0/SRegions(ireg).area;
         } else if( Spec_norm_rule == 3 ) { // per cm2
            Spec_norm_factor = 1.0/(SRegions(ireg).area*pixel_area_cm2);
         } else Spec_norm_factor = 1.0;

         Rate_src *= Spec_norm_factor;
         Rate_err_src *= Spec_norm_factor;
         Rate_bkg *= Spec_norm_factor;
         Rate_err_bkg *= Spec_norm_factor;
         Rate_net_src *= Spec_norm_factor;
         Rate_net_err_src *= Spec_norm_factor;

         // select the ARF based on distance to center
         dist = sqrt((SRegions(ireg).xcen - xdetcen)^2 + (SRegions(ireg).ycen - ydetcen)^2);
         //  now in pixels, convert to arcmin
         dist *= (pixel_size*180.*60.)/(10140.*pi);
         // given that the focal length is 10140 mm
         d = span(0.,9.,10);
         w = where( d > dist ); // now w(1) is the index on one side
                 // and w(1)-1 is the index on the other side
         if( !numberof(w) ) {
            write,"The region center is too far away";
         } else {
            i = w(1) - 1;
            arf = float(Arfs(,i) + ((dist - d(i))/(d(i+1)-d(i)))*(Arfs(,i+1)-Arfs(,i)));
            arffile = fullpath(get_next_filename("arf_????.fits"));
            arf2phaii, arffile, arf, Energ_lo, Energ_hi, extname="SPECRESP",\
                instrume=instrume,telescop=telescop;
            write,"ARF file made : "+arffile;
            local ser_str;
            specfile = get_next_filename("spec_????.fits",ser_str);
            bkgfile  = "bkg_"+ser_str+".fits";
            kwds_init;
            kwds_set,"NUMSRCPX", SRegions(ireg).area,"Number of source pixels";
            kwds_set,"NUMBKGPX", BRegions(ireg).area,"Number of background pixels";
            kwds_set,"REGXCEN", SRegions(ireg).xcen,"X pixel for region center";
            kwds_set,"REGYCEN", SRegions(ireg).ycen,"Y pixel for region center";
            kwds_set,"SRGSHAPE", SRegions(ireg).shape,"Shape of source region";
            kwds_set,"BRGSHAPE", BRegions(ireg).shape,"Shape of background region";
            kwds_set,"NORMFACT", Spec_norm_factor,"Spectral renormalization factor";
            kwds_set,"NORMTEXT", Spec_norm_text,"Explanation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            spec2phaii,specfile,Rate_net_src,Rate_net_err_src,ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,backfile=bkgfile,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Spectrum has been written to : "+specfile;
            write,lg,"Spectrum has been written to : "+specfile;
            spec2phaii,bkgfile,Rate_bkg,Rate_err_bkg,ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Background has been written to : "+bkgfile;
            write,lg,"Background has been written to : "+bkgfile;
         }
//
// ************************************** normspec *********************************************************
//
      } else if( cmd == "normspec" ) { // comnormspec - normalize spectrum
         cans = comparse(command_string,"s");
         if( !is_void(*cans.sparms) ) {
            if( (*cans.sparms)(1) == "1" ) {
               Spec_norm_rule = 1;
               Spec_norm_text = "Normalized to source region area";
            } else if( (*cans.sparms)(1) == "pixel" ) {
               Spec_norm_rule = 2;
               Spec_norm_text = "Normalized to a single pixel";
            } else if( (*cans.sparms)(1) == "cm2" ) {
               Spec_norm_rule = 3;
               Spec_norm_text = "Normalized to a cm2 on the detector";
            }
            write,"Next spectrum will be "+Spec_norm_text;
         }
//
// ************************************** pspec *********************************************************
//
      } else if( cmd == "pspec" ) { // compspec  - plot most recent spectrum
         cans = comparse(command_string,"r");
         frac = is_void(*cans.rparms) ? 0.2 : (*cans.rparms)(1);
         //+ 101123 plot_spectrum,E_min,E_max,Rate_src,Rate_err_src,itype=3;
         local ob1, ob2, orate, orate_err;
         specrebinninga, E_min, E_max, Rate_src, Rate_err_src, frac, ob1, ob2, orate, orate_err;
         plot_spectrum, ob1, ob2, orate, orate_err, itype=3;
         if(!is_void(b_sel)) {
            specrebinninga, E_min, E_max, Rate_bkg, Rate_err_bkg, frac, ob1, ob2, orate, orate_err;
            oplot_spectrum, ob1, ob2, orate, orate_err,color="red";
         }
         specrebinninga, E_min, E_max, Rate_net_src, Rate_net_err_src, frac, ob1, ob2, orate, orate_err;
         oplot_spectrum, ob1, ob2, orate, orate_err,color="green";
//
// ************************************** ? *********************************************************
//
      } else if( cmd == "?" ) { // com?
         cans = comparse(command_string,"s");
         if( is_void(*cans.sparms) ) { // show overview
            write,"info        show current settings,";
            write,"ebds        set energy boundaries,";
            write,"imdisp      display detector image between current energy limits,";
            write,"lmdisp      display detector logarithmic image between current energy limits,";
            write,"ps          dump current image to .ps file,";
            write,"imsave      write image between current energy limits to FITS file,";
            write,"mreg        make a region pair,";
            write,"dreg        delete a region pair,";
            write,"sreg        save region pair(s),";
            write,"lreg        load region pair(s),";
            write,"ireg        show info on loaded/created regions,";
            write,"normspec    setup a normalization of spectra,";
            write,"ss          create and save spectrum,";
            write,"pspec       plot most recent spectrum,";
            write,"rpos        read position in image in pixels and in WCS,";
            write,"x           exit aspec,";
            write,"?           help - this overview,";
            write,"? <command> help on specified command.";
         } else {
            if( (*cans.sparms)(1) == "imdisp" || (*cans.sparms)(1) == "lmdisp" ) {
               write,"imdisp [sigma] - display image for current setting of emin and emax";
               write,"lmdisp [sigma] - display logarithmic image for current setting of emin and emax";
               write,"                A Gauss kernel smoothing is applied if sigma is given.";
            } else if( (*cans.sparms)(1) == "info" ) {
               write,"info      - show information on current settings";
            } else if( (*cans.sparms)(1) == "ebds" ) {
               write,"ebds [emin [emax]] - set the energy boundaries for";
               write,"                image display and number counts in regions.";
            } else if( (*cans.sparms)(1) == "imsave" ) {
               write,"imsave [filename] - save image for current setting of emin and emax to FITS file";
               write,"                The file name will be automatically assigned unless given.";
            } else if( (*cans.sparms)(1) == "mreg" ) {
               write,"mreg [shape] - define a region pair, src + bkg, by help of the cursor";
               write,"          shape (if given, default is 'ca') must be a two letter string.";
               write,"                The first letter refers to the source region and it can";
               write,"                one of \"c\" (circle) and \"b\" (box).";
               write,"                The second letter refers to the background region and can";
               write,"                be one of \"a\" (annulus with same center as the source),";
               write,"                \"b\" (box), and \"v\" (void, no background will be subtracted).";
            } else if( (*cans.sparms)(1) == "ireg" ) {
               write,"ireg [number] - show region properties for all regions";
               write,"               unless the requested one is given.";
            } else if( (*cans.sparms)(1) == "dreg" ) {
               write,"dreg [number] - delete all regons";
               write,"               unless the requested one is given.";
            } else if( (*cans.sparms)(1) == "sreg" ) {
               write,"sreg [number] - save a region pair, src + bkg, into files";
               write,"               sreg_nnnn.fits and breg_nnnn.fits, where 'nnnn'"
               write,"               is a serial number. 'number' is the number";
               write,"               in the current region list. If omitted then the most recent";
               write,"               region will be saved. If set to zero the all regions will be saved.";
            } else if( (*cans.sparms)(1) == "lreg" ) {
               write,"lreg nnnn [number] - load a region pair, src + bkg, from files";
               write,"               sreg_nnnn.fits and breg_nnnn.fits, where 'nnnn'"
               write,"               is a serial number. 'number' is the row number";
               write,"               in the table. If omitted the first region will be";
               write,"               loaded, if zero all regions (rows) will be loaded.";
               write,"               The number of counts information will be updated";
               write,"               based on the current event list.";
            } else if( (*cans.sparms)(1) == "normspec" ) {
               write,"normspec word - setup the spectral normalization";
               write,"          1      return to spectrum in source area";
               write,"          cm2    give spectrum per cm2 on the detector";
               write,"          pixel  give spectrum per pixel on the detector";
               write," Must be defined before the spectrum is extracted and saved.";
            } else if( (*cans.sparms)(1) == "ss" ) {
               write,"ss [region]  - create and save spectrum with standard filename";
               write,"    region is its number from the list of regions,";
               write,"    if not given the most recent region will be used.";
               write,"  If spectral normalization is requested then the \"normspec\"";
               write,"  command must be given first.";
            } else if( (*cans.sparms)(1) == "pspec" ) {
               write,"pspec [error_fraction]  - plot the most recent spectrum.";
               write,"         A rebinning is done so that the relative error is";
               write,"         less than 0.2. A different value for this fraction";
               write,"         can be given.";
            } else if( (*cans.sparms)(1) == "rpos" ) {
               write,"rpos  -  a position in an image is marked by the cursor";
               write,"         and the coordinates are printed in pixels and in WCS.";
               write,"         The pixel value is also printed.";
            } else if( (*cans.sparms)(1) == "ps" ) {
               write,"ps [plotfilename] -  produce a PS file from current plot.";
               write,"         A specific name may be given.";
            } else if( (*cans.sparms)(1) == "?" ) {
               write,"? [command] - get more detailed help on command";
            }
         }
      }
   }
}

/* Function comparse */

func comparse( str, types )
/* DOCUMENT res = comparse( command_string, types )

     Returns an instance of the struct: s_Command
        res.command    holds the command itself
        res.rparms     is a pointer to the real parameters
        res.iparms     is a pointer to the integer parameters
        res.sparms     is a pointer to the string parameters

    Example:
       > res = comparse( "mreg circle 22 1.0 2.0","sirr" )
       > res.command
       "mreg"
       > *res.sparms
       ["circle"]
       > *res.iparms
       [22]
       > *res.rparms
       [1,2]
*/
{
   // parameters must be space separated

   command = s_Command();
   str = strtrim(strcompress(str));
   keys = strsplit(str," ");
   nkeys = numberof(keys);
   // initialize
   s_nill = [];
   command.rparms = &s_nill;
   command.iparms = &s_nill;
   command.sparms = &s_nill;

   if( nkeys == 1 ) {
      command.command = keys;
   } else {
      command.command = keys(1);
      if( typeof(types) == "string" ) {
         ntypes = strlen(types);
         if( ntypes < nkeys-1 ) {
            write,"comparse: too many keywords - truncated";
            nkeys = ntypes+1;
            keys = keys(nkeys);
         }
         vreal = vint = vstr = [];
         if( ntypes ) {
            for( i = 1; i < nkeys; i++ ) {
               strp = keys(i+1);
               typ = strpart(types,i:i);
               if( typ=="r" ) {
                  grow,vreal,atof(strp);
               } else if( typ=="i" ) {
                  grow,vint,atoi(strp);
               } else if( typ=="s" ) {
                  grow,vstr,strp;
               } else {
                  error,"Invalid type definition";
               }
            } // for( i = ...
         } // if( ntypes )
         command.rparms = &vreal;
         command.iparms = &vint;
         command.sparms = &vstr;
      }
   }
   return command;
}

/* Function keyparse */

func keyparse( str )
/* DOCUMENT res = keyparse( str )

    Interprets a string of shape 'keyword=value' that contains no spaces.
    If the input string fulfills this requirement a struct (s_Keyword)
    is returned, else nil.

     2012-01-16/NJW
*/
{
   // 'str' must be a string
   if( typeof(str) != "string" ) return [];
   // a '=' sign must be present
   pe = strpos( str, "=" );
   if( pe == 0 ) return [];
   // no spaces can be present
   if( strpos(str," ") ) return [];
   // the '=' cannot be the first nor the last character
   len = strlen(str);
   if( pe == 1 || pe == len) return [];
   res = s_Keyword();
   res.keyword = strpart( str, 1:pe-1 );
   res.keyvalue = strpart( str, pe+1:len );

   return res;
}
%FILE% aspec-2.2.i
#include "rmf_funcs.i"
#include "curreg.i"
#include "island.i"

// A struct for the command with parameters

struct s_Command {
   string command;
   pointer rparms;
   pointer iparms;
   pointer sparms;
}

// A struct for the command key words

struct s_Keyword {
   string keyword;
   string keyvalue;
}

// A struct for the regions

struct s_Reg {
   string type;
   string shape;
   double xcen;
   double ycen;
   long area;
   long ncts;
   pointer params;
   pointer imsegment;
   pointer n_outline;
   pointer p_outline;
   pointer x_outline;
   pointer y_outline;
}

Version = "2.2"; // 2012-03-28

void_value = [];

write,"";
write,"         --------------------------------------------------------";
write,"         |   Welcome to the spectral analysis tool: aspec-"+Version+"   |";
write,"         --------------------------------------------------------";
write,"";
write,"aspec is invoked as:  > aspec, event_file_name, ..";
write,"";
write,"   Accepts several event files that will be concatenated.";
write,"   'aspec' is command driven.";
write,"   Entering a '?' will show the command options. After exit 'aspec'";
write,"   can be continued (in the same Yorick session) by simply entering:";
write,"  > aspec";
write,"";
write,"But first choose the telescope:";
write,"      'n' for NuSTAR";
write,"      's' for SXT";
write,"      'o' for other (starts dialogue) :";
write,"";
answer = rdline(prompt=" ... ");
ccc = 1;
if( answer == "n" ) {
   write,"";
   write,"*** This is the NuSTAR verson ***";
   write,"";
   telescop = "NuSTAR";
   if( !file_test("aspec_nustar.par") ) error,"No aspec_nustar.par found in current directory";
   pixel_size = get_par("aspec_nustar.par","pixel_size"); // mm
   n_det_pixels = get_par("aspec_nustar.par","n_det_pixels");
   xdetcen = get_par("aspec_nustar.par","xdetcen"); // pixels
   ydetcen = get_par("aspec_nustar.par","ydetcen"); // pixels
   Rmf_file = get_par("aspec_nustar.par","rmf_file");
   Arf_file = get_par("aspec_nustar.par","arf_file");
   Ebegin = emin_default = get_par("aspec_nustar.par","emin_default"); // keV
   Eend =   emax_default = get_par("aspec_nustar.par","emax_default"); // keV
   pixel_area_cm2 = 0.01 * pixel_size^2;
   region_type = "simple"; // other option is 'detailed'
} else if( answer == "s" ) {
   write,"";
   write,"*** This is the SXT verson ***";
   write,"";
   telescop = "SXT";
   if( !file_test("aspec_sxt.par") ) error,"No aspec_sxt.par found in current directory";
   pixel_size = get_par("aspec_sxt.par","pixel_size"); // mm
   n_det_pixels = get_par("aspec_sxt.par","n_det_pixels");
   xdetcen = get_par("aspec_sxt.par","xdetcen"); // pixels
   ydetcen = get_par("aspec_sxt.par","ydetcen"); // pixels
   Rmf_file = get_par("aspec_sxt.par","rmf_file");
   Arf_file = get_par("aspec_sxt.par","arf_file");
   Ebegin = emin_default = get_par("aspec_sxt.par","emin_default"); // keV
   Eend =   emax_default = get_par("aspec_sxt.par","emax_default"); // keV
   pixel_area_cm2 = 0.01 * pixel_size^2;
   region_type = "simple"; // other option is 'detailed'
} else {
   write,"Not implemented yet";
   ccc = 0;
}
instrume = "MT_RAYOR-4.3";
if( ccc ) {
   write,format=" pixel_size = %.2f mm\n", pixel_size;
   write,format=" n_det_pixels = %i\n", n_det_pixels;
   write,format=" xdetcen    = %.2f pixels\n", xdetcen;
   write,format=" ydetcen    = %.2f pixels\n", ydetcen;
   write,format=" RMF: %s\n", Rmf_file;
   write,format=" ARF: %s\n", Arf_file;
   write,"";
}


func aspec( event_file, .., keep_reg= )
/* DOCUMENT aspec[,event_file][,event_file2, ..][, keep_reg=]

    A package for spectral analysis of X-ray mission event data.
    Enter '?' for a list of commands and '? <command>' for some
    more explanation.

    Giving an event_file will reset and read the event data.
    Keyword 'keep_reg' will except the defined regions from the resetting.

    Calling without an event_file will make it resume operations on
    existing data (if the Yorick session has not been interrupted).

    2010-10-20/NJW
    2010-10-28/NJW updated with normalization of spectra
*/
{

   extern Event_files, Rawx, Rawy, Rawxy, Energy, Nevents;
   extern SRegions, BRegions, Exposure, E_min, E_max, Arfs, Energ_lo, Energ_hi;
   extern Arf_file, Rmf_file, SOceans, BOceans;
   extern Rate_src, Rate_err_src, Rate_bkg, Rate_err_bkg, Spec_norm_factor;
   extern Rate_net, Rate_err_net, Spec_norm_rule, Spec_norm_text;
   extern Ebegin, Eend, Esel; // Defines current energy interval for image display
                        // and regions

   // coordinate system from first event file
   extern Coords;

  /*   Spec_norm_rule == 1  :  no renormalization i.e. spectrum in source area
   *                     2  :  spectrum per pixel
   *                     3  :  spectrum per cm2
   */
   Spec_norm_rule = 1; // default starting value
   Spec_norm_factor = 1.; // default starting value
   Spec_norm_text = "Normalized to source region area";

   if( !is_void(event_file) ) {
      Event_files = event_file;
      logfilename = get_next_filename("aspec_????.txt");
      lg = open(logfilename,"w");
      while( more_args() ) grow, Event_files, next_arg();
      n_event_files = numberof(Event_files);
   } else { // continue on current events
      if( is_void(Event_files) ) {
         write,"No session to continue ...";
         write,"Syntax:  aspec, eventfile[, eventfile2[, eventfile3, ..]][,keep_reg=]";
         return;
      }
      logfilename = get_next_filename("aspec_????.txt",latest=1);
      lg = open(logfilename,"a");
   }
   write,"Logging file: "+logfilename;
   write,lg,format="\nLog of 'aspec' on %s\n\n", ndate(3);
   erlog = open("aspec.log","w");

   if( !is_void(event_file) ) {
      for( i = 1; i <= n_event_files; i++ ) {
         if( !file_test(Event_files(i)) ) error,"File "+Event_files(i)+" is not found!";
      }
      write,erlog,"##1## resetting";
      if( !keep_reg ) SRegions = BRegions = [];

      write,"Reading "+Event_files(1)+" ...";
      dol = Event_files(1)+"+1";
      Rawx = rdfitscol(dol,"rawx");
      Rawy = rdfitscol(dol,"rawy");
      Energy = rdfitscol(dol,"energy");
      Esel = indgen(numberof(Energy));
      hdr = headfits(dol);
      Exposure = fxpar(hdr,"exposure");
      n_events = fxpar(hdr,"naxis2");
      write,lg,format="Event_file : %s,  %i events\n", Event_files(1), n_events;

      // get the WCS coordinate system
      Coords = s_Coords();
      Coords.flag = 1; // set flag for proper values until a necessary
                       // keyword is missing
      if( !is_void( (q = fxpar(hdr,"ctype1")) ) ) {
         Coords.ctype1 = q;
         if( !is_void( (q = fxpar(hdr,"ctype2")) ) ) Coords.ctype2 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"crpix1")) ) ) Coords.crpix1 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"crpix2")) ) ) Coords.crpix2 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"crval1")) ) ) Coords.crval1 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"crval2")) ) ) Coords.crval2 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"cd1_1")) ) ) Coords.cd1_1 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"cd1_2")) ) ) Coords.cd1_2 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"cd2_1")) ) ) Coords.cd2_1 = q;
         else Coords.flag = 0;
         if( !is_void( (q = fxpar(hdr,"cd2_2")) ) ) Coords.cd2_2 = q;
         else Coords.flag = 0;
      } else Coords.flag = 0;

      if( n_event_files > 1 ) {
         for( i = 2; i <= n_event_files; i++ ) {
            write,"Reading "+Event_files(i)+" ...";
            dol = Event_files(i)+"+1";
            grow, Rawx, rdfitscol(dol,"rawx");
            grow, Rawy, rdfitscol(dol,"rawy");
            grow, Energy, rdfitscol(dol,"energy");
            hdr = headfits(dol);
            exposure = fxpar(hdr,"exposure");
            n_events = fxpar(hdr,"naxis2");
            if( !near( Exposure, exposure, 1. ) ) error,"Wrong exposure in file #"+itoa(i);
            write,lg,format="Event_file : %s,  %i events\n", Event_files(i), n_events;
         }
      }

      Nevents = numberof(Rawx);
      Rawxy = (Rawy - 1)*n_det_pixels + Rawx;
      //+ Rmf_file = "/home/njw/yorick/mraytrace/nustar/test_rmf.fits";
      write,"Using RMF in: "+Rmf_file;
      E_min = rdfitscol(Rmf_file+"[EBOUNDS]","e_min");
      E_max = rdfitscol(Rmf_file+"[EBOUNDS]","e_max");
      write,"Loading ARFs from: "+Arf_file;
      Arfs = rdfitscol(Arf_file+"[SPECRESP]","SPECRESP");
      Energ_lo = rdfitscol(Arf_file+"[SPECRESP]","ENERG_LO")(,1);
      Energ_hi = rdfitscol(Arf_file+"[SPECRESP]","ENERG_HI")(,1);
   }

   im = array(int,n_det_pixels,n_det_pixels);
   for(i=1;i<=Nevents;i++) im(Rawx(i),Rawy(i)) += 1;
   mlogxy,0,0;
   disp,im,title="All events";

   command_string = "";
   while( 1 ) {
      read,format="%[^\n]",prompt="What now? ... ", command_string;
      command_string = strtrim(command_string);
      write,erlog,"##4## command given: "+command_string;
      write,lg,"Command given: "+command_string;
      cans = comparse(command_string);
      cmd = cans.command;

      if( cmd == "x" ) {
         close, lg;
         close, erlog;
         return;
      }

//
// ************************************** info *********************************************************
//
      if( cmd == "info" ) { // cominfo   -  give information on current settings
         cans = comparse(command_string, "i"); // information level
         niparms = numberof(*cans.iparms);

         write,format="Energy range: %.3f - %.3f keV\n", Ebegin, Eend;

//
// ************************************** ebds *********************************************************
//
      } else if( cmd == "ebds" ) { // comebds  -  set energy boundaries
         cans = comparse(command_string, "rr"); // Ebegin and Eend
         nrparms = numberof(*cans.rparms);
         if( nrparms == 0 ) {
            Ebegin = emin_default;
            Eend   = emax_default;
         } else if( nrparms == 1 ) {
            Ebegin = (*cans.rparms)(1);
            Eend   = emax_default;
         } else {
            Ebegin = (*cans.rparms)(1);
            Eend   = (*cans.rparms)(2);
         }
         Esel = where( Energy > Ebegin & Energy < Eend );
         nsel = numberof(Esel);
         write,format="Energy range: %.3f - %.3f keV\n", Ebegin, Eend;
         write,format="       containing %i events\n", nsel;
         dsel = where( E_max > Ebegin & E_min < Eend );
         write,format="       and %i detector energy bins\n", numberof(dsel);

      //   Update image and regions wrt. number of counts

         im = array(int,n_det_pixels,n_det_pixels);
         for(i=1;i<=nsel;i++) im(Rawx(Esel(i)),Rawy(Esel(i))) += 1;
         write,erlog,format="##5## emin emax nsel : %.2f %.2f %i\n", Ebegin, Eend, nsel;

         // update the regions
         nreg = numberof(SRegions);
         if( nreg ) {
            for( i = 1; i <= nreg; i++ ) {
               asel = *SRegions(i).imsegment; // area selection
               SRegions(i).ncts = numberof(whereany(Rawxy(Esel), asel));
               asel = *BRegions(i).imsegment; // area selection
               BRegions(i).ncts = numberof(whereany(Rawxy(Esel), asel));
            }
         }

//
// ************************************** imdisp & lmdisp *********************************************************
//
      } else if( cmd == "imdisp" || cmd == "lmdisp" ) { // comimdisp, comlmdisp   -  display detector image
         cans = comparse(command_string, "r"); // image folding sigma

         rim = double(im);
         if( !is_void(*cans.rparms) ) rim = gfconvol(rim,(*cans.rparms)(1));
         mlogxy,0,0;
         if( cmd == "lmdisp" ) disp,log(1.0+rim);
         else disp,rim;

         // add the regions
         nreg = numberof(SRegions);
         for( i = 1; i <= nreg; i++ ) {
            if( SRegions(i).type == "detailed" ) {
               nout = *SRegions(i).n_outline;
               pout = *SRegions(i).p_outline;
               xout = *SRegions(i).x_outline;
               yout = *SRegions(i).y_outline;
               for( j = 1; j <= numberof(nout); j++ ) {
                  oplot,xout(pout(j):pout(j)-1+nout(j)),yout(pout(j):pout(j)-1+nout(j)),color="green";
               }
            } else {
               reg_params = *SRegions(i).params;
               shape      = SRegions(i).shape;
               if( shape == "c" ) {
                  angles = span(0,2*pi,100);
                  oplot,reg_params(1) + reg_params(3)*cos(angles), \
                        reg_params(2) + reg_params(3)*sin(angles), color="green";
               }
               if( shape == "a" ) {
                  angles = span(0,2*pi,100);
                  oplot,reg_params(1) + reg_params(3)*cos(angles), \
                        reg_params(2) + reg_params(3)*sin(angles), color="green";
                  oplot,reg_params(1) + reg_params(4)*cos(angles), \
                        reg_params(2) + reg_params(4)*sin(angles), color="green";
               }
               if( shape == "b" ) {
                  oplot,[reg_params(1),reg_params(3),reg_params(3),reg_params(1), reg_params(1)], \
                        [reg_params(2),reg_params(2),reg_params(4),reg_params(4), reg_params(2)], \
                        color="green";
               }
            }
            if( BRegions(i).shape != "v" ) {
               if( BRegions(i).type == "detailed" ) {
                  nout = *BRegions(i).n_outline;
                  pout = *BRegions(i).p_outline;
                  xout = *BRegions(i).x_outline;
                  yout = *BRegions(i).y_outline;
                  for( j = 1; j <= numberof(nout); j++ ) {
                     oplot,xout(pout(j):pout(j)-1+nout(j)),yout(pout(j):pout(j)-1+nout(j)),color="red";
                  }
               } else {
                  reg_params = *BRegions(i).params;
                  shape      = BRegions(i).shape;
                  if( shape == "c" ) {
                     angles = span(0,2*pi,100);
                     oplot,reg_params(1) + reg_params(3)*cos(angles), \
                           reg_params(2) + reg_params(3)*sin(angles), color="red";
                  }
                  if( shape == "a" || shape == "d" ) {
                     angles = span(0,2*pi,100);
                     oplot,reg_params(1) + reg_params(3)*cos(angles), \
                           reg_params(2) + reg_params(3)*sin(angles), color="red";
                     oplot,reg_params(1) + reg_params(4)*cos(angles), \
                           reg_params(2) + reg_params(4)*sin(angles), color="red";
                  }
                  if( shape == "b" ) {
                     oplot,[reg_params(1),reg_params(3),reg_params(3),reg_params(1), reg_params(1)], \
                           [reg_params(2),reg_params(2),reg_params(4),reg_params(4), reg_params(2)], \
                           color="red";
                  }
               }
            }
         }
//
// ************************************** imsave *********************************************************
//
      } else if( cmd == "imsave"  ) { // comimsave  -  save detector image to FITS
         cans = comparse(command_string, "s"); // given filename

         if( is_void(*cans.sparms) ) {
            fits_name = get_next_filename("aspec_image_????.fits");
         } else {
            fits_name = (*cans.sparms)(1);
         }
         write,lg,"Writing to: "+fits_name;
         write,"Writing to: "+fits_name;
         kwds_init;
         kwds_set,"DATE",ndate(3),"Date/time of file creation";
         kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
         kwds_set,"E_MIN", Ebegin, "[keV] Lower energy limit";
         kwds_set,"E_MAX", Eend, "[keV] Upper energy limit";
         for( i = 1; i <= numberof(Event_files); i++ ) {
            kwds_set,"EVFILE"+itoa(i),Event_files(i);
         }
         if( Coords.flag) {
            kwds_set,"CTYPE1", Coords.ctype1, "Type of coord.system";
            kwds_set,"CTYPE2", Coords.ctype2, "Type of coord.system";
            kwds_set,"CRPIX1", Coords.crpix1, "Reference pixel position";
            kwds_set,"CRPIX2", Coords.crpix2, "Reference pixel position";
            kwds_set,"CRVAL1", Coords.crval1, "Reference coord value";
            kwds_set,"CRVAL2", Coords.crval2, "Reference coord value";
            kwds_set,"CD1_1", Coords.cd1_1, "Part of transf. matrix";
            kwds_set,"CD1_2", Coords.cd1_2, "Part of transf. matrix";
            kwds_set,"CD2_1", Coords.cd2_1, "Part of transf. matrix";
            kwds_set,"CD2_2", Coords.cd2_2, "Part of transf. matrix";
         }
         kwds_set,"EXTNAME","ASPEC_IMAGE","Name of this extension";
         writefits, fits_name, im;
//
// ************************************** rpos *********************************************************
//
      } else if( cmd == "rpos" ) { // comrpos  -  read position in image
         pos = curmark1( style=0,prompt="Mark the position ... " );
         write,format="Pixel position: %7.3f %7.3f\n", pos(1), pos(2);
         local coord1, coord2;
         skypos_fits, Coords, pos(1), pos(2), coord1, coord2, to_sky=1;
         write,format="Coord position: %7.3 %7.3\n", coord1, coord2;
         write,format="Pixel value : %i counts\n", im(int(pos(1)+0.5),int(pos(2)+0.5));
//
// ************************************** mreg *********************************************************
//
      } else if( cmd == "mreg" ) { // commreg  -  make region pair
         cans = comparse(command_string, "s");
         if( is_void(*cans.sparms) ) {
            s_shape = "c";  // circular region with annulus is the default
            b_shape = "d";  // Annulus with predefined center
         } else {
            shape = (*cans.sparms)(1);
            if( strlen(shape) != 2 ) {
               write,"Parameter must be two-letter string";
               continue;
            }
            s_shape = strpart(shape,1:1);
            b_shape = strpart(shape,2:2);
            if( s_shape != "c" && s_shape != "b" ) {
               write,"Parameter must have c or b as first letter";
               continue;
            }
            if( b_shape != "a" && b_shape != "b" && b_shape != "v" ) {
               write,"Parameter must have a, b, or v as second letter";
               continue;
            }
         }
         // ******  Prepare the regions arrays
         local xcen, ycen, sreg_params, breg_params;
         if( is_void(SRegions) ) {
            //+ 101119 SRegions = s_Reg();
            //+ 101119 BRegions = s_Reg();
            SRegions = array(s_Reg,1);
            BRegions = array(s_Reg,1);
         } else {
            grow, SRegions, s_Reg();
            grow, BRegions, s_Reg();
         }
         nreg = numberof(SRegions);
         // ******  Define the source region
         write,"Define the source region:";
         sel = int(curreg(im,s_shape, xcen, ycen, sreg_params, color="green",thick=2));
         if( region_type != "simple" ) {
            ocean = array(short,n_det_pixels,n_det_pixels);
            ocean(sel) = 1;
            isle = island(ocean);
            c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
            n_outline = int(n_outline);
            p_outline = int(p_outline);
            SRegions(nreg).n_outline = &n_outline;
            SRegions(nreg).p_outline = &p_outline;
            SRegions(nreg).x_outline = &x_outline;
            SRegions(nreg).y_outline = &y_outline;
         }
         SRegions(nreg).type = region_type;
         SRegions(nreg).params = &sreg_params;
         SRegions(nreg).shape = s_shape;
         SRegions(nreg).xcen = xcen;
         SRegions(nreg).ycen = ycen;
         SRegions(nreg).area = numberof(sel);
         SRegions(nreg).imsegment = &sel;
         SRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
         // ******  Define the background region
         if( b_shape == "v" ) { // void i.e. no background but dummy to be defined
            BRegions(nreg).shape = b_shape;
            BRegions(nreg).xcen = xcen;
            BRegions(nreg).ycen = ycen;
            BRegions(nreg).area = 1; // to avoid division by zero
            //+ BRegions(nreg).imsegment = &sel;
            BRegions(nreg).imsegment = &void_value;
            BRegions(nreg).ncts = 0;
            BRegions(nreg).type = region_type;
         } else { // 'a', 'd', or 'b' (annulus or box)
            write,"Define the background region:";
            sel = int(curreg(im, b_shape, xcen, ycen, breg_params, color="red",thick=2));
            if( region_type != "simple" ) {
               ocean = array(short,n_det_pixels,n_det_pixels);
               ocean(sel) = 1;
               isle = island(ocean);
               c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
               n_outline = int(n_outline);
               p_outline = int(p_outline);
               BRegions(nreg).n_outline = &n_outline;
               BRegions(nreg).p_outline = &p_outline;
               BRegions(nreg).x_outline = &x_outline;
               BRegions(nreg).y_outline = &y_outline;
            }
            BRegions(nreg).type = region_type;
            BRegions(nreg).shape = b_shape;
            BRegions(nreg).params = &breg_params;
            BRegions(nreg).xcen = xcen;
            BRegions(nreg).ycen = ycen;
            BRegions(nreg).area = numberof(sel);
            BRegions(nreg).imsegment = &sel;
            BRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
         }

//
// ************************************** dreg *********************************************************
//
      } else if( cmd == "dreg" ) { // comdreg  -  delete region(s)
         cans = comparse(command_string, "i");
         nreg = numberof(SRegions);
         if( nreg == 0 ) {
            write,"No regions have been defined ...";
         } else {
            if( !is_void(*cans.iparms) ) {
               // delete a single region
               i = (*cans.iparms)(1);
               if( i < 1 || i > nreg ) {
                  write,"Requested region is not found ...";
                  continue;
               }
               if( nreg == 1 ) {
                  SRegions = BRegions = [];
               } else {
                  SRegions = rem_elem( SRegions, i );
                  BRegions = rem_elem( BRegions, i );
               }
            } else {
               SRegions = BRegions = [];
            }
         }
//
// ************************************** ireg *********************************************************
//
      } else if( cmd == "ireg" ) { // comireg  -  show region information
         cans = comparse(command_string, "i");
         nreg = numberof(SRegions);
         if( nreg == 0 ) {
            write,"No regions have been defined ...";
         } else {
            i1 = 1; i2 = nreg; // default, show all regions
            if( !is_void(*cans.iparms) ) {
               i1 = i2 = (*cans.iparms)(1);
               if( i1 < 1 || i1 > nreg ) {
                  write,"Requested region is not found ...";
                  i1 = 1; i2 = nreg;
               }
            }
            write,"      #    xcen   ycen     area  shape      ncts";
            for( i = i1; i <= i2; i++ ) {
               write,format="Src: %3i  %6.2f %6.2f %8i    %s %11i\n", \
                  i, SRegions(i).xcen, SRegions(i).ycen, SRegions(i).area, \
                         SRegions(i).shape, SRegions(i).ncts;
               write,format="Bkg: %3i  %6.2f %6.2f %8i    %s %11i\n", \
                  i, BRegions(i).xcen, BRegions(i).ycen, BRegions(i).area, \
                         BRegions(i).shape, BRegions(i).ncts;
               n = SRegions(i).ncts;
               k = BRegions(i).area > 0 ? double(SRegions(i).area)/BRegions(i).area : 1.0;
               b = BRegions(i).ncts;
               dn = sqrt(n + b*(k^2));
               write,format=" Net counts: %.2f +- %.2f\n", n - b*k, dn;
            }
         }
//
// ************************************** sreg *********************************************************
//
      } else if( cmd == "sreg" ) { // comsreg  -  save region information
         nreg = numberof(SRegions);
         cans = comparse(command_string, "i"); // If number > 0 then save that one
                                               // If number == 0 then save all
                                               // If number is not given then save most recent
                                               // In any case a new file will be created
         if( is_void(*cans.iparms) ) {
            n = nreg;
         } else {
            n = (*cans.iparms)(1);
         }
    /*
     *   A region is described by a single row in a FITS files
     */
         local serstr;
         sregfile = get_next_filename("sreg_????.fits", serstr);
         bregfile = "breg_"+serstr+".fits";
         write,"      saving into "+sregfile+" and "+bregfile;
         write,lg,"      saving into "+sregfile+" and "+bregfile;
         if( n == 0 ) { // save all
           // --     source regions
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_SREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of source regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,sregfile,"TYPE",SRegions.type, \
                                "SHAPE",SRegions.shape, \
                                "XCEN",SRegions.xcen, \
                                "YCEN",SRegions.ycen, \
                                "AREA",SRegions.area, \
                                "NCTS",SRegions.ncts, \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            for( i = 1; i <= nreg; i++ ) {
               if( !is_void(*SRegions(i).imsegment) ) {
                  fits_bintable_poke,sregfile+"+1",i,"IMSEGMENT",*SRegions(i).imsegment;
                  if( SRegions(i).type == "detailed" ) {
                     fits_bintable_poke,sregfile+"+1",i,"N_OUTLINE",*SRegions(i).n_outline;
                     fits_bintable_poke,sregfile+"+1",i,"P_OUTLINE",*SRegions(i).p_outline;
                     fits_bintable_poke,sregfile+"+1",i,"X_OUTLINE",*SRegions(i).x_outline;
                     fits_bintable_poke,sregfile+"+1",i,"Y_OUTLINE",*SRegions(i).y_outline;
                  }
                  fits_bintable_poke,sregfile+"+1",i,"PARAMS",*SRegions(i).params;
               }
            }
           // --     background regions
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_BREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of background regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,bregfile,"TYPE",BRegions.type, \
                                "SHAPE",BRegions.shape, \
                                "XCEN",BRegions.xcen, \
                                "YCEN",BRegions.ycen, \
                                "AREA",BRegions.area, \
                                "NCTS",BRegions.ncts, \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            for( i = 1; i <= nreg; i++ ) {
               if( !is_void(*BRegions(i).imsegment) ) {
                  fits_bintable_poke,bregfile+"+1",i,"IMSEGMENT",*BRegions(i).imsegment;
                  if( SRegions(i).type == "detailed" ) {
                     fits_bintable_poke,bregfile+"+1",i,"N_OUTLINE",*BRegions(i).n_outline;
                     fits_bintable_poke,bregfile+"+1",i,"P_OUTLINE",*BRegions(i).p_outline;
                     fits_bintable_poke,bregfile+"+1",i,"X_OUTLINE",*BRegions(i).x_outline;
                     fits_bintable_poke,bregfile+"+1",i,"Y_OUTLINE",*BRegions(i).y_outline;
                  }
                  fits_bintable_poke,sregfile+"+1",i,"PARAMS",*BRegions(i).params;
               }
            }
         } else { // save the specified one
           //  --  the source region
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_SREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a singls source region";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,sregfile,"TYPE",[SRegions(n).type], \
                                "SHAPE",[SRegions(n).shape], \
                                "XCEN",[SRegions(n).xcen], \
                                "YCEN",[SRegions(n).ycen], \
                                "AREA",[SRegions(n).area], \
                                "NCTS",[SRegions(n).ncts], \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            if( !is_void(*SRegions(n).imsegment) ) {
               fits_bintable_poke,sregfile+"+1",1,"IMSEGMENT",*SRegions(n).imsegment;
               if( SRegions(n).type == "detailed" ) {
                  fits_bintable_poke,sregfile+"+1",1,"N_OUTLINE",*SRegions(n).n_outline;
                  fits_bintable_poke,sregfile+"+1",1,"P_OUTLINE",*SRegions(n).p_outline;
                  fits_bintable_poke,sregfile+"+1",1,"X_OUTLINE",*SRegions(n).x_outline;
                  fits_bintable_poke,sregfile+"+1",1,"Y_OUTLINE",*SRegions(n).y_outline;
               }
               fits_bintable_poke,sregfile+"+1",n,"PARAMS",*SRegions(n).params;
            }
           // --  the background region
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_BREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of source regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,bregfile,"TYPE",[BRegions(n).type], \
                                "SHAPE",[BRegions(n).shape], \
                                "XCEN",[BRegions(n).xcen], \
                                "YCEN",[BRegions(n).ycen], \
                                "AREA",[BRegions(n).area], \
                                "NCTS",[BRegions(n).ncts], \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            if( !is_void(*BRegions(n).imsegment) ) {
               fits_bintable_poke,bregfile+"+1",1,"IMSEGMENT",*BRegions(n).imsegment;
               if( SRegions(n).type == "detailed" ) {
                  fits_bintable_poke,bregfile+"+1",1,"N_OUTLINE",*BRegions(n).n_outline;
                  fits_bintable_poke,bregfile+"+1",1,"P_OUTLINE",*BRegions(n).p_outline;
                  fits_bintable_poke,bregfile+"+1",1,"X_OUTLINE",*BRegions(n).x_outline;
                  fits_bintable_poke,bregfile+"+1",1,"Y_OUTLINE",*BRegions(n).y_outline;
               }
               fits_bintable_poke,bregfile+"+1",n,"PARAMS",*BRegions(n).params;
            }
         }
//
// ************************************** lreg *********************************************************
//
      } else if( cmd == "lreg" ) { // comlreg  -  load region information
         nreg = numberof(SRegions);
         //   Command:   lreg NNNN [num]
         cans = comparse(command_string, "si"); // If number > 0 is given then load that one
                                                // If number == 0 then load all in file
                                                // If number is not given then load first
                                                // region in the file
        /*
         *   Check the command and the existence of region files
         */

         if( is_void(*cans.sparms) ) {
            error,"Illegal command for lreg";
         } else {
            serstr = (*cans.sparms)(1);
            lserstr = strlen(serstr);
            if( lserstr != 4 ) error,"Illegal length of str for lreg";
            sregfile = "sreg_"+serstr+".fits";
            if( !file_test(sregfile) ) error,sregfile+" is not found";
            bregfile = "breg_"+serstr+".fits";
            if( !file_test(bregfile) ) error,bregfile+" is not found";
         }

         if( is_void(*cans.iparms) ) {
            n = 1; // 'n' is the row number
         } else {
            n = (*cans.iparms)(1);
         }

         shdr = headfits(sregfile+"+1");
         bhdr = headfits(bregfile+"+1");
         nrows = fxpar( shdr, "naxis2" );
         if( nrows != fxpar( bhdr, "naxis2" ) ) error,"Different number of rows";

         if( n > nrows ) error,"Region number exceeds number of rows";

         // make room for the regions to be loaded

         if( n ) {
            grow, SRegions, array(s_Reg,1);
            grow, BRegions, array(s_Reg,1);
         } else {
            grow, SRegions, array(s_Reg,nrows);
            grow, BRegions, array(s_Reg,nrows);
         }

    /*
     *   A region is described by a single row in a FITS files
     */
         if( n == 0 ) { // load all
           // --     source regions
            type  = rdfitscol(sregfile+"+1","TYPE");
            shape = rdfitscol(sregfile+"+1","SHAPE");
            xcen = rdfitscol(sregfile+"+1","XCEN");
            ycen = rdfitscol(sregfile+"+1","YCEN");
            area = rdfitscol(sregfile+"+1","AREA");
            ncts = rdfitscol(sregfile+"+1","NCTS");
            SRegions(nreg+1:nreg+nrows).type  = type;
            SRegions(nreg+1:nreg+nrows).shape = shape;
            SRegions(nreg+1:nreg+nrows).xcen = xcen;
            SRegions(nreg+1:nreg+nrows).ycen = ycen;
            SRegions(nreg+1:nreg+nrows).area = area;
            SRegions(nreg+1:nreg+nrows).ncts = ncts;
            for( i = 1; i <= nrows; i++ ) {
               d1 = fits_bintable_peek(sregfile+"+1",i,"IMSEGMENT");
               SRegions(nreg+i).imsegment = &d1;
               // update number of counts
               if( !is_void(d1) ) SRegions(nreg+i).ncts = numberof(whereany(Rawxy, d1));
               d1 = fits_bintable_peek(sregfile+"+1",i,"N_OUTLINE");
               SRegions(nreg+i).n_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",i,"P_OUTLINE");
               SRegions(nreg+i).p_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",i,"X_OUTLINE");
               SRegions(nreg+i).x_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",i,"Y_OUTLINE");
               SRegions(nreg+i).y_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",i,"PARAMS");
               SRegions(nreg+i).params = &d1;
            }
           // --     background regions
            type  = rdfitscol(bregfile+"+1","TYPE");
            shape = rdfitscol(bregfile+"+1","SHAPE");
            xcen = rdfitscol(bregfile+"+1","XCEN");
            ycen = rdfitscol(bregfile+"+1","YCEN");
            area = rdfitscol(bregfile+"+1","AREA");
            ncts = rdfitscol(bregfile+"+1","NCTS");
            BRegions(nreg+1:nreg+nrows).type = type;
            BRegions(nreg+1:nreg+nrows).shape = shape;
            BRegions(nreg+1:nreg+nrows).xcen = xcen;
            BRegions(nreg+1:nreg+nrows).ycen = ycen;
            BRegions(nreg+1:nreg+nrows).area = area;
            BRegions(nreg+1:nreg+nrows).ncts = ncts;
            for( i = 1; i <= nrows; i++ ) {
               d1 = fits_bintable_peek(bregfile+"+1",i,"IMSEGMENT");
               BRegions(nreg+i).imsegment = &d1;
               // update number of counts
               if( !is_void(d1) ) BRegions(nreg+i).ncts = numberof(whereany(Rawxy, d1));
               d1 = fits_bintable_peek(bregfile+"+1",i,"N_OUTLINE");
               BRegions(nreg+i).n_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",i,"P_OUTLINE");
               BRegions(nreg+i).p_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",i,"X_OUTLINE");
               BRegions(nreg+i).x_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",i,"Y_OUTLINE");
               BRegions(nreg+i).y_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",i,"PARAMS");
               BRegions(nreg+i).params = &d1;
            }
         } else { // load the specified one(s)
           //  --  the source region
            type  = rdfitscol(sregfile+"+1","TYPE");
            shape = rdfitscol(sregfile+"+1","SHAPE");
            xcen = rdfitscol(sregfile+"+1","XCEN");
            ycen = rdfitscol(sregfile+"+1","YCEN");
            area = rdfitscol(sregfile+"+1","AREA");
            ncts = rdfitscol(sregfile+"+1","NCTS");
            SRegions(nreg+1).type  = type(n);
            SRegions(nreg+1).shape = shape(n);
            SRegions(nreg+1).xcen = xcen(n);
            SRegions(nreg+1).ycen = ycen(n);
            SRegions(nreg+1).area = area(n);
            SRegions(nreg+1).ncts = ncts(n);

            d1 = fits_bintable_peek(sregfile+"+1",n,"IMSEGMENT");
            SRegions(nreg+1).imsegment = &d1;
            // update number of counts
            if( !is_void(d1) ) SRegions(nreg+1).ncts = numberof(whereany(Rawxy, d1));
            d1 = fits_bintable_peek(sregfile+"+1",n,"N_OUTLINE");
            SRegions(nreg+1).n_outline = &d1;
            d1 = fits_bintable_peek(sregfile+"+1",n,"P_OUTLINE");
            SRegions(nreg+1).p_outline = &d1;
            d1 = fits_bintable_peek(sregfile+"+1",n,"X_OUTLINE");
            SRegions(nreg+1).x_outline = &d1;
            d1 = fits_bintable_peek(sregfile+"+1",n,"Y_OUTLINE");
            SRegions(nreg+1).y_outline = &d1;
            d1 = fits_bintable_peek(sregfile+"+1",n,"PARAMS");
            SRegions(nreg+1).params = &d1;

           // --  the background region
            type  = rdfitscol(bregfile+"+1","TYPE");
            shape = rdfitscol(bregfile+"+1","SHAPE");
            xcen = rdfitscol(bregfile+"+1","XCEN");
            ycen = rdfitscol(bregfile+"+1","YCEN");
            area = rdfitscol(bregfile+"+1","AREA");
            ncts = rdfitscol(bregfile+"+1","NCTS");
            BRegions(nreg+1).type = type(n);
            BRegions(nreg+1).shape = shape(n);
            BRegions(nreg+1).xcen = xcen(n);
            BRegions(nreg+1).ycen = ycen(n);
            BRegions(nreg+1).area = area(n);
            BRegions(nreg+1).ncts = ncts(n);

            d1 = fits_bintable_peek(bregfile+"+1",n,"IMSEGMENT");
            BRegions(nreg+1).imsegment = &d1;
            // update number of counts
            if( !is_void(d1) ) BRegions(nreg+1).ncts = numberof(whereany(Rawxy, d1));
            d1 = fits_bintable_peek(bregfile+"+1",n,"N_OUTLINE");
            BRegions(nreg+1).n_outline = &d1;
            d1 = fits_bintable_peek(bregfile+"+1",n,"P_OUTLINE");
            BRegions(nreg+1).p_outline = &d1;
            d1 = fits_bintable_peek(bregfile+"+1",n,"X_OUTLINE");
            BRegions(nreg+1).x_outline = &d1;
            d1 = fits_bintable_peek(bregfile+"+1",n,"Y_OUTLINE");
            BRegions(nreg+1).y_outline = &d1;
            d1 = fits_bintable_peek(bregfile+"+1",n,"PARAMS");
            BRegions(nreg+1).params = &d1;
         }
//
// ************************************** ps *********************************************************
//
      } else if( cmd == "ps" ) { // comps - dump plot to ps file
         cans = comparse(command_string, "s");
         plotsign;
         plotname,"Spectrum by aspec";
         zps,outfile=(*cans.sparms)(1),noc=1;
//
// ************************************** ss *********************************************************
//
      } else if( cmd == "ss" ) { // comss - save spectrum and background
         bb = comparse(command_string,"ssss");
         nbb = numberof(*bb.sparms);
         ireg = 0;
         ignbkg = 0; // ignore background
         if( nbb ) {
            for( i = 1; i <= nbb; i++ ) {
               kbb = keyparse((*bb.sparms)(i));
               if( is_void(kbb) ) {
                  cans = comparse(command_string, "i");
                  ireg = (*cans.iparms)(i);
                  write,"Setting ireg ("+itoa(ireg)+") from simple value ...";
               } else {
                  if( kbb.keyword == "ignbkg" ) {
                     ignbkg = kbb.keyvalue;
                     write,"Setting ignbkg ("+itoa(ignbkg)+") from keyword ...";
                  }
                  if( kbb.keyword == "reg" ) {
                     ireg = kbb.keyvalue;
                     write,"Setting ireg ("+itoa(ireg)+") from keyword ...";
                  }
               }
            }
         }
         nreg = numberof(SRegions);
         if( ireg == 0 ) ireg = nreg;
         write,lg,"Extracting spectrum for region # ",+itoa(ireg);

         //  Extract the spectrum

         s_sel = whereany(Rawxy, *SRegions(ireg).imsegment);
         b_sel = BRegions(ireg).shape == "v" ? [] : whereany(Rawxy, *BRegions(ireg).imsegment);
         if( ignbkg ) b_sel = [];

         //     Rate_src (Rate_err_src) is for total counts in source region
         //     Rate_bkg (Rate_err_bkg) is for renormalized counts in background region
         //     Rate_net (Rate_err_net) is for background subtracted counts

         specbinning, Energy(s_sel), E_min, E_max, Rate_src, Rate_err_src, exposure=Exposure;
         if( is_void(b_sel) ) {
            // if background is not considered make null spectrum
            Rate_bkg = Rate_err_bkg = Rate_src*0;
         } else {
            specbinning, Energy(b_sel), E_min, E_max, Rate_bkg, Rate_err_bkg, exposure=Exposure;
         }

         //  Renormalize background to adapt to source region size

         corf = float(SRegions(ireg).area)/BRegions(ireg).area;
         Rate_bkg *= corf;    // normalize to source area
         Rate_err_bkg *= corf;

         //  Get the net spectrum

         Rate_net = Rate_src - Rate_bkg;
         Rate_err_net = sqrt(Rate_err_src^2 + Rate_err_bkg^2);

         //  Renormalize the spectrum to pixel or unit area if requested

         if( Spec_norm_rule == 2 ) { // per pixel
            Spec_norm_factor = 1.0/SRegions(ireg).area;
         } else if( Spec_norm_rule == 3 ) { // per cm2
            Spec_norm_factor = 1.0/(SRegions(ireg).area*pixel_area_cm2);
         } else Spec_norm_factor = 1.0;

         Rate_src *= Spec_norm_factor;
         Rate_err_src *= Spec_norm_factor;
         Rate_bkg *= Spec_norm_factor;
         Rate_err_bkg *= Spec_norm_factor;
         Rate_net *= Spec_norm_factor;
         Rate_err_net *= Spec_norm_factor;

         // select the ARF based on distance to center
         dist = sqrt((SRegions(ireg).xcen - xdetcen)^2 + (SRegions(ireg).ycen - ydetcen)^2);
         //  now in pixels, convert to arcmin
         dist *= (pixel_size*180.*60.)/(10140.*pi);
         // given that the focal length is 10140 mm
         d = span(0.,9.,10);
         w = where( d > dist ); // now w(1) is the index on one side
                 // and w(1)-1 is the index on the other side
         if( !numberof(w) ) {
            write,"The region center is too far away";
         } else {
            i = w(1) - 1;
            arf = float(Arfs(,i) + ((dist - d(i))/(d(i+1)-d(i)))*(Arfs(,i+1)-Arfs(,i)));
            arffile = fullpath(get_next_filename("arf_????.fits"));
            arf2phaii, arffile, arf, Energ_lo, Energ_hi, extname="SPECRESP",\
                instrume=instrume,telescop=telescop;
            write,"ARF file made : "+arffile;

            // Allways make three spectral files: net, total, and bkg
            local ser_str;
            spec_net_file = get_next_filename("spec_net_????.fits",ser_str);
            spec_bkg_file  = "spec_bkg_"+ser_str+".fits";
            spec_tot_file  = "spec_tot_"+ser_str+".fits";

            kwds_init;
            kwds_set,"NUMSRCPX", SRegions(ireg).area,"Number of source pixels";
            kwds_set,"NUMBKGPX", BRegions(ireg).area,"Number of background pixels";
            kwds_set,"REGXCEN", SRegions(ireg).xcen,"X pixel for region center";
            kwds_set,"REGYCEN", SRegions(ireg).ycen,"Y pixel for region center";
            kwds_set,"SRGSHAPE", SRegions(ireg).shape,"Shape of source region";
            kwds_set,"BRGSHAPE", BRegions(ireg).shape,"Shape of background region";
            kwds_set,"NORMFACT", Spec_norm_factor,"Spectral renormalization factor";
            kwds_set,"NORMTEXT", Spec_norm_text,"Explanation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";

            // Write net spectrum

            spec2phaii,spec_net_file,Rate_net,Rate_err_net,type="net",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,backfile=spec_bkg_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Net spectrum has been written to : "+spec_net_file;
            write,lg,"Net spectrum has been written to : "+spec_net_file;

            // Write bkg spectrum

            spec2phaii,spec_bkg_file,Rate_bkg,Rate_err_bkg,type="bkg",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Background spectrum has been written to : "+spec_bkg_file;
            write,lg,"Background spectrum has been written to : "+spec_bkg_file;

            // Write total spectrum

            spec2phaii,spec_tot_file,Rate_src,Rate_err_src,type="total",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,backfile=spec_bkg_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Total spectrum has been written to : "+spec_tot_file;
            write,lg,"Total spectrum has been written to : "+spec_tot_file;
         }
//
// ************************************** normspec *********************************************************
//
      } else if( cmd == "normspec" ) { // comnormspec - normalize spectrum
         cans = comparse(command_string,"s");
         if( !is_void(*cans.sparms) ) {
            if( (*cans.sparms)(1) == "1" ) {
               Spec_norm_rule = 1;
               Spec_norm_text = "Normalized to source region area";
            } else if( (*cans.sparms)(1) == "pixel" ) {
               Spec_norm_rule = 2;
               Spec_norm_text = "Normalized to a single pixel";
            } else if( (*cans.sparms)(1) == "cm2" ) {
               Spec_norm_rule = 3;
               Spec_norm_text = "Normalized to a cm2 on the detector";
            }
            write,"Next spectrum will be "+Spec_norm_text;
         }
//
// ************************************** pspec *********************************************************
//
      } else if( cmd == "pspec" ) { // compspec  - plot most recent spectrum
         cans = comparse(command_string,"r");
         frac = is_void(*cans.rparms) ? 0.2 : (*cans.rparms)(1);
         //+ 101123 plot_spectrum,E_min,E_max,Rate_src,Rate_err_src,itype=3;
         local ob1, ob2, orate, orate_err;
         REBIN = specrebinninga( E_min, E_max, Rate_src, Rate_err_src, frac, ob1, ob2, orate, orate_err);
         plot_spectrum, ob1, ob2, orate, orate_err, itype=3;
         if(!is_void(b_sel)) {
            //+ specrebinninga, E_min, E_max, Rate_bkg, Rate_err_bkg, frac, ob1, ob2, orate, orate_err;
            specrebinning, E_min, E_max, Rate_bkg, Rate_err_bkg, REBIN, ob1, ob2, orate, orate_err;
            oplot_spectrum, ob1, ob2, orate, orate_err,color="red";
         }
         //+ specrebinninga, E_min, E_max, Rate_net, Rate_err_net, frac, ob1, ob2, orate, orate_err;
         specrebinning, E_min, E_max, Rate_net, Rate_err_net, REBIN, ob1, ob2, orate, orate_err;
         oplot_spectrum, ob1, ob2, orate, orate_err,color="green";
//
// ************************************** ? *********************************************************
//
      } else if( cmd == "?" ) { // com?
         cans = comparse(command_string,"s");
         if( is_void(*cans.sparms) ) { // show overview
            write,"info        show current settings,";
            write,"ebds        set energy boundaries,";
            write,"imdisp      display detector image between current energy limits,";
            write,"lmdisp      display detector logarithmic image between current energy limits,";
            write,"ps          dump current image to .ps file,";
            write,"imsave      write image between current energy limits to FITS file,";
            write,"mreg        make a region pair,";
            write,"dreg        delete a region pair,";
            write,"sreg        save region pair(s),";
            write,"lreg        load region pair(s),";
            write,"ireg        show info on loaded/created regions,";
            write,"normspec    setup a normalization of spectra,";
            write,"ss          create and save spectrum,";
            write,"pspec       plot most recent spectrum,";
            write,"rpos        read position in image in pixels and in WCS,";
            write,"x           exit aspec,";
            write,"?           help - this overview,";
            write,"? <command> help on specified command.";
         } else {
            if( (*cans.sparms)(1) == "imdisp" || (*cans.sparms)(1) == "lmdisp" ) {
               write,"imdisp [sigma] - display image for current setting of emin and emax";
               write,"lmdisp [sigma] - display logarithmic image for current setting of emin and emax";
               write,"                A Gauss kernel smoothing is applied if sigma is given.";
            } else if( (*cans.sparms)(1) == "info" ) {
               write,"info      - show information on current settings";
            } else if( (*cans.sparms)(1) == "ebds" ) {
               write,"ebds [emin [emax]] - set the energy boundaries for";
               write,"                image display and number counts in regions.";
            } else if( (*cans.sparms)(1) == "imsave" ) {
               write,"imsave [filename] - save image for current setting of emin and emax to FITS file";
               write,"                The file name will be automatically assigned unless given.";
            } else if( (*cans.sparms)(1) == "mreg" ) {
               write,"mreg [shape] - define a region pair, src + bkg, by help of the cursor";
               write,"          shape (if given, default is 'ca') must be a two letter string.";
               write,"                The first letter refers to the source region and it can";
               write,"                one of \"c\" (circle) and \"b\" (box).";
               write,"                The second letter refers to the background region and can";
               write,"                be one of \"a\" (annulus with same center as the source),";
               write,"                \"b\" (box), and \"v\" (void, no background will be subtracted).";
            } else if( (*cans.sparms)(1) == "ireg" ) {
               write,"ireg [number] - show region properties for all regions";
               write,"               unless the requested one is given.";
            } else if( (*cans.sparms)(1) == "dreg" ) {
               write,"dreg [number] - delete all regons";
               write,"               unless the requested one is given.";
            } else if( (*cans.sparms)(1) == "sreg" ) {
               write,"sreg [number] - save a region pair, src + bkg, into files";
               write,"               sreg_nnnn.fits and breg_nnnn.fits, where 'nnnn'"
               write,"               is a serial number. 'number' is the number";
               write,"               in the current region list. If omitted then the most recent";
               write,"               region will be saved. If set to zero the all regions will be saved.";
            } else if( (*cans.sparms)(1) == "lreg" ) {
               write,"lreg nnnn [number] - load a region pair, src + bkg, from files";
               write,"               sreg_nnnn.fits and breg_nnnn.fits, where 'nnnn'"
               write,"               is a serial number. 'number' is the row number";
               write,"               in the table. If omitted the first region will be";
               write,"               loaded, if zero all regions (rows) will be loaded.";
               write,"               The number of counts information will be updated";
               write,"               based on the current event list.";
            } else if( (*cans.sparms)(1) == "normspec" ) {
               write,"normspec word - setup the spectral normalization";
               write,"          1      return to spectrum in source area";
               write,"          cm2    give spectrum per cm2 on the detector";
               write,"          pixel  give spectrum per pixel on the detector";
               write," Must be defined before the spectrum is extracted and saved.";
            } else if( (*cans.sparms)(1) == "ss" ) {
               write,"ss [region]  - create and save spectrum with standard filename";
               write,"    region is its number from the list of regions,";
               write,"    if not given the most recent region will be used.";
               write,"  If spectral normalization is requested then the \"normspec\"";
               write,"  command must be given first.";
            } else if( (*cans.sparms)(1) == "pspec" ) {
               write,"pspec [error_fraction]  - plot the most recent spectrum.";
               write,"         A rebinning is done so that the relative error is";
               write,"         less than 0.2. A different value for this fraction";
               write,"         can be given.";
            } else if( (*cans.sparms)(1) == "rpos" ) {
               write,"rpos  -  a position in an image is marked by the cursor";
               write,"         and the coordinates are printed in pixels and in WCS.";
               write,"         The pixel value is also printed.";
            } else if( (*cans.sparms)(1) == "ps" ) {
               write,"ps [plotfilename] -  produce a PS file from current plot.";
               write,"         A specific name may be given.";
            } else if( (*cans.sparms)(1) == "?" ) {
               write,"? [command] - get more detailed help on command";
            }
         }
      }
   }
}

/* Function comparse */

func comparse( str, types )
/* DOCUMENT res = comparse( command_string, types )

     Returns an instance of the struct: s_Command
        res.command    holds the command itself
        res.rparms     is a pointer to the real parameters
        res.iparms     is a pointer to the integer parameters
        res.sparms     is a pointer to the string parameters

    Example:
       > res = comparse( "mreg circle 22 1.0 2.0","sirr" )
       > res.command
       "mreg"
       > *res.sparms
       ["circle"]
       > *res.iparms
       [22]
       > *res.rparms
       [1,2]
*/
{
   // parameters must be space separated

   command = s_Command();
   str = strtrim(strcompress(str));
   keys = strsplit(str," ");
   nkeys = numberof(keys);
   // initialize
   s_nill = [];
   command.rparms = &s_nill;
   command.iparms = &s_nill;
   command.sparms = &s_nill;

   if( nkeys == 1 ) {
      command.command = keys;
   } else {
      command.command = keys(1);
      if( typeof(types) == "string" ) {
         ntypes = strlen(types);
         if( ntypes < nkeys-1 ) {
            write,"comparse: too many keywords - truncated";
            nkeys = ntypes+1;
            keys = keys(nkeys);
         }
         vreal = vint = vstr = [];
         if( ntypes ) {
            for( i = 1; i < nkeys; i++ ) {
               strp = keys(i+1);
               typ = strpart(types,i:i);
               if( typ=="r" ) {
                  grow,vreal,atof(strp);
               } else if( typ=="i" ) {
                  grow,vint,atoi(strp);
               } else if( typ=="s" ) {
                  grow,vstr,strp;
               } else {
                  error,"Invalid type definition";
               }
            } // for( i = ...
         } // if( ntypes )
         command.rparms = &vreal;
         command.iparms = &vint;
         command.sparms = &vstr;
      }
   }
   return command;
}

/* Function keyparse */

func keyparse( str )
/* DOCUMENT res = keyparse( str )

    Interprets a string of shape 'keyword=value' that contains no spaces.
    If the input string fulfills this requirement a struct (s_Keyword)
    is returned, else nil.

     2012-01-16/NJW
*/
{
   // 'str' must be a string
   if( typeof(str) != "string" ) return [];
   // a '=' sign must be present
   pe = strpos( str, "=" );
   if( pe == 0 ) return [];
   // no spaces can be present
   if( strpos(str," ") ) return [];
   // the '=' cannot be the first nor the last character
   len = strlen(str);
   if( pe == 1 || pe == len) return [];
   res = s_Keyword();
   res.keyword = strpart( str, 1:pe-1 );
   res.keyvalue = strpart( str, pe+1:len );

   return res;
}
%FILE% aspec-2.4.i
#include "rmf_funcs.i"
#include "curreg.i"
#include "ds9reg.i"
#include "island.i"

// A struct for the command with parameters

struct s_Command {
   string command;
   pointer rparms;
   pointer iparms;
   pointer sparms;
}

// A struct for the command key words

struct s_Keyword {
   string keyword;
   string keyvalue;
}

// A struct for the regions

struct s_Reg {
   string type;
   string shape;
   double xcen;
   double ycen;
   long area;
   long ncts;
   pointer params;
   pointer imsegment;
   pointer n_outline;
   pointer p_outline;
   pointer x_outline;
   pointer y_outline;
}

Version = "2.4"; // 2012-08-24

void_value = [];

write,"";
write,"         --------------------------------------------------------";
write,"         |   Welcome to the spectral analysis tool: aspec-"+Version+"   |";
write,"         --------------------------------------------------------";
write,"";
write,"aspec is invoked as:  > aspec, event_file_name, ..";
write,"";
write,"   Accepts several event files that will be concatenated.";
write,"   'aspec' is command driven.";
write,"   Entering a '?' will show the command options. After exit 'aspec'";
write,"   can be continued (in the same Yorick session) by simply entering:";
write,"  > aspec";
write,"";
write,"But first choose the telescope:";
write,"      'n' for NuSTAR";
write,"      's' for SXT";
write,"      'o' for other (starts dialogue) :";
write,"";
answer = rdline(prompt=" ... ");
ccc = 1;
if( answer == "n" ) {
   write,"";
   write,"*** This is the NuSTAR verson ***";
   write,"";
   telescop = "NuSTAR";
   parfile = pfiles_path("aspec_nustar.par");
   if( is_void(parfile) ) error,"No aspec_nustar.par found";
   pixel_size = get_par(parfile,"pixel_size"); // mm
   n_det_pixels = get_par(parfile,"n_det_pixels");
   xdetcen = get_par(parfile,"xdetcen"); // pixels
   ydetcen = get_par(parfile,"ydetcen"); // pixels
   Rmf_file = get_par(parfile,"rmf_file");
   Arf_file = get_par(parfile,"arf_file");
   Ebegin = emin_default = get_par(parfile,"emin_default"); // keV
   Eend =   emax_default = get_par(parfile,"emax_default"); // keV
   pixel_area_cm2 = 0.01 * pixel_size^2;
   region_type = "simple"; // other option is 'detailed'
} else if( answer == "s" ) {
   write,"";
   write,"*** This is the SXT verson ***";
   write,"";
   telescop = "SXT";
   if( !file_test("aspec_sxt.par") ) error,"No aspec_sxt.par found in current directory";
   pixel_size = get_par("aspec_sxt.par","pixel_size"); // mm
   n_det_pixels = get_par("aspec_sxt.par","n_det_pixels");
   xdetcen = get_par("aspec_sxt.par","xdetcen"); // pixels
   ydetcen = get_par("aspec_sxt.par","ydetcen"); // pixels
   Rmf_file = get_par("aspec_sxt.par","rmf_file");
   Arf_file = get_par("aspec_sxt.par","arf_file");
   Ebegin = emin_default = get_par("aspec_sxt.par","emin_default"); // keV
   Eend =   emax_default = get_par("aspec_sxt.par","emax_default"); // keV
   pixel_area_cm2 = 0.01 * pixel_size^2;
   region_type = "simple"; // other option is 'detailed'
} else {
   write,"Not implemented yet";
   ccc = 0;
}
instrume = "MT_RAYOR-4.4";
if( ccc ) {
   write,format=" pixel_size = %.2f mm\n", pixel_size;
   write,format=" n_det_pixels = %i\n", n_det_pixels;
   write,format=" xdetcen    = %.2f pixels\n", xdetcen;
   write,format=" ydetcen    = %.2f pixels\n", ydetcen;
   write,format=" RMF: %s\n", Rmf_file;
   write,format=" ARF: %s\n", Arf_file;
   write,"";
}


func aspec( event_file, .., keep_reg= )
/* DOCUMENT aspec[,event_file][,event_file2, ..][, keep_reg=]

    A package for spectral analysis of X-ray mission event data.
    Enter '?' for a list of commands and '? <command>' for some
    more explanation.

    Giving an event_file will reset and read the event data.
    Keyword 'keep_reg' will except the defined regions from the resetting.

    Calling without an event_file will make it resume operations on
    existing data (if the Yorick session has not been interrupted).

    2010-10-20/NJW
    2010-10-28/NJW updated with normalization of spectra
*/
{

   extern Event_files, Rawx, Rawy, Rawxy, Energy, Nevents;
   extern SRegions, BRegions, Exposure, E_min, E_max, Arfs, Energ_lo, Energ_hi;
   extern Arf_file, Rmf_file, SOceans, BOceans;
   extern Rate_src, Rate_err_src, Rate_bkg, Rate_err_bkg, Spec_norm_factor;
   extern Rate_net, Rate_err_net, Spec_norm_rule, Spec_norm_text;
   extern Ebegin, Eend, Esel; // Defines current energy interval for image display
                        // and regions

   // coordinate system from first event file
   extern Coords;

  /*   Spec_norm_rule == 1  :  no renormalization i.e. spectrum in source area
   *                     2  :  spectrum per pixel
   *                     3  :  spectrum per cm2
   */
   Spec_norm_rule = 1; // default starting value
   Spec_norm_factor = 1.; // default starting value
   Spec_norm_text = "Normalized to source region area";

   if( !is_void(event_file) ) {
      Event_files = event_file;
      logfilename = get_next_filename("aspec_????.txt");
      lg = open(logfilename,"w");
      while( more_args() ) grow, Event_files, next_arg();
      n_event_files = numberof(Event_files);
   } else { // continue on current events
      if( is_void(Event_files) ) {
         write,"No session to continue ...";
         write,"Syntax:  aspec, eventfile[, eventfile2[, eventfile3, ..]][,keep_reg=]";
         return;
      }
      logfilename = get_next_filename("aspec_????.txt",latest=1);
      lg = open(logfilename,"a");
   }
   write,"Logging file: "+logfilename;
   write,lg,format="\nLog of 'aspec' on %s\n\n", ndate(3);
   erlog = open("aspec.log","w");

   if( !is_void(event_file) ) {
      for( i = 1; i <= n_event_files; i++ ) {
         if( !file_test(Event_files(i)) ) error,"File "+Event_files(i)+" is not found!";
      }
      write,erlog,"##1## resetting";
      if( !keep_reg ) SRegions = BRegions = [];

      write,"Reading "+Event_files(1)+" ...";
      dol = Event_files(1)+"+1";
      Rawx = rdfitscol(dol,"rawx");
      Rawy = rdfitscol(dol,"rawy");
      Energy = rdfitscol(dol,"energy");
      Esel = indgen(numberof(Energy));
      hdr = headfits(dol);
      Exposure = fxpar(hdr,"exposure");
      n_events = fxpar(hdr,"naxis2");
      write,lg,format="Event_file : %s,  %i events\n", Event_files(1), n_events;

      // get the WCS coordinate system
      Coords = get_wcs( hdr ); // Using recent (120817) function in mfits.i

      if( n_event_files > 1 ) {
         for( i = 2; i <= n_event_files; i++ ) {
            write,"Reading "+Event_files(i)+" ...";
            dol = Event_files(i)+"+1";
            grow, Rawx, rdfitscol(dol,"rawx");
            grow, Rawy, rdfitscol(dol,"rawy");
            grow, Energy, rdfitscol(dol,"energy");
            hdr = headfits(dol);
            exposure = fxpar(hdr,"exposure");
            n_events = fxpar(hdr,"naxis2");
            if( !near( Exposure, exposure, 1. ) ) error,"Wrong exposure in file #"+itoa(i);
            write,lg,format="Event_file : %s,  %i events\n", Event_files(i), n_events;
         }
      }

      Nevents = numberof(Rawx);
      Rawxy = (Rawy - 1)*n_det_pixels + Rawx;
      //+ Rmf_file = "/home/njw/yorick/mraytrace/nustar/test_rmf.fits";
      write,"Using RMF in: "+Rmf_file;
      E_min = rdfitscol(Rmf_file+"[EBOUNDS]","e_min");
      E_max = rdfitscol(Rmf_file+"[EBOUNDS]","e_max");
      write,"Loading ARFs from: "+Arf_file;
      Arfs = rdfitscol(Arf_file+"[SPECRESP]","SPECRESP");
      Energ_lo = rdfitscol(Arf_file+"[SPECRESP]","ENERG_LO")(,1);
      Energ_hi = rdfitscol(Arf_file+"[SPECRESP]","ENERG_HI")(,1);
   }

   im = array(int,n_det_pixels,n_det_pixels);
   for(i=1;i<=Nevents;i++) im(Rawx(i),Rawy(i)) += 1;
   mlogxy,0,0;
   disp,im,title="All events";

   command_string = "";
   while( 1 ) {
      read,format="%[^\n]",prompt="What now? ... ", command_string;
      command_string = strtrim(command_string);
      write,erlog,"##4## command given: "+command_string;
      write,lg,"Command given: "+command_string;
      cans = comparse(command_string);
      cmd = cans.command;

      if( cmd == "x" ) {
         close, lg;
         close, erlog;
         return;
      }

//
// ************************************** info *********************************************************
//
      if( cmd == "info" ) { // cominfo   -  give information on current settings
         cans = comparse(command_string, "i"); // information level
         niparms = numberof(*cans.iparms);

         write,format="Energy range: %.3f - %.3f keV\n", Ebegin, Eend;

//
// ************************************** pal *********************************************************
//
      } else if( cmd == "pal" ) { // compal   -  set the name of the palette
         cans = comparse(command_string, "s"); // name of palette
         nsparms = numberof(*cans.sparms);
         if( nsparms == 1 ) {
            pal = (*cans.sparms)(1);
            if( strpart( pal, -2:0 ) != ".gp" ) pal += ".gp";
            palette, pal;
         }
//
// ************************************** ebds *********************************************************
//
      } else if( cmd == "ebds" ) { // comebds  -  set energy boundaries
         cans = comparse(command_string, "rr"); // Ebegin and Eend
         nrparms = numberof(*cans.rparms);
         if( nrparms == 0 ) {
            Ebegin = emin_default;
            Eend   = emax_default;
         } else if( nrparms == 1 ) {
            Ebegin = (*cans.rparms)(1);
            Eend   = emax_default;
         } else {
            Ebegin = (*cans.rparms)(1);
            Eend   = (*cans.rparms)(2);
         }
         Esel = where( Energy > Ebegin & Energy < Eend );
         nsel = numberof(Esel);
         write,format="Energy range: %.3f - %.3f keV\n", Ebegin, Eend;
         write,format="       containing %i events\n", nsel;
         dsel = where( E_max > Ebegin & E_min < Eend );
         write,format="       and %i detector energy bins\n", numberof(dsel);

      //   Update image and regions wrt. number of counts

         im = array(int,n_det_pixels,n_det_pixels);
         for(i=1;i<=nsel;i++) im(Rawx(Esel(i)),Rawy(Esel(i))) += 1;
         write,erlog,format="##5## emin emax nsel : %.2f %.2f %i\n", Ebegin, Eend, nsel;

         // update the regions
         nreg = numberof(SRegions);
         if( nreg ) {
            for( i = 1; i <= nreg; i++ ) {
               asel = *SRegions(i).imsegment; // area selection
               SRegions(i).ncts = numberof(whereany(Rawxy(Esel), asel));
               asel = *BRegions(i).imsegment; // area selection
               BRegions(i).ncts = numberof(whereany(Rawxy(Esel), asel));
            }
         }

//
// ************************************** imdisp & lmdisp *********************************************************
//
      } else if( cmd == "imdisp" || cmd == "lmdisp" ) { // comimdisp, comlmdisp   -  display detector image
         cans = comparse(command_string, "r"); // image folding sigma

         rim = double(im);
         if( !is_void(*cans.rparms) ) rim = gfconvol(rim,(*cans.rparms)(1));
         mlogxy,0,0;
         if( cmd == "lmdisp" ) disp,log(1.0+rim);
         else disp,rim;

         // add the regions
         nreg = numberof(SRegions);
         for( i = 1; i <= nreg; i++ ) {
            if( SRegions(i).type == "detailed" ) {
               nout = *SRegions(i).n_outline;
               pout = *SRegions(i).p_outline;
               xout = *SRegions(i).x_outline;
               yout = *SRegions(i).y_outline;
               for( j = 1; j <= numberof(nout); j++ ) {
                  oplot,xout(pout(j):pout(j)-1+nout(j)),yout(pout(j):pout(j)-1+nout(j)),color="green";
               }
            } else {
               reg_params = *SRegions(i).params;
               shape      = SRegions(i).shape;
               if( shape == "c" ) {
                  angles = span(0,2*pi,100);
                  oplot,reg_params(1) + reg_params(3)*cos(angles), \
                        reg_params(2) + reg_params(3)*sin(angles), color="green";
               }
               if( shape == "a" ) {
                  angles = span(0,2*pi,100);
                  oplot,reg_params(1) + reg_params(3)*cos(angles), \
                        reg_params(2) + reg_params(3)*sin(angles), color="green";
                  oplot,reg_params(1) + reg_params(4)*cos(angles), \
                        reg_params(2) + reg_params(4)*sin(angles), color="green";
               }
               if( shape == "b" ) {
                  oplot,[reg_params(1),reg_params(3),reg_params(3),reg_params(1), reg_params(1)], \
                        [reg_params(2),reg_params(2),reg_params(4),reg_params(4), reg_params(2)], \
                        color="green";
               }
            }
            if( BRegions(i).shape != "v" ) {
               if( BRegions(i).type == "detailed" ) {
                  nout = *BRegions(i).n_outline;
                  pout = *BRegions(i).p_outline;
                  xout = *BRegions(i).x_outline;
                  yout = *BRegions(i).y_outline;
                  for( j = 1; j <= numberof(nout); j++ ) {
                     oplot,xout(pout(j):pout(j)-1+nout(j)),yout(pout(j):pout(j)-1+nout(j)),color="red";
                  }
               } else {
                  reg_params = *BRegions(i).params;
                  shape      = BRegions(i).shape;
                  if( shape == "c" ) {
                     angles = span(0,2*pi,100);
                     oplot,reg_params(1) + reg_params(3)*cos(angles), \
                           reg_params(2) + reg_params(3)*sin(angles), color="red";
                  }
                  if( shape == "a" || shape == "d" ) {
                     angles = span(0,2*pi,100);
                     oplot,reg_params(1) + reg_params(3)*cos(angles), \
                           reg_params(2) + reg_params(3)*sin(angles), color="red";
                     oplot,reg_params(1) + reg_params(4)*cos(angles), \
                           reg_params(2) + reg_params(4)*sin(angles), color="red";
                  }
                  if( shape == "b" ) {
                     oplot,[reg_params(1),reg_params(3),reg_params(3),reg_params(1), reg_params(1)], \
                           [reg_params(2),reg_params(2),reg_params(4),reg_params(4), reg_params(2)], \
                           color="red";
                  }
               }
            }
         }
//
// ************************************** imsave *********************************************************
//
      } else if( cmd == "imsave"  ) { // comimsave  -  save detector image to FITS
         cans = comparse(command_string, "s"); // given filename

         if( is_void(*cans.sparms) ) {
            fits_name = get_next_filename("aspec_image_????.fits");
         } else {
            fits_name = (*cans.sparms)(1);
         }
         write,lg,"Writing to: "+fits_name;
         write,"Writing to: "+fits_name;
         kwds_init;
         kwds_set,"DATE",ndate(3),"Date/time of file creation";
         kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
         kwds_set,"E_MIN", Ebegin, "[keV] Lower energy limit";
         kwds_set,"E_MAX", Eend, "[keV] Upper energy limit";
         for( i = 1; i <= numberof(Event_files); i++ ) {
            kwds_set,"EVFILE"+itoa(i),Event_files(i);
         }
         if( Coords.flag) {
            kwds_set,"CTYPE1", Coords.ctype1, "Type of coord.system";
            kwds_set,"CTYPE2", Coords.ctype2, "Type of coord.system";
            kwds_set,"CRPIX1", Coords.crpix1, "Reference pixel position";
            kwds_set,"CRPIX2", Coords.crpix2, "Reference pixel position";
            kwds_set,"CRVAL1", Coords.crval1, "Reference coord value";
            kwds_set,"CRVAL2", Coords.crval2, "Reference coord value";
            kwds_set,"CD1_1", Coords.cd1_1, "Part of transf. matrix";
            kwds_set,"CD1_2", Coords.cd1_2, "Part of transf. matrix";
            kwds_set,"CD2_1", Coords.cd2_1, "Part of transf. matrix";
            kwds_set,"CD2_2", Coords.cd2_2, "Part of transf. matrix";
         }
         kwds_set,"EXTNAME","ASPEC_IMAGE","Name of this extension";
         writefits, fits_name, im;
//
// ************************************** rpos *********************************************************
//
      } else if( cmd == "rpos" ) { // comrpos  -  read position in image
         pos = curmark1( style=0,prompt="Mark the position ... " );
         write,format="Pixel position: %7.3f %7.3f\n", pos(1), pos(2);
         local coord1, coord2;
         skypos_fits, Coords, pos(1), pos(2), coord1, coord2, to_sky=1;
         write,format="Coord position: %7.3 %7.3\n", coord1, coord2;
         write,format="Pixel value : %i counts\n", im(int(pos(1)+0.5),int(pos(2)+0.5));
//
// ************************************** gpix *********************************************************
//
      } else if( cmd == "gpix" ) { // comgpix  -  get pixel numbers from WCS
         cans = comparse(command_string, "rr"); // RA and dec
         nrparms = numberof(*cans.rparms);
         if( nrparms != 2 ) {
            write,"Exactly two values must be entered ...";
         } else {
            local pix1, pix2;
            skypos_fits, Coords, pix1, pix2, (*cans.rparms)(1), (*cans.rparms)(2), to_pix=1;
            write,format="Coord position: %7.3 %7.3\n", (*cans.rparms)(1), (*cans.rparms)(2);
            write,format="Pixel position: %7.3f %7.3f\n", pix1, pix2;
            write,format="Pixel value : %i counts\n", im(int(pix1+0.5),int(pix2+0.5));
         }
//
// ************************************** mreg *********************************************************
//
      } else if( cmd == "mreg" ) { // commreg  -  make region pair
         cans = comparse(command_string, "s");
         if( is_void(*cans.sparms) ) {
            s_shape = "c";  // circular region with annulus is the default
            b_shape = "d";  // Annulus with predefined center
         } else {
            shape = (*cans.sparms)(1);
            if( strlen(shape) != 2 ) {
               write,"Parameter must be two-letter string";
               continue;
            }
            s_shape = strpart(shape,1:1);
            b_shape = strpart(shape,2:2);
            if( s_shape != "c" && s_shape != "b" ) {
               write,"Parameter must have c or b as first letter";
               continue;
            }
            if( b_shape != "a" && b_shape != "b" && b_shape != "v" ) {
               write,"Parameter must have a, b, or v as second letter";
               continue;
            }
         }
         // ******  Prepare the regions arrays
         local xcen, ycen, sreg_params, breg_params;
         if( is_void(SRegions) ) {
            //+ 101119 SRegions = s_Reg();
            //+ 101119 BRegions = s_Reg();
            SRegions = array(s_Reg,1);
            BRegions = array(s_Reg,1);
         } else {
            grow, SRegions, s_Reg();
            grow, BRegions, s_Reg();
         }
         nreg = numberof(SRegions);
         // ******  Define the source region
         write,"Define the source region:";
         sel = int(curreg(im,s_shape, xcen, ycen, sreg_params, color="green",thick=2));
         if( region_type != "simple" ) {
            ocean = array(short,n_det_pixels,n_det_pixels);
            ocean(sel) = 1;
            isle = island(ocean);
            c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
            n_outline = int(n_outline);
            p_outline = int(p_outline);
            SRegions(nreg).n_outline = &n_outline;
            SRegions(nreg).p_outline = &p_outline;
            SRegions(nreg).x_outline = &x_outline;
            SRegions(nreg).y_outline = &y_outline;
         }
         SRegions(nreg).type = region_type;
         SRegions(nreg).params = &sreg_params;
         SRegions(nreg).shape = s_shape;
         SRegions(nreg).xcen = xcen;
         SRegions(nreg).ycen = ycen;
         SRegions(nreg).area = numberof(sel);
         SRegions(nreg).imsegment = &sel;
         SRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
         // ******  Define the background region
         if( b_shape == "v" ) { // void i.e. no background but dummy to be defined
            BRegions(nreg).shape = b_shape;
            BRegions(nreg).xcen = xcen;
            BRegions(nreg).ycen = ycen;
            BRegions(nreg).area = 1; // to avoid division by zero
            //+ BRegions(nreg).imsegment = &sel;
            BRegions(nreg).imsegment = &void_value;
            BRegions(nreg).ncts = 0;
            BRegions(nreg).type = region_type;
         } else { // 'a', 'd', or 'b' (annulus or box)
            write,"Define the background region:";
            sel = int(curreg(im, b_shape, xcen, ycen, breg_params, color="red",thick=2));
            if( region_type != "simple" ) {
               ocean = array(short,n_det_pixels,n_det_pixels);
               ocean(sel) = 1;
               isle = island(ocean);
               c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
               n_outline = int(n_outline);
               p_outline = int(p_outline);
               BRegions(nreg).n_outline = &n_outline;
               BRegions(nreg).p_outline = &p_outline;
               BRegions(nreg).x_outline = &x_outline;
               BRegions(nreg).y_outline = &y_outline;
            }
            BRegions(nreg).type = region_type;
            BRegions(nreg).shape = b_shape;
            BRegions(nreg).params = &breg_params;
            BRegions(nreg).xcen = xcen;
            BRegions(nreg).ycen = ycen;
            BRegions(nreg).area = numberof(sel);
            BRegions(nreg).imsegment = &sel;
            BRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
         }

//
// ************************************** dreg *********************************************************
//
      } else if( cmd == "dreg" ) { // comdreg  -  delete region(s)
         cans = comparse(command_string, "i");
         nreg = numberof(SRegions);
         if( nreg == 0 ) {
            write,"No regions have been defined ...";
         } else {
            if( !is_void(*cans.iparms) ) {
               // delete a single region
               i = (*cans.iparms)(1);
               if( i < 1 || i > nreg ) {
                  write,"Requested region is not found ...";
                  continue;
               }
               if( nreg == 1 ) {
                  SRegions = BRegions = [];
               } else {
                  SRegions = rem_elem( SRegions, i );
                  BRegions = rem_elem( BRegions, i );
               }
            } else {
               SRegions = BRegions = [];
            }
         }
//
// ************************************** ireg *********************************************************
//
      } else if( cmd == "ireg" ) { // comireg  -  show region information
         cans = comparse(command_string, "i");
         nreg = numberof(SRegions);
         if( nreg == 0 ) {
            write,"No regions have been defined ...";
         } else {
            i1 = 1; i2 = nreg; // default, show all regions
            if( !is_void(*cans.iparms) ) {
               i1 = i2 = (*cans.iparms)(1);
               if( i1 < 1 || i1 > nreg ) {
                  write,"Requested region is not found ...";
                  i1 = 1; i2 = nreg;
               }
            }
            write,"      #    xcen   ycen     area  shape      ncts";
            for( i = i1; i <= i2; i++ ) {
               write,format="Src: %3i  %6.2f %6.2f %8i    %s %11i\n", \
                  i, SRegions(i).xcen, SRegions(i).ycen, SRegions(i).area, \
                         SRegions(i).shape, SRegions(i).ncts;
               write,format="Bkg: %3i  %6.2f %6.2f %8i    %s %11i\n", \
                  i, BRegions(i).xcen, BRegions(i).ycen, BRegions(i).area, \
                         BRegions(i).shape, BRegions(i).ncts;
               n = SRegions(i).ncts;
               k = BRegions(i).area > 0 ? double(SRegions(i).area)/BRegions(i).area : 1.0;
               b = BRegions(i).ncts;
               dn = sqrt(n + b*(k^2));
               write,format=" Net counts: %.2f +- %.2f\n", n - b*k, dn;
            }
         }
//
// ************************************** sreg *********************************************************
//
      } else if( cmd == "sreg" ) { // comsreg  -  save region information
         nreg = numberof(SRegions);
         cans = comparse(command_string, "i"); // If number > 0 then save that one
                                               // If number == 0 then save all
                                               // If number is not given then save most recent
                                               // In any case a new file will be created
         if( is_void(*cans.iparms) ) {
            n = nreg;
         } else {
            n = (*cans.iparms)(1);
         }
    /*
     *   A region is described by a single row in a FITS files
     */
         local serstr;
         sregfile = get_next_filename("sreg_????.fits", serstr);
         bregfile = "breg_"+serstr+".fits";
         write,"      saving into "+sregfile+" and "+bregfile;
         write,lg,"      saving into "+sregfile+" and "+bregfile;
         if( n == 0 ) { // save all
           // --     source regions
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_SREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of source regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,sregfile,"TYPE",SRegions.type, \
                                "SHAPE",SRegions.shape, \
                                "XCEN",SRegions.xcen, \
                                "YCEN",SRegions.ycen, \
                                "AREA",SRegions.area, \
                                "NCTS",SRegions.ncts, \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            for( i = 1; i <= nreg; i++ ) {
               if( !is_void(*SRegions(i).imsegment) ) {
                  fits_bintable_poke,sregfile+"+1",i,"IMSEGMENT",*SRegions(i).imsegment;
                  if( SRegions(i).type == "detailed" ) {
                     fits_bintable_poke,sregfile+"+1",i,"N_OUTLINE",*SRegions(i).n_outline;
                     fits_bintable_poke,sregfile+"+1",i,"P_OUTLINE",*SRegions(i).p_outline;
                     fits_bintable_poke,sregfile+"+1",i,"X_OUTLINE",*SRegions(i).x_outline;
                     fits_bintable_poke,sregfile+"+1",i,"Y_OUTLINE",*SRegions(i).y_outline;
                  }
                  fits_bintable_poke,sregfile+"+1",i,"PARAMS",*SRegions(i).params;
               }
            }
           // --     background regions
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_BREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of background regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,bregfile,"TYPE",BRegions.type, \
                                "SHAPE",BRegions.shape, \
                                "XCEN",BRegions.xcen, \
                                "YCEN",BRegions.ycen, \
                                "AREA",BRegions.area, \
                                "NCTS",BRegions.ncts, \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            for( i = 1; i <= nreg; i++ ) {
               if( !is_void(*BRegions(i).imsegment) ) {
                  fits_bintable_poke,bregfile+"+1",i,"IMSEGMENT",*BRegions(i).imsegment;
                  if( SRegions(i).type == "detailed" ) {
                     fits_bintable_poke,bregfile+"+1",i,"N_OUTLINE",*BRegions(i).n_outline;
                     fits_bintable_poke,bregfile+"+1",i,"P_OUTLINE",*BRegions(i).p_outline;
                     fits_bintable_poke,bregfile+"+1",i,"X_OUTLINE",*BRegions(i).x_outline;
                     fits_bintable_poke,bregfile+"+1",i,"Y_OUTLINE",*BRegions(i).y_outline;
                  }
                  fits_bintable_poke,sregfile+"+1",i,"PARAMS",*BRegions(i).params;
               }
            }
         } else { // save the specified one
           //  --  the source region
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_SREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a singls source region";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,sregfile,"TYPE",[SRegions(n).type], \
                                "SHAPE",[SRegions(n).shape], \
                                "XCEN",[SRegions(n).xcen], \
                                "YCEN",[SRegions(n).ycen], \
                                "AREA",[SRegions(n).area], \
                                "NCTS",[SRegions(n).ncts], \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            if( !is_void(*SRegions(n).imsegment) ) {
               fits_bintable_poke,sregfile+"+1",1,"IMSEGMENT",*SRegions(n).imsegment;
               if( SRegions(n).type == "detailed" ) {
                  fits_bintable_poke,sregfile+"+1",1,"N_OUTLINE",*SRegions(n).n_outline;
                  fits_bintable_poke,sregfile+"+1",1,"P_OUTLINE",*SRegions(n).p_outline;
                  fits_bintable_poke,sregfile+"+1",1,"X_OUTLINE",*SRegions(n).x_outline;
                  fits_bintable_poke,sregfile+"+1",1,"Y_OUTLINE",*SRegions(n).y_outline;
               }
               fits_bintable_poke,sregfile+"+1",n,"PARAMS",*SRegions(n).params;
            }
           // --  the background region
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_BREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of source regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,bregfile,"TYPE",[BRegions(n).type], \
                                "SHAPE",[BRegions(n).shape], \
                                "XCEN",[BRegions(n).xcen], \
                                "YCEN",[BRegions(n).ycen], \
                                "AREA",[BRegions(n).area], \
                                "NCTS",[BRegions(n).ncts], \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            if( !is_void(*BRegions(n).imsegment) ) {
               fits_bintable_poke,bregfile+"+1",1,"IMSEGMENT",*BRegions(n).imsegment;
               if( SRegions(n).type == "detailed" ) {
                  fits_bintable_poke,bregfile+"+1",1,"N_OUTLINE",*BRegions(n).n_outline;
                  fits_bintable_poke,bregfile+"+1",1,"P_OUTLINE",*BRegions(n).p_outline;
                  fits_bintable_poke,bregfile+"+1",1,"X_OUTLINE",*BRegions(n).x_outline;
                  fits_bintable_poke,bregfile+"+1",1,"Y_OUTLINE",*BRegions(n).y_outline;
               }
               fits_bintable_poke,bregfile+"+1",n,"PARAMS",*BRegions(n).params;
            }
         }
//
// ************************************** lreg *********************************************************
//
      } else if( cmd == "lreg" ) { // comlreg  -  load region information
         nreg = numberof(SRegions);
         //   Command:   lreg NNNN [num]
         //              lreg file=regionfilename

         cans = comparse(command_string, "si"); // If number > 0 is given then load that one
                                                // If number == 0 then load all in file
                                                // If number is not given then load first
                                                // region in the file
        /*
         *   Check the command and the existence of region files
         */

         if( is_void(*cans.sparms) ) {
            error,"Illegal command for lreg";
         } else {
            // see if a keyword has been given:
            kc = keyparse( (*cans.sparms)(1) );
            if( is_void( kc ) ) {
               from_ds9reg = 0;
               serstr = (*cans.sparms)(1);
               lserstr = strlen(serstr);
               if( lserstr != 4 ) error,"Illegal length of str for lreg";
               sregfile = "sreg_"+serstr+".fits";
               if( !file_test(sregfile) ) error,sregfile+" is not found";
               bregfile = "breg_"+serstr+".fits";
               if( !file_test(bregfile) ) error,bregfile+" is not found";
            } else {
               if( kc.keyword != "file" ) error,"Wrong keyword";
               if( !file_test(kc.keyvalue) ) error,"Did not find: "+kc.keyvalue;
               from_ds9reg = 1;
            }
         }

         if( from_ds9reg ) {

            sel = ds9reg(kc.keyvalue,im,Coords,s_shape, xcen, ycen, sreg_params, color="green",thick=2);
            n_sel = numberof(sel);

            while( n_sel > 1 ) {

               grow, SRegions, array(s_Reg,1);
               grow, BRegions, array(s_Reg,1);
               nreg = numberof(SRegions);

               // ******  Define the source region
               if( region_type != "simple" ) {
                  ocean = array(short,n_det_pixels,n_det_pixels);
                  ocean(sel) = 1;
                  isle = island(ocean);
                  c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
                  n_outline = int(n_outline);
                  p_outline = int(p_outline);
                  SRegions(nreg).n_outline = &n_outline;
                  SRegions(nreg).p_outline = &p_outline;
                  SRegions(nreg).x_outline = &x_outline;
                  SRegions(nreg).y_outline = &y_outline;
               }
               SRegions(nreg).type = region_type;
               SRegions(nreg).params = &sreg_params;
               SRegions(nreg).shape = s_shape;
               SRegions(nreg).xcen = xcen;
               SRegions(nreg).ycen = ycen;
               SRegions(nreg).area = numberof(sel);
               SRegions(nreg).imsegment = &sel;
               SRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
               // ******  Define a dummy background region
               BRegions(nreg).shape = "v";
               BRegions(nreg).xcen = xcen;
               BRegions(nreg).ycen = ycen;
               BRegions(nreg).area = 1; // to avoid division by zero
               //+ BRegions(nreg).imsegment = &sel;
               BRegions(nreg).imsegment = &void_value;
               BRegions(nreg).ncts = 0;
               BRegions(nreg).type = region_type;

               sel = ds9reg( ,im,Coords,s_shape, xcen, ycen, sreg_params, color="green",thick=2);
               n_sel = numberof(sel);

            }

         } else {

            if( is_void(*cans.iparms) ) {
               n = 1; // 'n' is the row number
            } else {
               n = (*cans.iparms)(1);
            }
   
            shdr = headfits(sregfile+"+1");
            bhdr = headfits(bregfile+"+1");
            nrows = fxpar( shdr, "naxis2" );
            if( nrows != fxpar( bhdr, "naxis2" ) ) error,"Different number of rows";
   
            if( n > nrows ) error,"Region number exceeds number of rows";
   
            // make room for the regions to be loaded
   
            if( n ) {
               grow, SRegions, array(s_Reg,1);
               grow, BRegions, array(s_Reg,1);
            } else {
               grow, SRegions, array(s_Reg,nrows);
               grow, BRegions, array(s_Reg,nrows);
            }
   
       /*
        *   A region is described by a single row in a FITS files
        */
            if( n == 0 ) { // load all
              // --     source regions
               type  = rdfitscol(sregfile+"+1","TYPE");
               shape = rdfitscol(sregfile+"+1","SHAPE");
               xcen = rdfitscol(sregfile+"+1","XCEN");
               ycen = rdfitscol(sregfile+"+1","YCEN");
               area = rdfitscol(sregfile+"+1","AREA");
               ncts = rdfitscol(sregfile+"+1","NCTS");
               SRegions(nreg+1:nreg+nrows).type  = type;
               SRegions(nreg+1:nreg+nrows).shape = shape;
               SRegions(nreg+1:nreg+nrows).xcen = xcen;
               SRegions(nreg+1:nreg+nrows).ycen = ycen;
               SRegions(nreg+1:nreg+nrows).area = area;
               SRegions(nreg+1:nreg+nrows).ncts = ncts;
               for( i = 1; i <= nrows; i++ ) {
                  d1 = fits_bintable_peek(sregfile+"+1",i,"IMSEGMENT");
                  SRegions(nreg+i).imsegment = &d1;
                  // update number of counts
                  if( !is_void(d1) ) SRegions(nreg+i).ncts = numberof(whereany(Rawxy, d1));
                  d1 = fits_bintable_peek(sregfile+"+1",i,"N_OUTLINE");
                  SRegions(nreg+i).n_outline = &d1;
                  d1 = fits_bintable_peek(sregfile+"+1",i,"P_OUTLINE");
                  SRegions(nreg+i).p_outline = &d1;
                  d1 = fits_bintable_peek(sregfile+"+1",i,"X_OUTLINE");
                  SRegions(nreg+i).x_outline = &d1;
                  d1 = fits_bintable_peek(sregfile+"+1",i,"Y_OUTLINE");
                  SRegions(nreg+i).y_outline = &d1;
                  d1 = fits_bintable_peek(sregfile+"+1",i,"PARAMS");
                  SRegions(nreg+i).params = &d1;
               }
              // --     background regions
               type  = rdfitscol(bregfile+"+1","TYPE");
               shape = rdfitscol(bregfile+"+1","SHAPE");
               xcen = rdfitscol(bregfile+"+1","XCEN");
               ycen = rdfitscol(bregfile+"+1","YCEN");
               area = rdfitscol(bregfile+"+1","AREA");
               ncts = rdfitscol(bregfile+"+1","NCTS");
               BRegions(nreg+1:nreg+nrows).type = type;
               BRegions(nreg+1:nreg+nrows).shape = shape;
               BRegions(nreg+1:nreg+nrows).xcen = xcen;
               BRegions(nreg+1:nreg+nrows).ycen = ycen;
               BRegions(nreg+1:nreg+nrows).area = area;
               BRegions(nreg+1:nreg+nrows).ncts = ncts;
               for( i = 1; i <= nrows; i++ ) {
                  d1 = fits_bintable_peek(bregfile+"+1",i,"IMSEGMENT");
                  BRegions(nreg+i).imsegment = &d1;
                  // update number of counts
                  if( !is_void(d1) ) BRegions(nreg+i).ncts = numberof(whereany(Rawxy, d1));
                  d1 = fits_bintable_peek(bregfile+"+1",i,"N_OUTLINE");
                  BRegions(nreg+i).n_outline = &d1;
                  d1 = fits_bintable_peek(bregfile+"+1",i,"P_OUTLINE");
                  BRegions(nreg+i).p_outline = &d1;
                  d1 = fits_bintable_peek(bregfile+"+1",i,"X_OUTLINE");
                  BRegions(nreg+i).x_outline = &d1;
                  d1 = fits_bintable_peek(bregfile+"+1",i,"Y_OUTLINE");
                  BRegions(nreg+i).y_outline = &d1;
                  d1 = fits_bintable_peek(bregfile+"+1",i,"PARAMS");
                  BRegions(nreg+i).params = &d1;
               }
            } else { // load the specified one(s)
              //  --  the source region
               type  = rdfitscol(sregfile+"+1","TYPE");
               shape = rdfitscol(sregfile+"+1","SHAPE");
               xcen = rdfitscol(sregfile+"+1","XCEN");
               ycen = rdfitscol(sregfile+"+1","YCEN");
               area = rdfitscol(sregfile+"+1","AREA");
               ncts = rdfitscol(sregfile+"+1","NCTS");
               SRegions(nreg+1).type  = type(n);
               SRegions(nreg+1).shape = shape(n);
               SRegions(nreg+1).xcen = xcen(n);
               SRegions(nreg+1).ycen = ycen(n);
               SRegions(nreg+1).area = area(n);
               SRegions(nreg+1).ncts = ncts(n);
   
               d1 = fits_bintable_peek(sregfile+"+1",n,"IMSEGMENT");
               SRegions(nreg+1).imsegment = &d1;
               // update number of counts
               if( !is_void(d1) ) SRegions(nreg+1).ncts = numberof(whereany(Rawxy, d1));
               d1 = fits_bintable_peek(sregfile+"+1",n,"N_OUTLINE");
               SRegions(nreg+1).n_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",n,"P_OUTLINE");
               SRegions(nreg+1).p_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",n,"X_OUTLINE");
               SRegions(nreg+1).x_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",n,"Y_OUTLINE");
               SRegions(nreg+1).y_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",n,"PARAMS");
               SRegions(nreg+1).params = &d1;
   
              // --  the background region
               type  = rdfitscol(bregfile+"+1","TYPE");
               shape = rdfitscol(bregfile+"+1","SHAPE");
               xcen = rdfitscol(bregfile+"+1","XCEN");
               ycen = rdfitscol(bregfile+"+1","YCEN");
               area = rdfitscol(bregfile+"+1","AREA");
               ncts = rdfitscol(bregfile+"+1","NCTS");
               BRegions(nreg+1).type = type(n);
               BRegions(nreg+1).shape = shape(n);
               BRegions(nreg+1).xcen = xcen(n);
               BRegions(nreg+1).ycen = ycen(n);
               BRegions(nreg+1).area = area(n);
               BRegions(nreg+1).ncts = ncts(n);
   
               d1 = fits_bintable_peek(bregfile+"+1",n,"IMSEGMENT");
               BRegions(nreg+1).imsegment = &d1;
               // update number of counts
               if( !is_void(d1) ) BRegions(nreg+1).ncts = numberof(whereany(Rawxy, d1));
               d1 = fits_bintable_peek(bregfile+"+1",n,"N_OUTLINE");
               BRegions(nreg+1).n_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",n,"P_OUTLINE");
               BRegions(nreg+1).p_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",n,"X_OUTLINE");
               BRegions(nreg+1).x_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",n,"Y_OUTLINE");
               BRegions(nreg+1).y_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",n,"PARAMS");
               BRegions(nreg+1).params = &d1;
            }
         }
//
// ************************************** ps *********************************************************
//
      } else if( cmd == "ps" ) { // comps - dump plot to ps file
         cans = comparse(command_string, "s");
         plotsign;
         plotname,"Spectrum by aspec";
         zps,outfile=(*cans.sparms)(1),noc=1;
//
// ************************************** ss *********************************************************
//
      } else if( cmd == "ss" ) { // comss - save spectrum and background
         // accept up to four parameters (keyvalues)
         //    1) single number - the region number e.g. 'ss 3'
         //    2) by keyword e.g. 'ss reg=3'
         //    3) by keyword only e.g. 'ss ignbkg=1 reg=3' (remember no spaces)
         bb = comparse(command_string,"ssss");
         nbb = numberof(*bb.sparms);
         ireg = 0;
         ignbkg = 0; // ignore background
         if( nbb ) {
            for( i = 1; i <= nbb; i++ ) {
               // get the 'keyword=value' if this format is entered
               //  else [] is returned
               kbb = keyparse((*bb.sparms)(i));
               if( is_void(kbb) ) { // simple value interpreted as the region number
                  cans = comparse(command_string, "i");
                  ireg = (*cans.iparms)(i);
                  write,"Setting ireg ("+itoa(ireg)+") from simple value ...";
               } else {
                  if( kbb.keyword == "ignbkg" ) {
                     ignbkg = kbb.keyvalue;
                     write,"Setting ignbkg ("+itoa(ignbkg)+") from keyword ...";
                  }
                  if( kbb.keyword == "reg" ) {
                     ireg = kbb.keyvalue;
                     write,"Setting ireg ("+itoa(ireg)+") from keyword ...";
                  }
               }
            }
         }
         nreg = numberof(SRegions);
         if( ireg == 0 ) ireg = nreg;
         write,lg,"Extracting spectrum for region # ",+itoa(ireg);

         //  Extract the spectrum

         s_sel = whereany(Rawxy, *SRegions(ireg).imsegment);
         b_sel = BRegions(ireg).shape == "v" ? [] : whereany(Rawxy, *BRegions(ireg).imsegment);
         if( ignbkg ) b_sel = [];

         //     Rate_src (Rate_err_src) is for total counts in source region
         //     Rate_bkg (Rate_err_bkg) is for renormalized counts in background region
         //     Rate_net (Rate_err_net) is for background subtracted counts

         specbinning, Energy(s_sel), E_min, E_max, Rate_src, Rate_err_src, exposure=Exposure;
         if( is_void(b_sel) ) {
            // if background is not considered make null spectrum
            Rate_bkg = Rate_err_bkg = Rate_src*0;
         } else {
            specbinning, Energy(b_sel), E_min, E_max, Rate_bkg, Rate_err_bkg, exposure=Exposure;
         }

         //  Renormalize background to adapt to source region size

         corf = float(SRegions(ireg).area)/BRegions(ireg).area;
         Rate_bkg *= corf;    // normalize to source area
         Rate_err_bkg *= corf;

         //  Get the net spectrum

         Rate_net = Rate_src - Rate_bkg;
         Rate_err_net = sqrt(Rate_err_src^2 + Rate_err_bkg^2);

         //  Renormalize the spectrum to pixel or unit area if requested

         if( Spec_norm_rule == 2 ) { // per pixel
            Spec_norm_factor = 1.0/SRegions(ireg).area;
         } else if( Spec_norm_rule == 3 ) { // per cm2
            Spec_norm_factor = 1.0/(SRegions(ireg).area*pixel_area_cm2);
         } else Spec_norm_factor = 1.0;

         Rate_src *= Spec_norm_factor;
         Rate_err_src *= Spec_norm_factor;
         Rate_bkg *= Spec_norm_factor;
         Rate_err_bkg *= Spec_norm_factor;
         Rate_net *= Spec_norm_factor;
         Rate_err_net *= Spec_norm_factor;

         // select the ARF based on distance to center
         dist = sqrt((SRegions(ireg).xcen - xdetcen)^2 + (SRegions(ireg).ycen - ydetcen)^2);
         //  now in pixels, convert to arcmin
         dist *= (pixel_size*180.*60.)/(10140.*pi);
         // given that the focal length is 10140 mm
         d = span(0.,9.,10);
         w = where( d > dist ); // now w(1) is the index on one side
                 // and w(1)-1 is the index on the other side
         if( !numberof(w) ) {
            write,"The region center is too far away";
         } else {
            i = w(1) - 1;
            arf = float(Arfs(,i) + ((dist - d(i))/(d(i+1)-d(i)))*(Arfs(,i+1)-Arfs(,i)));
            arffile = fullpath(get_next_filename("arf_????.fits"));
            arf2phaii, arffile, arf, Energ_lo, Energ_hi, extname="SPECRESP",\
                instrume=instrume,telescop=telescop;
            write,"ARF file made : "+arffile;

            // Allways make three spectral files: net, total, and bkg
            local ser_str;
            spec_net_file = get_next_filename("spec_net_????.fits",ser_str);
            spec_bkg_file  = "spec_bkg_"+ser_str+".fits";
            spec_tot_file  = "spec_tot_"+ser_str+".fits";

            kwds_init;
            kwds_set,"NUMSRCPX", SRegions(ireg).area,"Number of source pixels";
            kwds_set,"NUMBKGPX", BRegions(ireg).area,"Number of background pixels";
            kwds_set,"REGXCEN", SRegions(ireg).xcen,"X pixel for region center";
            kwds_set,"REGYCEN", SRegions(ireg).ycen,"Y pixel for region center";
            kwds_set,"SRGSHAPE", SRegions(ireg).shape,"Shape of source region";
            kwds_set,"BRGSHAPE", BRegions(ireg).shape,"Shape of background region";
            kwds_set,"NORMFACT", Spec_norm_factor,"Spectral renormalization factor";
            kwds_set,"NORMTEXT", Spec_norm_text,"Explanation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";

            // Write net spectrum

            spec2phaii,spec_net_file,Rate_net,Rate_err_net,type="net",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,backfile=spec_bkg_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Net spectrum has been written to : "+spec_net_file;
            write,lg,"Net spectrum has been written to : "+spec_net_file;

            // Write bkg spectrum

            spec2phaii,spec_bkg_file,Rate_bkg,Rate_err_bkg,type="bkg",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Background spectrum has been written to : "+spec_bkg_file;
            write,lg,"Background spectrum has been written to : "+spec_bkg_file;

            // Write total spectrum

            spec2phaii,spec_tot_file,Rate_src,Rate_err_src,type="total",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,backfile=spec_bkg_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Total spectrum has been written to : "+spec_tot_file;
            write,lg,"Total spectrum has been written to : "+spec_tot_file;
         }
//
// ************************************** normspec *********************************************************
//
      } else if( cmd == "normspec" ) { // comnormspec - normalize spectrum
         cans = comparse(command_string,"s");
         if( !is_void(*cans.sparms) ) {
            if( (*cans.sparms)(1) == "1" ) {
               Spec_norm_rule = 1;
               Spec_norm_text = "Normalized to source region area";
            } else if( (*cans.sparms)(1) == "pixel" ) {
               Spec_norm_rule = 2;
               Spec_norm_text = "Normalized to a single pixel";
            } else if( (*cans.sparms)(1) == "cm2" ) {
               Spec_norm_rule = 3;
               Spec_norm_text = "Normalized to a cm2 on the detector";
            }
            write,"Next spectrum will be "+Spec_norm_text;
         }
//
// ************************************** pspec *********************************************************
//
      } else if( cmd == "pspec" ) { // compspec  - plot most recent spectrum
         cans = comparse(command_string,"r");
         frac = is_void(*cans.rparms) ? 0.2 : (*cans.rparms)(1);
         //+ 101123 plot_spectrum,E_min,E_max,Rate_src,Rate_err_src,itype=3;
         local ob1, ob2, orate, orate_err;
         REBIN = specrebinninga( E_min, E_max, Rate_src, Rate_err_src, frac, ob1, ob2, orate, orate_err);
         plot_spectrum, ob1, ob2, orate, orate_err, itype=3;
         if(!is_void(b_sel)) {
            //+ specrebinninga, E_min, E_max, Rate_bkg, Rate_err_bkg, frac, ob1, ob2, orate, orate_err;
            specrebinning, E_min, E_max, Rate_bkg, Rate_err_bkg, REBIN, ob1, ob2, orate, orate_err;
            oplot_spectrum, ob1, ob2, orate, orate_err,color="red";
         }
         //+ specrebinninga, E_min, E_max, Rate_net, Rate_err_net, frac, ob1, ob2, orate, orate_err;
         specrebinning, E_min, E_max, Rate_net, Rate_err_net, REBIN, ob1, ob2, orate, orate_err;
         oplot_spectrum, ob1, ob2, orate, orate_err,color="green";
//
// ************************************** ? *********************************************************
//
      } else if( cmd == "?" ) { // com?
         cans = comparse(command_string,"s");
         if( is_void(*cans.sparms) ) { // show overview
            write,"info        show current settings,";
            write,"ebds        set energy boundaries,";
            write,"imdisp      display detector image between current energy limits,";
            write,"lmdisp      display detector logarithmic image between current energy limits,";
            write,"pal         define the name of the palette to use for images,";
            write,"ps          dump current image to .ps file,";
            write,"imsave      write image between current energy limits to FITS file,";
            write,"evtsave     write events in region to an event file (not implemented),";
            write,"mreg        make a region pair,";
            write,"dreg        delete a region pair,";
            write,"sreg        save region pair(s),";
            write,"lreg        load region pair(s),";
            write,"ireg        show info on loaded/created regions,";
            write,"normspec    setup a normalization of spectra,";
            write,"ss          create and save spectrum,";
            write,"pspec       plot most recent spectrum,";
            write,"rpos        read position in image in pixels and in WCS,";
            write,"gpix        get pixel numbers from WCS coordinates,";
            write,"x           exit aspec,";
            write,"?           help - this overview,";
            write,"? <command> help on specified command.";
         } else {
            if( (*cans.sparms)(1) == "imdisp" || (*cans.sparms)(1) == "lmdisp" ) {
               write,"imdisp [sigma] - display image for current setting of emin and emax";
               write,"lmdisp [sigma] - display logarithmic image for current setting of emin and emax";
               write,"                A Gauss kernel smoothing is applied if sigma is given.";
            } else if( (*cans.sparms)(1) == "info" ) {
               write,"info      - show information on current settings";
            } else if( (*cans.sparms)(1) == "pal" ) {
               write,"pal name  - Define name of palette (the .gp postfix may be left out)";
            } else if( (*cans.sparms)(1) == "ebds" ) {
               write,"ebds [emin [emax]] - set the energy boundaries for";
               write,"                image display and number counts in regions.";
            } else if( (*cans.sparms)(1) == "imsave" ) {
               write,"imsave [filename] - save image for current setting of emin and emax to FITS file";
               write,"                The file name will be automatically assigned unless given.";
            } else if( (*cans.sparms)(1) == "mreg" ) {
               write,"mreg [shape] - define a region pair, src + bkg, by help of the cursor";
               write,"          shape (if given, default is 'ca') must be a two letter string.";
               write,"                The first letter refers to the source region and it can";
               write,"                one of \"c\" (circle) and \"b\" (box).";
               write,"                The second letter refers to the background region and can";
               write,"                be one of \"a\" (annulus with same center as the source),";
               write,"                \"b\" (box), and \"v\" (void, no background will be subtracted).";
            } else if( (*cans.sparms)(1) == "ireg" ) {
               write,"ireg [number] - show region properties for all regions";
               write,"               unless the requested one is given.";
            } else if( (*cans.sparms)(1) == "dreg" ) {
               write,"dreg [number] - delete all regons";
               write,"               unless the requested one is given.";
            } else if( (*cans.sparms)(1) == "sreg" ) {
               write,"sreg [number] - save a region pair, src + bkg, into files";
               write,"               sreg_nnnn.fits and breg_nnnn.fits, where 'nnnn'"
               write,"               is a serial number. 'number' is the number";
               write,"               in the current region list. If omitted then the most recent";
               write,"               region will be saved. If set to zero the all regions will be saved.";
            } else if( (*cans.sparms)(1) == "lreg" ) {
               write,"lreg nnnn [number] - load a region pair, src + bkg, from files";
               write,"               sreg_nnnn.fits and breg_nnnn.fits, where 'nnnn'"
               write,"               is a serial number. 'number' is the row number";
               write,"               in the table. If omitted the first region will be";
               write,"               loaded, if zero all regions (rows) will be loaded.";
               write,"               The number of counts information will be updated";
               write,"               based on the current event list.";
            } else if( (*cans.sparms)(1) == "normspec" ) {
               write,"normspec word - setup the spectral normalization";
               write,"          1      return to spectrum in source area";
               write,"          cm2    give spectrum per cm2 on the detector";
               write,"          pixel  give spectrum per pixel on the detector";
               write," Must be defined before the spectrum is extracted and saved.";
            } else if( (*cans.sparms)(1) == "ss" ) {
               write,"ss [region]  - create and save spectrum with standard filename";
               write,"    region is its number from the list of regions,";
               write,"    if not given the most recent region will be used.";
               write,"  If spectral normalization is requested then the \"normspec\"";
               write,"  command must be given first.";
            } else if( (*cans.sparms)(1) == "pspec" ) {
               write,"pspec [error_fraction]  - plot the most recent spectrum.";
               write,"         A rebinning is done so that the relative error is";
               write,"         less than 0.2. A different value for this fraction";
               write,"         can be given.";
            } else if( (*cans.sparms)(1) == "rpos" ) {
               write,"rpos  -  a position in an image is marked by the cursor";
               write,"         and the coordinates are printed in pixels and in WCS.";
               write,"         The pixel value is also printed.";
            } else if( (*cans.sparms)(1) == "ps" ) {
               write,"ps [plotfilename] -  produce a PS file from current plot.";
               write,"         A specific name may be given.";
            } else if( (*cans.sparms)(1) == "?" ) {
               write,"? [command] - get more detailed help on command";
            }
         }
      }
   }
}

/* Function comparse */

func comparse( str, types )
/* DOCUMENT res = comparse( command_string, types )

     Returns an instance of the struct: s_Command
        res.command    holds the command itself
        res.rparms     is a pointer to the real parameters
        res.iparms     is a pointer to the integer parameters
        res.sparms     is a pointer to the string parameters

    Example:
       > res = comparse( "mreg circle 22 1.0 2.0","sirr" )
       > res.command
       "mreg"
       > *res.sparms
       ["circle"]
       > *res.iparms
       [22]
       > *res.rparms
       [1,2]
*/
{
   // parameters must be space separated

   command = s_Command();
   str = strtrim(strcompress(str));
   keys = strsplit(str," ");
   nkeys = numberof(keys);
   // initialize
   s_nill = [];
   command.rparms = &s_nill;
   command.iparms = &s_nill;
   command.sparms = &s_nill;

   if( nkeys == 1 ) {
      command.command = keys;
   } else {
      command.command = keys(1);
      if( typeof(types) == "string" ) {
         ntypes = strlen(types);
         if( ntypes < nkeys-1 ) {
            write,"comparse: too many keywords - truncated";
            nkeys = ntypes+1;
            keys = keys(nkeys);
         }
         vreal = vint = vstr = [];
         if( ntypes ) {
            for( i = 1; i < nkeys; i++ ) {
               strp = keys(i+1);
               typ = strpart(types,i:i);
               if( typ=="r" ) {
                  grow,vreal,atof(strp);
               } else if( typ=="i" ) {
                  grow,vint,atoi(strp);
               } else if( typ=="s" ) {
                  grow,vstr,strp;
               } else {
                  error,"Invalid type definition";
               }
            } // for( i = ...
         } // if( ntypes )
         command.rparms = &vreal;
         command.iparms = &vint;
         command.sparms = &vstr;
      }
   }
   return command;
}

/* Function keyparse */

func keyparse( str )
/* DOCUMENT res = keyparse( str )

    Interprets a string of shape 'keyword=value' that contains no spaces.
    If the input string fulfills this requirement a struct (s_Keyword)
    is returned, else nil.

     2012-01-16/NJW
*/
{
   // 'str' must be a string
   if( typeof(str) != "string" ) return [];
   // a '=' sign must be present
   pe = strpos( str, "=" );
   if( pe == 0 ) return [];
   // no spaces can be present
   if( strpos(str," ") ) return [];
   // the '=' cannot be the first nor the last character
   len = strlen(str);
   if( pe == 1 || pe == len) return [];
   res = s_Keyword();
   res.keyword = strpart( str, 1:pe-1 );
   res.keyvalue = strpart( str, pe+1:len );

   return res;
}
%FILE% aspec.i
#include "rmf_funcs.i"
#include "curreg.i"
#include "ds9reg.i"
#include "island.i"

// A struct for the command with parameters

struct s_Command {
   string command;
   pointer rparms;
   pointer iparms;
   pointer sparms;
}

// A struct for the command key words

struct s_Keyword {
   string keyword;
   string keyvalue;
}

// A struct for the regions

struct s_Reg {
   string type;
   string shape;
   double xcen;
   double ycen;
   long area;
   long ncts;
   pointer params;
   pointer imsegment;
   pointer n_outline;
   pointer p_outline;
   pointer x_outline;
   pointer y_outline;
}

Version = "2.5"; // 2012-09-25 Introduce dead area of detector

void_value = [];

write,"";
write,"         --------------------------------------------------------";
write,"         |   Welcome to the spectral analysis tool: aspec-"+Version+"   |";
write,"         --------------------------------------------------------";
write,"";
write,"aspec is invoked as:  > aspec, event_file_name, ..";
write,"";
write,"   Accepts several event files that will be concatenated.";
write,"   'aspec' is command driven.";
write,"   Entering a '?' will show the command options. After exit 'aspec'";
write,"   can be continued (in the same Yorick session) by simply entering:";
write,"  > aspec";
write,"";
write,"But first choose the telescope:";
write,"      'n' for NuSTAR";
write,"      's' for SXT";
write,"      'o' for other (starts dialogue) :";
write,"";
answer = rdline(prompt=" ... ");
ccc = 1;
if( answer == "n" ) {
   write,"";
   write,"*** This is the NuSTAR verson ***";
   write,"";
   telescop = "NuSTAR";
   parfile = pfiles_path("aspec_nustar.par");
   if( is_void(parfile) ) error,"No aspec_nustar.par found";
   pixel_size = get_par(parfile,"pixel_size"); // mm
   n_det_pixels = get_par(parfile,"n_det_pixels");
   xdetcen = get_par(parfile,"xdetcen"); // pixels
   ydetcen = get_par(parfile,"ydetcen"); // pixels
   Rmf_file = get_par(parfile,"rmf_file");
   Arf_file = get_par(parfile,"arf_file");
   Ebegin = emin_default = get_par(parfile,"emin_default"); // keV
   Eend =   emax_default = get_par(parfile,"emax_default"); // keV
   dead_pixel_map_dol = get_par(parfile,"dead_pixel_map");
   if( is_void(dead_pixel_map_dol) || dead_pixel_map_dol == "none" ) {
      Dead_pixel_map = array(short,n_det_pixels,n_det_pixels);
   } else {
      Dead_pixel_map = readfits(dead_pixel_map_dol);
      dmsdpm = dimsof(Dead_pixel_map);
      if( dmsdpm(2) != n_det_pixels || dmsdpm(3) != n_det_pixels ) \
         error,"##63## Inconsistency in detector pixels and dpm";
   }
   dead_idx = where(Dead_pixel_map);
   pixel_area_cm2 = 0.01 * pixel_size^2;
   region_type = "simple"; // other option is 'detailed'
} else if( answer == "s" ) {
   write,"";
   write,"*** This is the SXT verson ***";
   write,"";
   telescop = "SXT";
   if( !file_test("aspec_sxt.par") ) error,"No aspec_sxt.par found in current directory";
   pixel_size = get_par("aspec_sxt.par","pixel_size"); // mm
   n_det_pixels = get_par("aspec_sxt.par","n_det_pixels");
   xdetcen = get_par("aspec_sxt.par","xdetcen"); // pixels
   ydetcen = get_par("aspec_sxt.par","ydetcen"); // pixels
   Rmf_file = get_par("aspec_sxt.par","rmf_file");
   Arf_file = get_par("aspec_sxt.par","arf_file");
   Ebegin = emin_default = get_par("aspec_sxt.par","emin_default"); // keV
   Eend =   emax_default = get_par("aspec_sxt.par","emax_default"); // keV
   pixel_area_cm2 = 0.01 * pixel_size^2;
   region_type = "simple"; // other option is 'detailed'
} else {
   write,"Not implemented yet";
   ccc = 0;
}
instrume = "MT_RAYOR-4.4";
if( ccc ) {
   write,format=" pixel_size = %.2f mm\n", pixel_size;
   write,format=" n_det_pixels = %i\n", n_det_pixels;
   write,format=" xdetcen    = %.2f pixels\n", xdetcen;
   write,format=" ydetcen    = %.2f pixels\n", ydetcen;
   write,format=" RMF: %s\n", Rmf_file;
   write,format=" ARF: %s\n", Arf_file;
   write,"";
}


func aspec( event_file, .., keep_reg= )
/* DOCUMENT aspec[,event_file][,event_file2, ..][, keep_reg=]

    A package for spectral analysis of X-ray mission event data.
    Enter '?' for a list of commands and '? <command>' for some
    more explanation.

    Giving an event_file will reset and read the event data.
    Keyword 'keep_reg' will except the defined regions from the resetting.

    Calling without an event_file will make it resume operations on
    existing data (if the Yorick session has not been interrupted).

    2010-10-20/NJW
    2010-10-28/NJW updated with normalization of spectra
*/
{

   extern Event_files, Rawx, Rawy, Rawxy, Energy, Nevents;
   extern SRegions, BRegions, Exposure, E_min, E_max, Arfs, Energ_lo, Energ_hi;
   extern Arf_file, Rmf_file, SOceans, BOceans;
   extern Rate_src, Rate_err_src, Rate_bkg, Rate_err_bkg, Spec_norm_factor;
   extern Rate_net, Rate_err_net, Spec_norm_rule, Spec_norm_text;
   extern Ebegin, Eend, Esel; // Defines current energy interval for image display
                        // and regions

   // coordinate system from first event file
   extern Coords;

  /*   Spec_norm_rule == 1  :  no renormalization i.e. spectrum in source area
   *                     2  :  spectrum per pixel
   *                     3  :  spectrum per cm2
   */
   Spec_norm_rule = 1; // default starting value
   Spec_norm_factor = 1.; // default starting value
   Spec_norm_text = "Normalized to source region area";

   if( !is_void(event_file) ) {
      Event_files = event_file;
      logfilename = get_next_filename("aspec_????.txt");
      lg = open(logfilename,"w");
      while( more_args() ) grow, Event_files, next_arg();
      n_event_files = numberof(Event_files);
   } else { // continue on current events
      if( is_void(Event_files) ) {
         write,"No session to continue ...";
         write,"Syntax:  aspec, eventfile[, eventfile2[, eventfile3, ..]][,keep_reg=]";
         return;
      }
      logfilename = get_next_filename("aspec_????.txt",latest=1);
      lg = open(logfilename,"a");
   }
   write,"Logging file: "+logfilename;
   write,lg,format="\nLog of 'aspec' on %s\n\n", ndate(3);
   erlog = open("aspec.log","w");

   if( !is_void(event_file) ) {
      for( i = 1; i <= n_event_files; i++ ) {
         if( !file_test(Event_files(i)) ) error,"File "+Event_files(i)+" is not found!";
      }
      write,erlog,"##1## resetting";
      if( !keep_reg ) SRegions = BRegions = [];

      write,"Reading "+Event_files(1)+" ...";
      dol = Event_files(1)+"+1";
      Rawx = rdfitscol(dol,"rawx");
      Rawy = rdfitscol(dol,"rawy");
      Energy = rdfitscol(dol,"energy");
      Esel = indgen(numberof(Energy));
      hdr = headfits(dol);
      Exposure = fxpar(hdr,"exposure");
      n_events = fxpar(hdr,"naxis2");
      write,lg,format="Event_file : %s,  %i events\n", Event_files(1), n_events;

      // get the WCS coordinate system
      Coords = get_wcs( hdr ); // Using recent (120817) function in mfits.i

      if( n_event_files > 1 ) {
         for( i = 2; i <= n_event_files; i++ ) {
            write,"Reading "+Event_files(i)+" ...";
            dol = Event_files(i)+"+1";
            grow, Rawx, rdfitscol(dol,"rawx");
            grow, Rawy, rdfitscol(dol,"rawy");
            grow, Energy, rdfitscol(dol,"energy");
            hdr = headfits(dol);
            exposure = fxpar(hdr,"exposure");
            n_events = fxpar(hdr,"naxis2");
            if( !near( Exposure, exposure, 1. ) ) error,"Wrong exposure in file #"+itoa(i);
            write,lg,format="Event_file : %s,  %i events\n", Event_files(i), n_events;
         }
      }

      // Filter out the dead detector areas

      if( !is_void(dead_idx) ) {
         ev_idx = (Rawy - 1) * n_det_pixels + Rawx;
         idx = whereany( ev_idx, dead_idx );
         if( numberof(idx) ) {
            ev_idxn = rem_elem( ev_idx, idx );
            Rawx = Rawx(ev_idxn);
            Rawy = Rawy(ev_idxn);
            Energy = Energy(ev_idxn);
         }
      }

      Nevents = numberof(Rawx);
      Rawxy = (Rawy - 1)*n_det_pixels + Rawx;
      //+ Rmf_file = "/home/njw/yorick/mraytrace/nustar/test_rmf.fits";
      write,"Using RMF in: "+Rmf_file;
      E_min = rdfitscol(Rmf_file+"[EBOUNDS]","e_min");
      E_max = rdfitscol(Rmf_file+"[EBOUNDS]","e_max");
      write,"Loading ARFs from: "+Arf_file;
      Arfs = rdfitscol(Arf_file+"[SPECRESP]","SPECRESP");
      Energ_lo = rdfitscol(Arf_file+"[SPECRESP]","ENERG_LO")(,1);
      Energ_hi = rdfitscol(Arf_file+"[SPECRESP]","ENERG_HI")(,1);
   }

   im = array(int,n_det_pixels,n_det_pixels);
   for(i=1;i<=Nevents;i++) im(Rawx(i),Rawy(i)) += 1;
   mlogxy,0,0;
   disp,im,title="All events";

   command_string = "";
   while( 1 ) {
      read,format="%[^\n]",prompt="What now? ... ", command_string;
      command_string = strtrim(command_string);
      write,erlog,"##4## command given: "+command_string;
      write,lg,"Command given: "+command_string;
      cans = comparse(command_string);
      cmd = cans.command;

      if( cmd == "x" ) {
         close, lg;
         close, erlog;
         return;
      }

//
// ************************************** info *********************************************************
//
      if( cmd == "info" ) { // cominfo   -  give information on current settings
         cans = comparse(command_string, "i"); // information level
         niparms = numberof(*cans.iparms);

         write,format="Energy range: %.3f - %.3f keV\n", Ebegin, Eend;

//
// ************************************** pal *********************************************************
//
      } else if( cmd == "pal" ) { // compal   -  set the name of the palette
         cans = comparse(command_string, "s"); // name of palette
         nsparms = numberof(*cans.sparms);
         if( nsparms == 1 ) {
            pal = (*cans.sparms)(1);
            if( strpart( pal, -2:0 ) != ".gp" ) pal += ".gp";
            palette, pal;
         }
//
// ************************************** ebds *********************************************************
//
      } else if( cmd == "ebds" ) { // comebds  -  set energy boundaries
         cans = comparse(command_string, "rr"); // Ebegin and Eend
         nrparms = numberof(*cans.rparms);
         if( nrparms == 0 ) {
            Ebegin = emin_default;
            Eend   = emax_default;
         } else if( nrparms == 1 ) {
            Ebegin = (*cans.rparms)(1);
            Eend   = emax_default;
         } else {
            Ebegin = (*cans.rparms)(1);
            Eend   = (*cans.rparms)(2);
         }
         Esel = where( Energy > Ebegin & Energy < Eend );
         nsel = numberof(Esel);
         write,format="Energy range: %.3f - %.3f keV\n", Ebegin, Eend;
         write,format="       containing %i events\n", nsel;
         dsel = where( E_max > Ebegin & E_min < Eend );
         write,format="       and %i detector energy bins\n", numberof(dsel);

      //   Update image and regions wrt. number of counts

         im = array(int,n_det_pixels,n_det_pixels);
         for(i=1;i<=nsel;i++) im(Rawx(Esel(i)),Rawy(Esel(i))) += 1;
         write,erlog,format="##5## emin emax nsel : %.2f %.2f %i\n", Ebegin, Eend, nsel;

         // update the regions
         nreg = numberof(SRegions);
         if( nreg ) {
            for( i = 1; i <= nreg; i++ ) {
               asel = *SRegions(i).imsegment; // area selection
               SRegions(i).ncts = numberof(whereany(Rawxy(Esel), asel));
               asel = *BRegions(i).imsegment; // area selection
               BRegions(i).ncts = numberof(whereany(Rawxy(Esel), asel));
            }
         }

//
// ************************************** imdisp & lmdisp *********************************************************
//
      } else if( cmd == "imdisp" || cmd == "lmdisp" ) { // comimdisp, comlmdisp   -  display detector image
         cans = comparse(command_string, "r"); // image folding sigma

         rim = double(im);
         if( !is_void(*cans.rparms) ) rim = gfconvol(rim,(*cans.rparms)(1));
         mlogxy,0,0;
         if( cmd == "lmdisp" ) disp,log(1.0+rim);
         else disp,rim;

         // add the regions
         nreg = numberof(SRegions);
         for( i = 1; i <= nreg; i++ ) {
            if( SRegions(i).type == "detailed" ) {
               nout = *SRegions(i).n_outline;
               pout = *SRegions(i).p_outline;
               xout = *SRegions(i).x_outline;
               yout = *SRegions(i).y_outline;
               for( j = 1; j <= numberof(nout); j++ ) {
                  oplot,xout(pout(j):pout(j)-1+nout(j)),yout(pout(j):pout(j)-1+nout(j)),color="green";
               }
            } else {
               reg_params = *SRegions(i).params;
               shape      = SRegions(i).shape;
               if( shape == "c" ) {
                  angles = span(0,2*pi,100);
                  oplot,reg_params(1) + reg_params(3)*cos(angles), \
                        reg_params(2) + reg_params(3)*sin(angles), color="green";
               }
               if( shape == "a" ) {
                  angles = span(0,2*pi,100);
                  oplot,reg_params(1) + reg_params(3)*cos(angles), \
                        reg_params(2) + reg_params(3)*sin(angles), color="green";
                  oplot,reg_params(1) + reg_params(4)*cos(angles), \
                        reg_params(2) + reg_params(4)*sin(angles), color="green";
               }
               if( shape == "b" ) {
                  oplot,[reg_params(1),reg_params(3),reg_params(3),reg_params(1), reg_params(1)], \
                        [reg_params(2),reg_params(2),reg_params(4),reg_params(4), reg_params(2)], \
                        color="green";
               }
            }
            if( BRegions(i).shape != "v" ) {
               if( BRegions(i).type == "detailed" ) {
                  nout = *BRegions(i).n_outline;
                  pout = *BRegions(i).p_outline;
                  xout = *BRegions(i).x_outline;
                  yout = *BRegions(i).y_outline;
                  for( j = 1; j <= numberof(nout); j++ ) {
                     oplot,xout(pout(j):pout(j)-1+nout(j)),yout(pout(j):pout(j)-1+nout(j)),color="red";
                  }
               } else {
                  reg_params = *BRegions(i).params;
                  shape      = BRegions(i).shape;
                  if( shape == "c" ) {
                     angles = span(0,2*pi,100);
                     oplot,reg_params(1) + reg_params(3)*cos(angles), \
                           reg_params(2) + reg_params(3)*sin(angles), color="red";
                  }
                  if( shape == "a" || shape == "d" ) {
                     angles = span(0,2*pi,100);
                     oplot,reg_params(1) + reg_params(3)*cos(angles), \
                           reg_params(2) + reg_params(3)*sin(angles), color="red";
                     oplot,reg_params(1) + reg_params(4)*cos(angles), \
                           reg_params(2) + reg_params(4)*sin(angles), color="red";
                  }
                  if( shape == "b" ) {
                     oplot,[reg_params(1),reg_params(3),reg_params(3),reg_params(1), reg_params(1)], \
                           [reg_params(2),reg_params(2),reg_params(4),reg_params(4), reg_params(2)], \
                           color="red";
                  }
               }
            }
         }
//
// ************************************** imsave *********************************************************
//
      } else if( cmd == "imsave"  ) { // comimsave  -  save detector image to FITS
         cans = comparse(command_string, "s"); // given filename

         if( is_void(*cans.sparms) ) {
            fits_name = get_next_filename("aspec_image_????.fits");
         } else {
            fits_name = (*cans.sparms)(1);
         }
         write,lg,"Writing to: "+fits_name;
         write,"Writing to: "+fits_name;
         kwds_init;
         kwds_set,"DATE",ndate(3),"Date/time of file creation";
         kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
         kwds_set,"E_MIN", Ebegin, "[keV] Lower energy limit";
         kwds_set,"E_MAX", Eend, "[keV] Upper energy limit";
         for( i = 1; i <= numberof(Event_files); i++ ) {
            kwds_set,"EVFILE"+itoa(i),Event_files(i);
         }
         if( Coords.flag) {
            kwds_set,"CTYPE1", Coords.ctype1, "Type of coord.system";
            kwds_set,"CTYPE2", Coords.ctype2, "Type of coord.system";
            kwds_set,"CRPIX1", Coords.crpix1, "Reference pixel position";
            kwds_set,"CRPIX2", Coords.crpix2, "Reference pixel position";
            kwds_set,"CRVAL1", Coords.crval1, "Reference coord value";
            kwds_set,"CRVAL2", Coords.crval2, "Reference coord value";
            kwds_set,"CD1_1", Coords.cd1_1, "Part of transf. matrix";
            kwds_set,"CD1_2", Coords.cd1_2, "Part of transf. matrix";
            kwds_set,"CD2_1", Coords.cd2_1, "Part of transf. matrix";
            kwds_set,"CD2_2", Coords.cd2_2, "Part of transf. matrix";
         }
         kwds_set,"EXTNAME","ASPEC_IMAGE","Name of this extension";
         writefits, fits_name, im;
//
// ************************************** rpos *********************************************************
//
      } else if( cmd == "rpos" ) { // comrpos  -  read position in image
         pos = curmark1( style=0,prompt="Mark the position ... " );
         write,format="Pixel position: %7.3f %7.3f\n", pos(1), pos(2);
         local coord1, coord2;
         skypos_fits, Coords, pos(1), pos(2), coord1, coord2, to_sky=1;
         write,format="Coord position: %7.3 %7.3\n", coord1, coord2;
         write,format="Pixel value : %i counts\n", im(int(pos(1)+0.5),int(pos(2)+0.5));
//
// ************************************** gpix *********************************************************
//
      } else if( cmd == "gpix" ) { // comgpix  -  get pixel numbers from WCS
         cans = comparse(command_string, "rr"); // RA and dec
         nrparms = numberof(*cans.rparms);
         if( nrparms != 2 ) {
            write,"Exactly two values must be entered ...";
         } else {
            local pix1, pix2;
            skypos_fits, Coords, pix1, pix2, (*cans.rparms)(1), (*cans.rparms)(2), to_pix=1;
            write,format="Coord position: %7.3 %7.3\n", (*cans.rparms)(1), (*cans.rparms)(2);
            write,format="Pixel position: %7.3f %7.3f\n", pix1, pix2;
            write,format="Pixel value : %i counts\n", im(int(pix1+0.5),int(pix2+0.5));
         }
//
// ************************************** mreg *********************************************************
//
      } else if( cmd == "mreg" ) { // commreg  -  make region pair
         cans = comparse(command_string, "s");
         if( is_void(*cans.sparms) ) {
            s_shape = "c";  // circular region with annulus is the default
            b_shape = "d";  // Annulus with predefined center
         } else {
            shape = (*cans.sparms)(1);
            if( strlen(shape) != 2 ) {
               write,"Parameter must be two-letter string";
               continue;
            }
            s_shape = strpart(shape,1:1);
            b_shape = strpart(shape,2:2);
            if( s_shape != "c" && s_shape != "b" ) {
               write,"Parameter must have c or b as first letter";
               continue;
            }
            if( b_shape != "a" && b_shape != "b" && b_shape != "v" ) {
               write,"Parameter must have a, b, or v as second letter";
               continue;
            }
         }
         // ******  Prepare the regions arrays
         local xcen, ycen, sreg_params, breg_params;
         if( is_void(SRegions) ) {
            //+ 101119 SRegions = s_Reg();
            //+ 101119 BRegions = s_Reg();
            SRegions = array(s_Reg,1);
            BRegions = array(s_Reg,1);
         } else {
            grow, SRegions, s_Reg();
            grow, BRegions, s_Reg();
         }
         nreg = numberof(SRegions);
         // ******  Define the source region
         write,"Define the source region:";
         sel = int(curreg(im,s_shape, xcen, ycen, sreg_params, color="green",thick=2));
         if( region_type != "simple" ) {
            ocean = array(short,n_det_pixels,n_det_pixels);
            ocean(sel) = 1;
            isle = island(ocean);
            c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
            n_outline = int(n_outline);
            p_outline = int(p_outline);
            SRegions(nreg).n_outline = &n_outline;
            SRegions(nreg).p_outline = &p_outline;
            SRegions(nreg).x_outline = &x_outline;
            SRegions(nreg).y_outline = &y_outline;
         }
         SRegions(nreg).type = region_type;
         SRegions(nreg).params = &sreg_params;
         SRegions(nreg).shape = s_shape;
         SRegions(nreg).xcen = xcen;
         SRegions(nreg).ycen = ycen;
         SRegions(nreg).area = numberof(sel);
         SRegions(nreg).imsegment = &sel;
         SRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
         // ******  Define the background region
         if( b_shape == "v" ) { // void i.e. no background but dummy to be defined
            BRegions(nreg).shape = b_shape;
            BRegions(nreg).xcen = xcen;
            BRegions(nreg).ycen = ycen;
            BRegions(nreg).area = 1; // to avoid division by zero
            //+ BRegions(nreg).imsegment = &sel;
            BRegions(nreg).imsegment = &void_value;
            BRegions(nreg).ncts = 0;
            BRegions(nreg).type = region_type;
         } else { // 'a', 'd', or 'b' (annulus or box)
            write,"Define the background region:";
            sel = int(curreg(im, b_shape, xcen, ycen, breg_params, color="red",thick=2));
            if( region_type != "simple" ) {
               ocean = array(short,n_det_pixels,n_det_pixels);
               ocean(sel) = 1;
               isle = island(ocean);
               c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
               n_outline = int(n_outline);
               p_outline = int(p_outline);
               BRegions(nreg).n_outline = &n_outline;
               BRegions(nreg).p_outline = &p_outline;
               BRegions(nreg).x_outline = &x_outline;
               BRegions(nreg).y_outline = &y_outline;
            }
            BRegions(nreg).type = region_type;
            BRegions(nreg).shape = b_shape;
            BRegions(nreg).params = &breg_params;
            BRegions(nreg).xcen = xcen;
            BRegions(nreg).ycen = ycen;
            BRegions(nreg).area = numberof(sel);
            BRegions(nreg).imsegment = &sel;
            BRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
         }

//
// ************************************** dreg *********************************************************
//
      } else if( cmd == "dreg" ) { // comdreg  -  delete region(s)
         cans = comparse(command_string, "i");
         nreg = numberof(SRegions);
         if( nreg == 0 ) {
            write,"No regions have been defined ...";
         } else {
            if( !is_void(*cans.iparms) ) {
               // delete a single region
               i = (*cans.iparms)(1);
               if( i < 1 || i > nreg ) {
                  write,"Requested region is not found ...";
                  continue;
               }
               if( nreg == 1 ) {
                  SRegions = BRegions = [];
               } else {
                  SRegions = rem_elem( SRegions, i );
                  BRegions = rem_elem( BRegions, i );
               }
            } else {
               SRegions = BRegions = [];
            }
         }
//
// ************************************** ireg *********************************************************
//
      } else if( cmd == "ireg" ) { // comireg  -  show region information
         cans = comparse(command_string, "i");
         nreg = numberof(SRegions);
         if( nreg == 0 ) {
            write,"No regions have been defined ...";
         } else {
            i1 = 1; i2 = nreg; // default, show all regions
            if( !is_void(*cans.iparms) ) {
               i1 = i2 = (*cans.iparms)(1);
               if( i1 < 1 || i1 > nreg ) {
                  write,"Requested region is not found ...";
                  i1 = 1; i2 = nreg;
               }
            }
            write,"      #    xcen   ycen     area  shape      ncts";
            for( i = i1; i <= i2; i++ ) {
               write,format="Src: %3i  %6.2f %6.2f %8i    %s %11i\n", \
                  i, SRegions(i).xcen, SRegions(i).ycen, SRegions(i).area, \
                         SRegions(i).shape, SRegions(i).ncts;
               write,format="Bkg: %3i  %6.2f %6.2f %8i    %s %11i\n", \
                  i, BRegions(i).xcen, BRegions(i).ycen, BRegions(i).area, \
                         BRegions(i).shape, BRegions(i).ncts;
               n = SRegions(i).ncts;
               k = BRegions(i).area > 0 ? double(SRegions(i).area)/BRegions(i).area : 1.0;
               b = BRegions(i).ncts;
               dn = sqrt(n + b*(k^2));
               write,format=" Net counts: %.2f +- %.2f\n", n - b*k, dn;
            }
         }
//
// ************************************** sreg *********************************************************
//
      } else if( cmd == "sreg" ) { // comsreg  -  save region information
         nreg = numberof(SRegions);
         cans = comparse(command_string, "i"); // If number > 0 then save that one
                                               // If number == 0 then save all
                                               // If number is not given then save most recent
                                               // In any case a new file will be created
         if( is_void(*cans.iparms) ) {
            n = nreg;
         } else {
            n = (*cans.iparms)(1);
         }
    /*
     *   A region is described by a single row in a FITS files
     */
         local serstr;
         sregfile = get_next_filename("sreg_????.fits", serstr);
         bregfile = "breg_"+serstr+".fits";
         write,"      saving into "+sregfile+" and "+bregfile;
         write,lg,"      saving into "+sregfile+" and "+bregfile;
         if( n == 0 ) { // save all
           // --     source regions
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_SREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of source regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,sregfile,"TYPE",SRegions.type, \
                                "SHAPE",SRegions.shape, \
                                "XCEN",SRegions.xcen, \
                                "YCEN",SRegions.ycen, \
                                "AREA",SRegions.area, \
                                "NCTS",SRegions.ncts, \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            for( i = 1; i <= nreg; i++ ) {
               if( !is_void(*SRegions(i).imsegment) ) {
                  fits_bintable_poke,sregfile+"+1",i,"IMSEGMENT",*SRegions(i).imsegment;
                  if( SRegions(i).type == "detailed" ) {
                     fits_bintable_poke,sregfile+"+1",i,"N_OUTLINE",*SRegions(i).n_outline;
                     fits_bintable_poke,sregfile+"+1",i,"P_OUTLINE",*SRegions(i).p_outline;
                     fits_bintable_poke,sregfile+"+1",i,"X_OUTLINE",*SRegions(i).x_outline;
                     fits_bintable_poke,sregfile+"+1",i,"Y_OUTLINE",*SRegions(i).y_outline;
                  }
                  fits_bintable_poke,sregfile+"+1",i,"PARAMS",*SRegions(i).params;
               }
            }
           // --     background regions
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_BREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of background regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,bregfile,"TYPE",BRegions.type, \
                                "SHAPE",BRegions.shape, \
                                "XCEN",BRegions.xcen, \
                                "YCEN",BRegions.ycen, \
                                "AREA",BRegions.area, \
                                "NCTS",BRegions.ncts, \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            for( i = 1; i <= nreg; i++ ) {
               if( !is_void(*BRegions(i).imsegment) ) {
                  fits_bintable_poke,bregfile+"+1",i,"IMSEGMENT",*BRegions(i).imsegment;
                  if( SRegions(i).type == "detailed" ) {
                     fits_bintable_poke,bregfile+"+1",i,"N_OUTLINE",*BRegions(i).n_outline;
                     fits_bintable_poke,bregfile+"+1",i,"P_OUTLINE",*BRegions(i).p_outline;
                     fits_bintable_poke,bregfile+"+1",i,"X_OUTLINE",*BRegions(i).x_outline;
                     fits_bintable_poke,bregfile+"+1",i,"Y_OUTLINE",*BRegions(i).y_outline;
                  }
                  fits_bintable_poke,sregfile+"+1",i,"PARAMS",*BRegions(i).params;
               }
            }
         } else { // save the specified one
           //  --  the source region
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_SREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a singls source region";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,sregfile,"TYPE",[SRegions(n).type], \
                                "SHAPE",[SRegions(n).shape], \
                                "XCEN",[SRegions(n).xcen], \
                                "YCEN",[SRegions(n).ycen], \
                                "AREA",[SRegions(n).area], \
                                "NCTS",[SRegions(n).ncts], \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            if( !is_void(*SRegions(n).imsegment) ) {
               fits_bintable_poke,sregfile+"+1",1,"IMSEGMENT",*SRegions(n).imsegment;
               if( SRegions(n).type == "detailed" ) {
                  fits_bintable_poke,sregfile+"+1",1,"N_OUTLINE",*SRegions(n).n_outline;
                  fits_bintable_poke,sregfile+"+1",1,"P_OUTLINE",*SRegions(n).p_outline;
                  fits_bintable_poke,sregfile+"+1",1,"X_OUTLINE",*SRegions(n).x_outline;
                  fits_bintable_poke,sregfile+"+1",1,"Y_OUTLINE",*SRegions(n).y_outline;
               }
               fits_bintable_poke,sregfile+"+1",n,"PARAMS",*SRegions(n).params;
            }
           // --  the background region
            kwds_init;
            kwds_set,"EXTNAME","ASPEC_BREGFILE","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";
            kwds_set,"EMIN", Ebegin,"[keV] Lower energy limit";
            kwds_set,"EMAX", Eend,"[keV] Upper energy limit";
            kwds_set,"COMMENT","This is a number of source regions";
            kwds_set,"COMMENT","from a running of 'aspec' version "+Version;
            wrmfitscols,bregfile,"TYPE",[BRegions(n).type], \
                                "SHAPE",[BRegions(n).shape], \
                                "XCEN",[BRegions(n).xcen], \
                                "YCEN",[BRegions(n).ycen], \
                                "AREA",[BRegions(n).area], \
                                "NCTS",[BRegions(n).ncts], \
                                "IMSEGMENT",int(0), \
                                "N_OUTLINE",int(0), \
                                "P_OUTLINE",int(0), \
                                "X_OUTLINE",double(0), \
                                "Y_OUTLINE",double(0), \
                                "PARAMS",double(0), \
                                var=[7,8,9,10,11,12];
            if( !is_void(*BRegions(n).imsegment) ) {
               fits_bintable_poke,bregfile+"+1",1,"IMSEGMENT",*BRegions(n).imsegment;
               if( SRegions(n).type == "detailed" ) {
                  fits_bintable_poke,bregfile+"+1",1,"N_OUTLINE",*BRegions(n).n_outline;
                  fits_bintable_poke,bregfile+"+1",1,"P_OUTLINE",*BRegions(n).p_outline;
                  fits_bintable_poke,bregfile+"+1",1,"X_OUTLINE",*BRegions(n).x_outline;
                  fits_bintable_poke,bregfile+"+1",1,"Y_OUTLINE",*BRegions(n).y_outline;
               }
               fits_bintable_poke,bregfile+"+1",n,"PARAMS",*BRegions(n).params;
            }
         }
//
// ************************************** lreg *********************************************************
//
      } else if( cmd == "lreg" ) { // comlreg  -  load region information
         nreg = numberof(SRegions);
         //   Command:   lreg NNNN [num]
         //              lreg file=regionfilename

         cans = comparse(command_string, "si"); // If number > 0 is given then load that one
                                                // If number == 0 then load all in file
                                                // If number is not given then load first
                                                // region in the file
        /*
         *   Check the command and the existence of region files
         */

         if( is_void(*cans.sparms) ) {
            error,"Illegal command for lreg";
         } else {
            // see if a keyword has been given:
            kc = keyparse( (*cans.sparms)(1) );
            if( is_void( kc ) ) {
               from_ds9reg = 0;
               serstr = (*cans.sparms)(1);
               lserstr = strlen(serstr);
               if( lserstr != 4 ) error,"Illegal length of str for lreg";
               sregfile = "sreg_"+serstr+".fits";
               if( !file_test(sregfile) ) error,sregfile+" is not found";
               bregfile = "breg_"+serstr+".fits";
               if( !file_test(bregfile) ) error,bregfile+" is not found";
            } else {
               if( kc.keyword != "file" ) error,"Wrong keyword";
               if( !file_test(kc.keyvalue) ) error,"Did not find: "+kc.keyvalue;
               from_ds9reg = 1;
            }
         }

         if( from_ds9reg ) {

            sel = ds9reg(kc.keyvalue,im,Coords,s_shape, xcen, ycen, sreg_params, color="green",thick=2);
            n_sel = numberof(sel);

            while( n_sel > 1 ) {

               grow, SRegions, array(s_Reg,1);
               grow, BRegions, array(s_Reg,1);
               nreg = numberof(SRegions);

               // ******  Define the source region
               if( region_type != "simple" ) {
                  ocean = array(short,n_det_pixels,n_det_pixels);
                  ocean(sel) = 1;
                  isle = island(ocean);
                  c_outline, isle, ocean, x_outline, y_outline, n_outline, p_outline;
                  n_outline = int(n_outline);
                  p_outline = int(p_outline);
                  SRegions(nreg).n_outline = &n_outline;
                  SRegions(nreg).p_outline = &p_outline;
                  SRegions(nreg).x_outline = &x_outline;
                  SRegions(nreg).y_outline = &y_outline;
               }
               SRegions(nreg).type = region_type;
               SRegions(nreg).params = &sreg_params;
               SRegions(nreg).shape = s_shape;
               SRegions(nreg).xcen = xcen;
               SRegions(nreg).ycen = ycen;
               SRegions(nreg).area = numberof(sel);
               SRegions(nreg).imsegment = &sel;
               SRegions(nreg).ncts = numberof(whereany(Rawxy(Esel), sel));
               // ******  Define a dummy background region
               BRegions(nreg).shape = "v";
               BRegions(nreg).xcen = xcen;
               BRegions(nreg).ycen = ycen;
               BRegions(nreg).area = 1; // to avoid division by zero
               //+ BRegions(nreg).imsegment = &sel;
               BRegions(nreg).imsegment = &void_value;
               BRegions(nreg).ncts = 0;
               BRegions(nreg).type = region_type;

               sel = ds9reg( ,im,Coords,s_shape, xcen, ycen, sreg_params, color="green",thick=2);
               n_sel = numberof(sel);

            }

         } else {

            if( is_void(*cans.iparms) ) {
               n = 1; // 'n' is the row number
            } else {
               n = (*cans.iparms)(1);
            }
   
            shdr = headfits(sregfile+"+1");
            bhdr = headfits(bregfile+"+1");
            nrows = fxpar( shdr, "naxis2" );
            if( nrows != fxpar( bhdr, "naxis2" ) ) error,"Different number of rows";
   
            if( n > nrows ) error,"Region number exceeds number of rows";
   
            // make room for the regions to be loaded
   
            if( n ) {
               grow, SRegions, array(s_Reg,1);
               grow, BRegions, array(s_Reg,1);
            } else {
               grow, SRegions, array(s_Reg,nrows);
               grow, BRegions, array(s_Reg,nrows);
            }
   
       /*
        *   A region is described by a single row in a FITS files
        */
            if( n == 0 ) { // load all
              // --     source regions
               type  = rdfitscol(sregfile+"+1","TYPE");
               shape = rdfitscol(sregfile+"+1","SHAPE");
               xcen = rdfitscol(sregfile+"+1","XCEN");
               ycen = rdfitscol(sregfile+"+1","YCEN");
               area = rdfitscol(sregfile+"+1","AREA");
               ncts = rdfitscol(sregfile+"+1","NCTS");
               SRegions(nreg+1:nreg+nrows).type  = type;
               SRegions(nreg+1:nreg+nrows).shape = shape;
               SRegions(nreg+1:nreg+nrows).xcen = xcen;
               SRegions(nreg+1:nreg+nrows).ycen = ycen;
               SRegions(nreg+1:nreg+nrows).area = area;
               SRegions(nreg+1:nreg+nrows).ncts = ncts;
               for( i = 1; i <= nrows; i++ ) {
                  d1 = fits_bintable_peek(sregfile+"+1",i,"IMSEGMENT");
                  SRegions(nreg+i).imsegment = &d1;
                  // update number of counts
                  if( !is_void(d1) ) SRegions(nreg+i).ncts = numberof(whereany(Rawxy, d1));
                  d1 = fits_bintable_peek(sregfile+"+1",i,"N_OUTLINE");
                  SRegions(nreg+i).n_outline = &d1;
                  d1 = fits_bintable_peek(sregfile+"+1",i,"P_OUTLINE");
                  SRegions(nreg+i).p_outline = &d1;
                  d1 = fits_bintable_peek(sregfile+"+1",i,"X_OUTLINE");
                  SRegions(nreg+i).x_outline = &d1;
                  d1 = fits_bintable_peek(sregfile+"+1",i,"Y_OUTLINE");
                  SRegions(nreg+i).y_outline = &d1;
                  d1 = fits_bintable_peek(sregfile+"+1",i,"PARAMS");
                  SRegions(nreg+i).params = &d1;
               }
              // --     background regions
               type  = rdfitscol(bregfile+"+1","TYPE");
               shape = rdfitscol(bregfile+"+1","SHAPE");
               xcen = rdfitscol(bregfile+"+1","XCEN");
               ycen = rdfitscol(bregfile+"+1","YCEN");
               area = rdfitscol(bregfile+"+1","AREA");
               ncts = rdfitscol(bregfile+"+1","NCTS");
               BRegions(nreg+1:nreg+nrows).type = type;
               BRegions(nreg+1:nreg+nrows).shape = shape;
               BRegions(nreg+1:nreg+nrows).xcen = xcen;
               BRegions(nreg+1:nreg+nrows).ycen = ycen;
               BRegions(nreg+1:nreg+nrows).area = area;
               BRegions(nreg+1:nreg+nrows).ncts = ncts;
               for( i = 1; i <= nrows; i++ ) {
                  d1 = fits_bintable_peek(bregfile+"+1",i,"IMSEGMENT");
                  BRegions(nreg+i).imsegment = &d1;
                  // update number of counts
                  if( !is_void(d1) ) BRegions(nreg+i).ncts = numberof(whereany(Rawxy, d1));
                  d1 = fits_bintable_peek(bregfile+"+1",i,"N_OUTLINE");
                  BRegions(nreg+i).n_outline = &d1;
                  d1 = fits_bintable_peek(bregfile+"+1",i,"P_OUTLINE");
                  BRegions(nreg+i).p_outline = &d1;
                  d1 = fits_bintable_peek(bregfile+"+1",i,"X_OUTLINE");
                  BRegions(nreg+i).x_outline = &d1;
                  d1 = fits_bintable_peek(bregfile+"+1",i,"Y_OUTLINE");
                  BRegions(nreg+i).y_outline = &d1;
                  d1 = fits_bintable_peek(bregfile+"+1",i,"PARAMS");
                  BRegions(nreg+i).params = &d1;
               }
            } else { // load the specified one(s)
              //  --  the source region
               type  = rdfitscol(sregfile+"+1","TYPE");
               shape = rdfitscol(sregfile+"+1","SHAPE");
               xcen = rdfitscol(sregfile+"+1","XCEN");
               ycen = rdfitscol(sregfile+"+1","YCEN");
               area = rdfitscol(sregfile+"+1","AREA");
               ncts = rdfitscol(sregfile+"+1","NCTS");
               SRegions(nreg+1).type  = type(n);
               SRegions(nreg+1).shape = shape(n);
               SRegions(nreg+1).xcen = xcen(n);
               SRegions(nreg+1).ycen = ycen(n);
               SRegions(nreg+1).area = area(n);
               SRegions(nreg+1).ncts = ncts(n);
   
               d1 = fits_bintable_peek(sregfile+"+1",n,"IMSEGMENT");
               SRegions(nreg+1).imsegment = &d1;
               // update number of counts
               if( !is_void(d1) ) SRegions(nreg+1).ncts = numberof(whereany(Rawxy, d1));
               d1 = fits_bintable_peek(sregfile+"+1",n,"N_OUTLINE");
               SRegions(nreg+1).n_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",n,"P_OUTLINE");
               SRegions(nreg+1).p_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",n,"X_OUTLINE");
               SRegions(nreg+1).x_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",n,"Y_OUTLINE");
               SRegions(nreg+1).y_outline = &d1;
               d1 = fits_bintable_peek(sregfile+"+1",n,"PARAMS");
               SRegions(nreg+1).params = &d1;
   
              // --  the background region
               type  = rdfitscol(bregfile+"+1","TYPE");
               shape = rdfitscol(bregfile+"+1","SHAPE");
               xcen = rdfitscol(bregfile+"+1","XCEN");
               ycen = rdfitscol(bregfile+"+1","YCEN");
               area = rdfitscol(bregfile+"+1","AREA");
               ncts = rdfitscol(bregfile+"+1","NCTS");
               BRegions(nreg+1).type = type(n);
               BRegions(nreg+1).shape = shape(n);
               BRegions(nreg+1).xcen = xcen(n);
               BRegions(nreg+1).ycen = ycen(n);
               BRegions(nreg+1).area = area(n);
               BRegions(nreg+1).ncts = ncts(n);
   
               d1 = fits_bintable_peek(bregfile+"+1",n,"IMSEGMENT");
               BRegions(nreg+1).imsegment = &d1;
               // update number of counts
               if( !is_void(d1) ) BRegions(nreg+1).ncts = numberof(whereany(Rawxy, d1));
               d1 = fits_bintable_peek(bregfile+"+1",n,"N_OUTLINE");
               BRegions(nreg+1).n_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",n,"P_OUTLINE");
               BRegions(nreg+1).p_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",n,"X_OUTLINE");
               BRegions(nreg+1).x_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",n,"Y_OUTLINE");
               BRegions(nreg+1).y_outline = &d1;
               d1 = fits_bintable_peek(bregfile+"+1",n,"PARAMS");
               BRegions(nreg+1).params = &d1;
            }
         }
//
// ************************************** ps *********************************************************
//
      } else if( cmd == "ps" ) { // comps - dump plot to ps file
         cans = comparse(command_string, "s");
         plotsign;
         plotname,"Spectrum by aspec";
         zps,outfile=(*cans.sparms)(1),noc=1;
//
// ************************************** ss *********************************************************
//
      } else if( cmd == "ss" ) { // comss - save spectrum and background
         // accept up to four parameters (keyvalues)
         //    1) single number - the region number e.g. 'ss 3'
         //    2) by keyword e.g. 'ss reg=3'
         //    3) by keyword only e.g. 'ss ignbkg=1 reg=3' (remember no spaces)
         bb = comparse(command_string,"ssss");
         nbb = numberof(*bb.sparms);
         ireg = 0;
         ignbkg = 0; // ignore background
         if( nbb ) {
            for( i = 1; i <= nbb; i++ ) {
               // get the 'keyword=value' if this format is entered
               //  else [] is returned
               kbb = keyparse((*bb.sparms)(i));
               if( is_void(kbb) ) { // simple value interpreted as the region number
                  cans = comparse(command_string, "i");
                  ireg = (*cans.iparms)(i);
                  write,"Setting ireg ("+itoa(ireg)+") from simple value ...";
               } else {
                  if( kbb.keyword == "ignbkg" ) {
                     ignbkg = kbb.keyvalue;
                     write,"Setting ignbkg ("+itoa(ignbkg)+") from keyword ...";
                  }
                  if( kbb.keyword == "reg" ) {
                     ireg = kbb.keyvalue;
                     write,"Setting ireg ("+itoa(ireg)+") from keyword ...";
                  }
               }
            }
         }
         nreg = numberof(SRegions);
         if( ireg == 0 ) ireg = nreg;
         write,lg,"Extracting spectrum for region # ",+itoa(ireg);

         //  Extract the spectrum

         s_sel = whereany(Rawxy, *SRegions(ireg).imsegment);
         b_sel = BRegions(ireg).shape == "v" ? [] : whereany(Rawxy, *BRegions(ireg).imsegment);
         if( ignbkg ) b_sel = [];

         //     Rate_src (Rate_err_src) is for total counts in source region
         //     Rate_bkg (Rate_err_bkg) is for renormalized counts in background region
         //     Rate_net (Rate_err_net) is for background subtracted counts

         specbinning, Energy(s_sel), E_min, E_max, Rate_src, Rate_err_src, exposure=Exposure;
         if( is_void(b_sel) ) {
            // if background is not considered make null spectrum
            Rate_bkg = Rate_err_bkg = Rate_src*0;
         } else {
            specbinning, Energy(b_sel), E_min, E_max, Rate_bkg, Rate_err_bkg, exposure=Exposure;
         }

         //  Renormalize background to adapt to source region size

         corf = float(SRegions(ireg).area)/BRegions(ireg).area;
         Rate_bkg *= corf;    // normalize to source area
         Rate_err_bkg *= corf;

         //  Get the net spectrum

         Rate_net = Rate_src - Rate_bkg;
         Rate_err_net = sqrt(Rate_err_src^2 + Rate_err_bkg^2);

         //  Renormalize the spectrum to pixel or unit area if requested

         if( Spec_norm_rule == 2 ) { // per pixel
            Spec_norm_factor = 1.0/SRegions(ireg).area;
         } else if( Spec_norm_rule == 3 ) { // per cm2
            Spec_norm_factor = 1.0/(SRegions(ireg).area*pixel_area_cm2);
         } else Spec_norm_factor = 1.0;

         Rate_src *= Spec_norm_factor;
         Rate_err_src *= Spec_norm_factor;
         Rate_bkg *= Spec_norm_factor;
         Rate_err_bkg *= Spec_norm_factor;
         Rate_net *= Spec_norm_factor;
         Rate_err_net *= Spec_norm_factor;

         // select the ARF based on distance to center
         dist = sqrt((SRegions(ireg).xcen - xdetcen)^2 + (SRegions(ireg).ycen - ydetcen)^2);
         //  now in pixels, convert to arcmin
         dist *= (pixel_size*180.*60.)/(10140.*pi);
         // given that the focal length is 10140 mm
         d = span(0.,9.,10);
         w = where( d > dist ); // now w(1) is the index on one side
                 // and w(1)-1 is the index on the other side
         if( !numberof(w) ) {
            write,"The region center is too far away";
         } else {
            i = w(1) - 1;
            arf = float(Arfs(,i) + ((dist - d(i))/(d(i+1)-d(i)))*(Arfs(,i+1)-Arfs(,i)));
            arffile = fullpath(get_next_filename("arf_????.fits"));
            arf2phaii, arffile, arf, Energ_lo, Energ_hi, extname="SPECRESP",\
                instrume=instrume,telescop=telescop;
            write,"ARF file made : "+arffile;

            // Allways make three spectral files: net, total, and bkg
            local ser_str;
            spec_net_file = get_next_filename("spec_net_????.fits",ser_str);
            spec_bkg_file  = "spec_bkg_"+ser_str+".fits";
            spec_tot_file  = "spec_tot_"+ser_str+".fits";

            kwds_init;
            kwds_set,"NUMSRCPX", SRegions(ireg).area,"Number of source pixels";
            kwds_set,"NUMBKGPX", BRegions(ireg).area,"Number of background pixels";
            kwds_set,"REGXCEN", SRegions(ireg).xcen,"X pixel for region center";
            kwds_set,"REGYCEN", SRegions(ireg).ycen,"Y pixel for region center";
            kwds_set,"SRGSHAPE", SRegions(ireg).shape,"Shape of source region";
            kwds_set,"BRGSHAPE", BRegions(ireg).shape,"Shape of background region";
            kwds_set,"NORMFACT", Spec_norm_factor,"Spectral renormalization factor";
            kwds_set,"NORMTEXT", Spec_norm_text,"Explanation";
            kwds_set,"ORIGIN","aspec-"+Version,"Software that produced it";

            // Write net spectrum

            spec2phaii,spec_net_file,Rate_net,Rate_err_net,type="net",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,backfile=spec_bkg_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Net spectrum has been written to : "+spec_net_file;
            write,lg,"Net spectrum has been written to : "+spec_net_file;

            // Write bkg spectrum

            spec2phaii,spec_bkg_file,Rate_bkg,Rate_err_bkg,type="bkg",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Background spectrum has been written to : "+spec_bkg_file;
            write,lg,"Background spectrum has been written to : "+spec_bkg_file;

            // Write total spectrum

            spec2phaii,spec_tot_file,Rate_src,Rate_err_src,type="total",ra_obj=[float(1.)*ireg],\
               dec_obj=[float(1.)*ireg],exposure=[Exposure],name=["source"+itoa(ireg)],ancrfile=[arffile],\
               respfile=Rmf_file,backfile=spec_bkg_file,telescop=telescop,instrume=instrume,no_kwds_init=1;
            write,"Total spectrum has been written to : "+spec_tot_file;
            write,lg,"Total spectrum has been written to : "+spec_tot_file;
         }
//
// ************************************** normspec *********************************************************
//
      } else if( cmd == "normspec" ) { // comnormspec - normalize spectrum
         cans = comparse(command_string,"s");
         if( !is_void(*cans.sparms) ) {
            if( (*cans.sparms)(1) == "1" ) {
               Spec_norm_rule = 1;
               Spec_norm_text = "Normalized to source region area";
            } else if( (*cans.sparms)(1) == "pixel" ) {
               Spec_norm_rule = 2;
               Spec_norm_text = "Normalized to a single pixel";
            } else if( (*cans.sparms)(1) == "cm2" ) {
               Spec_norm_rule = 3;
               Spec_norm_text = "Normalized to a cm2 on the detector";
            }
            write,"Next spectrum will be "+Spec_norm_text;
         }
//
// ************************************** pspec *********************************************************
//
      } else if( cmd == "pspec" ) { // compspec  - plot most recent spectrum
         cans = comparse(command_string,"r");
         frac = is_void(*cans.rparms) ? 0.2 : (*cans.rparms)(1);
         //+ 101123 plot_spectrum,E_min,E_max,Rate_src,Rate_err_src,itype=3;
         local ob1, ob2, orate, orate_err;
         REBIN = specrebinninga( E_min, E_max, Rate_src, Rate_err_src, frac, ob1, ob2, orate, orate_err);
         plot_spectrum, ob1, ob2, orate, orate_err, itype=3;
         if(!is_void(b_sel)) {
            //+ specrebinninga, E_min, E_max, Rate_bkg, Rate_err_bkg, frac, ob1, ob2, orate, orate_err;
            specrebinning, E_min, E_max, Rate_bkg, Rate_err_bkg, REBIN, ob1, ob2, orate, orate_err;
            oplot_spectrum, ob1, ob2, orate, orate_err,color="red";
         }
         //+ specrebinninga, E_min, E_max, Rate_net, Rate_err_net, frac, ob1, ob2, orate, orate_err;
         specrebinning, E_min, E_max, Rate_net, Rate_err_net, REBIN, ob1, ob2, orate, orate_err;
         oplot_spectrum, ob1, ob2, orate, orate_err,color="green";
//
// ************************************** ? *********************************************************
//
      } else if( cmd == "?" ) { // com?
         cans = comparse(command_string,"s");
         if( is_void(*cans.sparms) ) { // show overview
            write,"info        show current settings,";
            write,"ebds        set energy boundaries,";
            write,"imdisp      display detector image between current energy limits,";
            write,"lmdisp      display detector logarithmic image between current energy limits,";
            write,"pal         define the name of the palette to use for images,";
            write,"ps          dump current image to .ps file,";
            write,"imsave      write image between current energy limits to FITS file,";
            write,"evtsave     write events in region to an event file (not implemented),";
            write,"mreg        make a region pair,";
            write,"dreg        delete a region pair,";
            write,"sreg        save region pair(s),";
            write,"lreg        load region pair(s),";
            write,"ireg        show info on loaded/created regions,";
            write,"normspec    setup a normalization of spectra,";
            write,"ss          create and save spectrum,";
            write,"pspec       plot most recent spectrum,";
            write,"rpos        read position in image in pixels and in WCS,";
            write,"gpix        get pixel numbers from WCS coordinates,";
            write,"x           exit aspec,";
            write,"?           help - this overview,";
            write,"? <command> help on specified command.";
         } else {
            if( (*cans.sparms)(1) == "imdisp" || (*cans.sparms)(1) == "lmdisp" ) {
               write,"imdisp [sigma] - display image for current setting of emin and emax";
               write,"lmdisp [sigma] - display logarithmic image for current setting of emin and emax";
               write,"                A Gauss kernel smoothing is applied if sigma is given.";
            } else if( (*cans.sparms)(1) == "info" ) {
               write,"info      - show information on current settings";
            } else if( (*cans.sparms)(1) == "pal" ) {
               write,"pal name  - Define name of palette (the .gp postfix may be left out)";
            } else if( (*cans.sparms)(1) == "ebds" ) {
               write,"ebds [emin [emax]] - set the energy boundaries for";
               write,"                image display and number counts in regions.";
            } else if( (*cans.sparms)(1) == "imsave" ) {
               write,"imsave [filename] - save image for current setting of emin and emax to FITS file";
               write,"                The file name will be automatically assigned unless given.";
            } else if( (*cans.sparms)(1) == "mreg" ) {
               write,"mreg [shape] - define a region pair, src + bkg, by help of the cursor";
               write,"          shape (if given, default is 'ca') must be a two letter string.";
               write,"                The first letter refers to the source region and it can";
               write,"                one of \"c\" (circle) and \"b\" (box).";
               write,"                The second letter refers to the background region and can";
               write,"                be one of \"a\" (annulus with same center as the source),";
               write,"                \"b\" (box), and \"v\" (void, no background will be subtracted).";
            } else if( (*cans.sparms)(1) == "ireg" ) {
               write,"ireg [number] - show region properties for all regions";
               write,"               unless the requested one is given.";
            } else if( (*cans.sparms)(1) == "dreg" ) {
               write,"dreg [number] - delete all regons";
               write,"               unless the requested one is given.";
            } else if( (*cans.sparms)(1) == "sreg" ) {
               write,"sreg [number] - save a region pair, src + bkg, into files";
               write,"               sreg_nnnn.fits and breg_nnnn.fits, where 'nnnn'"
               write,"               is a serial number. 'number' is the number";
               write,"               in the current region list. If omitted then the most recent";
               write,"               region will be saved. If set to zero the all regions will be saved.";
            } else if( (*cans.sparms)(1) == "lreg" ) {
               write,"lreg nnnn [number] - load a region pair, src + bkg, from files";
               write,"               sreg_nnnn.fits and breg_nnnn.fits, where 'nnnn'"
               write,"               is a serial number. 'number' is the row number";
               write,"               in the table. If omitted the first region will be";
               write,"               loaded, if zero all regions (rows) will be loaded.";
               write,"               The number of counts information will be updated";
               write,"               based on the current event list.";
            } else if( (*cans.sparms)(1) == "normspec" ) {
               write,"normspec word - setup the spectral normalization";
               write,"          1      return to spectrum in source area";
               write,"          cm2    give spectrum per cm2 on the detector";
               write,"          pixel  give spectrum per pixel on the detector";
               write," Must be defined before the spectrum is extracted and saved.";
            } else if( (*cans.sparms)(1) == "ss" ) {
               write,"ss [region]  - create and save spectrum with standard filename";
               write,"    region is its number from the list of regions,";
               write,"    if not given the most recent region will be used.";
               write,"  If spectral normalization is requested then the \"normspec\"";
               write,"  command must be given first.";
            } else if( (*cans.sparms)(1) == "pspec" ) {
               write,"pspec [error_fraction]  - plot the most recent spectrum.";
               write,"         A rebinning is done so that the relative error is";
               write,"         less than 0.2. A different value for this fraction";
               write,"         can be given.";
            } else if( (*cans.sparms)(1) == "rpos" ) {
               write,"rpos  -  a position in an image is marked by the cursor";
               write,"         and the coordinates are printed in pixels and in WCS.";
               write,"         The pixel value is also printed.";
            } else if( (*cans.sparms)(1) == "ps" ) {
               write,"ps [plotfilename] -  produce a PS file from current plot.";
               write,"         A specific name may be given.";
            } else if( (*cans.sparms)(1) == "?" ) {
               write,"? [command] - get more detailed help on command";
            }
         }
      }
   }
}

/* Function comparse */

func comparse( str, types )
/* DOCUMENT res = comparse( command_string, types )

     Returns an instance of the struct: s_Command
        res.command    holds the command itself
        res.rparms     is a pointer to the real parameters
        res.iparms     is a pointer to the integer parameters
        res.sparms     is a pointer to the string parameters

    Example:
       > res = comparse( "mreg circle 22 1.0 2.0","sirr" )
       > res.command
       "mreg"
       > *res.sparms
       ["circle"]
       > *res.iparms
       [22]
       > *res.rparms
       [1,2]
*/
{
   // parameters must be space separated

   command = s_Command();
   str = strtrim(strcompress(str));
   keys = strsplit(str," ");
   nkeys = numberof(keys);
   // initialize
   s_nill = [];
   command.rparms = &s_nill;
   command.iparms = &s_nill;
   command.sparms = &s_nill;

   if( nkeys == 1 ) {
      command.command = keys;
   } else {
      command.command = keys(1);
      if( typeof(types) == "string" ) {
         ntypes = strlen(types);
         if( ntypes < nkeys-1 ) {
            write,"comparse: too many keywords - truncated";
            nkeys = ntypes+1;
            keys = keys(nkeys);
         }
         vreal = vint = vstr = [];
         if( ntypes ) {
            for( i = 1; i < nkeys; i++ ) {
               strp = keys(i+1);
               typ = strpart(types,i:i);
               if( typ=="r" ) {
                  grow,vreal,atof(strp);
               } else if( typ=="i" ) {
                  grow,vint,atoi(strp);
               } else if( typ=="s" ) {
                  grow,vstr,strp;
               } else {
                  error,"Invalid type definition";
               }
            } // for( i = ...
         } // if( ntypes )
         command.rparms = &vreal;
         command.iparms = &vint;
         command.sparms = &vstr;
      }
   }
   return command;
}

/* Function keyparse */

func keyparse( str )
/* DOCUMENT res = keyparse( str )

    Interprets a string of shape 'keyword=value' that contains no spaces.
    If the input string fulfills this requirement a struct (s_Keyword)
    is returned, else nil.

     2012-01-16/NJW
*/
{
   // 'str' must be a string
   if( typeof(str) != "string" ) return [];
   // a '=' sign must be present
   pe = strpos( str, "=" );
   if( pe == 0 ) return [];
   // no spaces can be present
   if( strpos(str," ") ) return [];
   // the '=' cannot be the first nor the last character
   len = strlen(str);
   if( pe == 1 || pe == len) return [];
   res = s_Keyword();
   res.keyword = strpart( str, 1:pe-1 );
   res.keyvalue = strpart( str, pe+1:len );

   return res;
}
%FILE% astrophys.i
extern astrophysdoc;
/* DOCUMENT *************************************

   A compendium of various constants and conversions
   useful in astrophysics

     cgs_c = 2.997924562e10; // cm/s    Velocity of light
     cgs_h = 6.626196e-27; // erg s     Planck's constant
     cgs_k = 1.380622e-16; // erg/degK  Boltzmann's constant
     cgs_me = 9.109558e-28; // g        Electron rest mass
     cgs_amu = 1.66053e-24; // g        Atomic mass unit (~ proton mass)
     cgs_G = 6.6732e-8; // dyn cm2 / g2 Gravitational constant
     cgs_sigma = 5.6696e-5; // erg /(cm2 s degK4) Stefan-Boltzmann's constant
     cgs_AU = 1.49597892e13; // cm      Astronomical unit
     cgs_pc = 3.0856e18;   // cm        Parsec
     cgs_kpc = 3.0856e21;   // cm       Kiloparsec
     cgs_Mpc = 3.0856e24;   // cm       Megaparsec
     cgs_Msun = 1.989e33;   // g        Solar mass
     cgs_Rsun = 6.9598e10;   // cm        Solar radius
     cgs_Lsun = 3.827e33;   // erg/s    Solar luminosity
     cgs_keV = 1.60184e-9;  // erg      One kiloelectronvolt

  Functions:
         Physical constants have elements:
              (string)   type, unit, unit_cgs
              (double)   val, val_cgs
    The 'unit_cgs' is fixed but the pair (unit,val) can
    be changed by function 'chunit'
  Supported types:
      distance
      flux
      luminosity
      temperature

    chunit   : Change unit
    flux2lum : Calculate luminosity from flux and distance
    lum2flux : Calculate flux from luminosity and distance
    mulsc    : Multiply with a scalar
    set_dist : Define a distance
    set_flux : Define a flux
    set_temp : Define a temperature

   2008-12-18/NJW
   2009-02-03/NJW updated with chunit, set_temp
************************************************/
struct s_const {
   string type;
   double val;
   string unit;
   double val_cgs;
   string unit_cgs;
}

cgs_c = 2.997924562e10; // cm/s    Velocity of light
cgs_h = 6.626196e-27; // erg s     Planck's constant
cgs_k = 1.380622e-16; // erg/degK  Boltzmann's constant
cgs_me = 9.109558e-28; // g        Electron rest mass
cgs_amu = 1.66053e-24; // g        Atomic mass unit (~ proton mass)
cgs_G = 6.6732e-8; // dyn cm2 / g2 Gravitational constant
cgs_sigma = 5.6696e-5; // erg /(cm2 s degK4) Stefan-Boltzmann's constant
cgs_AU = 1.49597892e13; // cm      Astronomical unit
cgs_pc = 3.0856e18;   // cm        Parsec
cgs_kpc = 3.0856e21;   // cm       Kiloparsec
cgs_Mpc = 3.0856e24;   // cm       Megaparsec
cgs_Msun = 1.989e33;   // g        Solar mass
cgs_Rsun = 6.9598e10;   // cm        Solar radius
cgs_Lsun = 3.827e33;   // erg/s    Solar luminosity
cgs_keV = 1.60184e-9;  // erg      One kiloelectronvolt
cgs_A = 1.0000e-8;     // cm       One Angstrom

//  -----   defining lists with units -----------

Types = ["distance","flux","luminosity","temperature"];
udistance = ["cm","AU","pc","kpc","Mpc"];
cdistance = [1., 1./cgs_AU,1./cgs_pc, 0.001, 0.001];
uflux = ["erg/cm2s"];
cflux = [1.];
uluminosity = ["erg/s"];
cluminosity = [1.];
utemperature = ["K","MK","keV"];
ctemperature = [1., 1.e-6, cgs_k*1.e6/cgs_keV];

// Note that conversion factors are given so that converting
// from index i to i+1 one multiplies with ctype(i+1)
// and converting from i to i-1 is a division with ctype(i)

utypes = _lst( udistance, uflux, uluminosity, utemperature );
ctypes = _lst( cdistance, cflux, cluminosity, ctemperature );

/* Function set_dist */

func set_dist( void )
/* DOCUMENT dist = set_dist()
     Prompts for keyboard input
*/
{
   res = s_const();
   res.type = "distance";
   res.unit_cgs = "cm";

   x = 0.0;
   read,prompt="Dist value : ... ",format="%f", x;
   res.val = x;
   _set_unit, res;
   if( res.unit == "cm" ) {
      res.val_cgs = res.val;
   } else if( res.unit == "AU" ) {
      res.val_cgs = res.val * cgs_AU;
   } else if( res.unit == "pc" ) {
      res.val_cgs = res.val * cgs_pc;
   } else if( res.unit == "kpc" ) {
      res.val_cgs = res.val * cgs_kpc;
   } else if( res.unit == "Mpc" ) {
      res.val_cgs = res.val * cgs_Mpc;
   } else {
      write,"Illegal unit";
   }

   return res;
}

func set_flux( void )
/* DOCUMENT flux = set_flux()
     Prompts for keyboard input
*/
{
   res = s_const();
   res.type = "flux";
   res.unit_cgs = "erg/cm2s";

   x = 0.0;
   read,prompt="Flux value : ... ",format="%f", x;
   res.val = x;
   _set_unit, res;

   if( res.unit == "erg/cm2s" ) {
      res.val_cgs = res.val;
   } else {
      write,"Illegal unit";
   }

   return res;
}

func set_temp( void )
/* DOCUMENT dist = set_temp()
     Prompts for keyboard input
*/
{
   res = s_const();
   res.type = "temperature";
   res.unit_cgs = "K";

   x = 0.0;
   read,prompt="Temp value : ... ",format="%f", x;
   res.val = x;
   _set_unit, res;
   if( res.unit == "K" ) {
      res.val_cgs = res.val;
   } else if( res.unit == "MK" ) {
      res.val_cgs = res.val * 1.e6;
   } else if( res.unit == "keV" ) {
      res.val_cgs = res.val * cgs_keV / cgs_k;
   } else {
      write,"Illegal unit";
   }

   return res;
}

func mulsc( x, cst )
/* DOCUMENT new_cst = mulsc( x, cst )
     multiplies the physical constant 'cst' with the
     scalar 'x'
*/
{
   // scalar - phys constant multiplication

   res = cst;
   res.val = x * cst.val;
   res.val_cgs = x * cst.val_cgs;

   return res;
}

func flux2lum( flux, dist )
/* DOCUMENT luminosity = flux2lum( flux, dist )
     'flux' and 'dist' are physical constants as
     well as the returned value.
*/
{
   res = s_const();
   f = flux.val_cgs * 4.0 * pi * dist.val_cgs^2;
   res.val = f;
   res.val_cgs = f;
   res.unit = "erg/s";
   res.unit_cgs = "erg/s";
   res.type = "luminosity";

   return res;
}

func lum2flux( lum, dist )
/* DOCUMENT flux = lum2flux( luminosity, dist )
     'luminosity' and 'dist' are physical constants as
     well as the returned value.
*/
{
   res = s_const();
   f = lum.val_cgs / ( 4.0 * pi * dist.val_cgs^2 );
   res.val = f;
   res.val_cgs = f;
   res.unit = "erg/cm2s";
   res.unit_cgs = "erg/cm2s";
   res.type = "flux";

   return res;
}

func _set_unit( quan )
/* DOCUMENT index = _set_unit( quan )
    The unit options must be given in string array 'unit_arr'
    and the user is prompted to select one by number in the
    array or string match (shortest unique match will work).
*/
{
   write,"Options:";
   itype = where(Types == quan.type)(1);
   for(i=1;i<=numberof(_car(utypes,itype));i++) {
      write,format="%i: %s   ", i, _car(utypes,itype)(i);
   }
   write,"";
   ans = "";
   read,prompt="Unit : ... ",format="%s", ans;
   if( is_digit(ans) ) {
      i = atoi(ans);
      quan.unit = _car(utypes,itype)(i);
   } else error,"Illegal number";

}

/* Function chunit */

func chunit( quan )
/* DOCUMENT quan_p = chunit( quan )

   where 'quan' is a physical quantity. The new unit is found
   by a dialogue.
*/
{
   write,format="Quantity : %10.4e %s\n", quan.val, quan.unit;
   write,format="Change unit to one of these:%s\n"," ";
   itype = where(Types == quan.type)(1);
   for(i=1;i<=numberof(_car(utypes,itype));i++) {
      if( _car(utypes,itype)(i) == quan.unit ) iunit = i;
      write,format="%i: %s   ", i, _car(utypes,itype)(i);
   }
   write,"";
   j = 0;
   read,prompt="Select new unit : ... ",format="%i", j;
   if( iunit == j ) {
      write,"No change - quit";
      return;
   }
   x = quan.val;
   fac = 1.;
   if( j < iunit ) {
      for( k = iunit; k > j; k-- ) {
         x /= _car(ctypes,itype)(k);
         fac /= _car(ctypes,itype)(k);
      }
   } else {
      for( k = iunit+1; k <= j; k++ ) {
         x *= _car(ctypes,itype)(k);
         fac *= _car(ctypes,itype)(k);
      }
   }
   write,format="Conversion factor : %10.4e\n", fac;
   quan.val = x;
   quan.unit = _car(utypes,itype)(j);
   write,format="Quantity : %10.4e %s\n", quan.val, quan.unit;

}
%FILE% axisym_psf.i
struct s_PSF {
   pointer r;    // distance in pixels
   pointer rho;  // density at 'r'
   pointer frac; // fraction inside 'r'
   pointer rlog; // distances in log scale
   pointer fraclog; // fraction inside 'rlog'
   pointer rholog; // PSF density at 'rlog'
   double xcen;
   double ycen;
}

func axisym_psf( im, xpix, ypix, rmax=, n_outside= )
/* DOCUMENT stru = axisym_psf( im, [xpix, ypix,] rmax=, n_outside= )

    Returns a struct with members:
        r    (pointer) to an array of radii in pixels
        rho  (pointer) to the array of count density (per pixel)
        frac (pointer) to the array of counts fractions inside radius 'r'

    Arguments: im  is an input image
               xpix is the source position in x (pixels)
               ypix is the source position in y (pixels)
                    xpix and ypix may be omitted in which case their values
                    will be assigned to the pixel with the highest value.
    Keyword  rmax:  The maximum radius to use (the default value is 90%
                    of the maximum distance in the image from the source
                    position).
    Keyword n_outside:  Number of counts outside the image that are to be
                        taken into account.

    Example: > p = axisym_psf( focal_plane_image )
             > r = *p.r
             > f = *p.frac
             > HPD = 2*interp(r,f,0.5); // in pixels

   2010-06-07/NJW
*/
{
   local mval, xp, yp;

   dms = dimsof( im );
   maxim, im, mval, xp, yp;
   if( is_void(xpix) ) {
      xpix = xp;
      ypix = yp;
   } else {
      if( is_void(ypix) ) error,"Both xpix and ypix must be given!";
   }

   if( is_void(n_outside) ) n_outside = 0;

   d = distances( dms(2), dms(3), xpix, ypix );
   if( is_void(rmax) ) rmax = 0.9*max(d);

   rho = double(mval);
   r = 0.0;

   r_i = 1.0;
   frac = 0.0;

   do {
      r_o = r_i + 1.;
      w = where( d > r_i & d <= r_o );
      nw = numberof(w);
      if( nw ) {
         grow,r,0.5*(r_i + r_o);
         grow,rho,double(sum(im(w)))/nw;
         m = where( d < r(0) );
         grow,frac,double(sum(im(m)));
      }
      r_i += 1.;
   } while( r_o < rmax );
   frac(0) += n_outside;
   frac /= frac(0);

   // struct s_PSF has been defined in first lines of this file

   res = s_PSF();
   res.r = &r;
   res.rho = &rho;
   res.frac = &frac;
   res.xcen = xpix;
   res.ycen = ypix;

   return res;

}

func axisym_psf_arr( xvals, yvals, xcen, ycen, rmax=, nelem= )
/* DOCUMENT stru = axisym_psf_arr( xvals, yvals, [xcen, ycen,] rmax=, nelem= )

    Returns a struct with members:
        r       (pointer) to an array of radii
        rho     (pointer) to the array of count density (per pixel)
        frac    (pointer) to the array of counts fractions inside radius 'r'
        rlog    (pointer) to an array of radii in log scale
        rholog  (pointer) to the array of PSF density at 'rlog'
        fraclog (pointer) to the array of count fraction inside radius 'rlog'

    Arguments: xvals  array with x-values
               yvals  array with y values, must have same dimension as 'xvals'
               xcen is the source position in x
               ycen is the source position in y
                    xcen and ycen may be omitted in which case their values
                    will be assigned to the center-of-mass
    Keyword  rmax:  The maximum radius to use (the default value is 90%
                    of the maximum distance from the source position).
             nelem: Number of elements in 'rlog' etc. Default is 200.

    Example: > p = axisym_psf_arr( focal_plane_image )
             > r = *p.r
             > f = *p.frac
             > HPD = 2*interp(r,f,0.5); // in pixels

   2012-06-27/NJW
*/
{
   nx = numberof(xvals);
   if( numberof(yvals) != nx ) error,"xvals and yvals have unequal lengths!";
   if( is_void(nelem) ) nelem = 200;

   // Calculate the CM value but limit to +-3*sigma
   xp = avg(xvals);
   sigx = wrms(xvals);
   w = where( xvals > xp - 3*sigx & xvals < xp + 3*sigx );
   xp = avg(xvals(w));
   yp = avg(yvals);
   sigy = wrms(yvals);
   w = where( yvals > yp - 3*sigy & yvals < yp + 3*sigy );
   yp = avg(yvals(w));

   if( is_void(xcen) ) {
      xcen = xp;
      ycen = yp;
   } else {
      if( is_void(ycen) ) error,"Both xcen and ycen must be given!";
   }

   r = sqrt((xvals - xp)^2 + (yvals - yp)^2);

   if( !is_void(rmax) ) {
      w = where(r < rmax);
      if( numberof(w) ) {
         r = r(w);
         nx = numberof(w);
      }
   }
   r = r(sort(r));
   frac = double(indgen(nx))/nx;
   rho = array(double,nx);
   rho(1) = 1./(pi*r(1)^2);
   rho(2:0) = 1./(2*pi*r(zcen)*r(dif));

   // Resample 'r' and 'frac' to lin or log scale radius

   rlog = spanl(r(1),r(0),nelem);
   fraclog = interp(frac,r,rlog);
   rholog = ((fraclog(dif)/rlog(dif))(pcen))/(2*pi*rlog);

   // struct s_PSF has been defined in first lines of this file

   res = s_PSF();
   res.r = &r;
   res.rho = &rho;
   res.frac = &frac;
   res.rlog = &rlog;
   res.rholog = &rholog;
   res.fraclog = &fraclog;
   res.xcen = xcen;
   res.ycen = ycen;

   return res;

}
%FILE% basic.i
extern basicdoc;
/* DOCUMENT basic package
 *
 *   Basic UNIX like functions and some other very
 *   general purpose ones.
 *
 *   2004-10/NJW
 *   2009-11-13/NJW, updated with lettername

      _cp             fswap           near360         
      _lettername     fullpath        nextbatch       
      adstring        get_time        pfiles_path     
      back            ghost           priarr          
      bit_extract     grep            prstrarr        
      bitpatt2arr     indexclose      pwd             
      cat             indices         radec2sxg       
      check_time      insert          rem_elem        
      cp              inter_step      rm              
      delta           is_dir          set_time        
      docuc           lettername      setbatch        
      docud           lfacul          setup_dir       
      docuf           ls              sixty           
      docui           mkdirp          splitfname      
      docum           more            t2s             
      docup           mv              ten             
      docus           n_yoricks       uniq            
      facul           nan2zero        whereany        
      filesize        near            wherenan        
      filter_common   near2pi         wrdig           
      filter_done     prmat           add13
      remove13        tdosunix        reldif
      gettimetag      n_idls          cronjob
      vsave           vrest           fndeci
      plural
*/

timestamp, TSTARTYORICK;

/* Function insert */

func insert( new_elem, old_arr, final_idx )
/* DOCUMENT new_arr = insert( new_elem, old_arr, final_idx )

   2008-08-19/NJW
*/
{
   if( final_idx <= 0 ) final_idx += numberof(old_arr)+1;

   if( final_idx == 1 ) {
      res = new_elem;
      grow, res, old_arr;
   } else if( final_idx == numberof(old_arr)+1 ) {
      res = old_arr;
      grow, res, new_elem;
   } else {
      res = old_arr(1:final_idx-1);
      grow,res,new_elem,old_arr(final_idx:0);
   }

   return res;

}

/* Function uniq */

func uniq( x )
/* DOCUMENT idx = uniq( x )

   Returns the indices of the unique elements of the
   one-dimensional array 'x'.
   'x' will not be sorted here so
       >  uniq([1,2,1]) returns [1,2,3]
       >  uniq([1,1,2]) returns [1,3]

   2007-06-19/NJW
   2009-10-27/NJW faster because 'grow' now operates on blocks

*/
{
   n = numberof(x);
   if( n == 0 ) return [];
   rsize = 500;
   res = array(long,rsize);
   res(1) = 1;
   k = 1;
   for(i=2;i<=n;i++) {
      if( x(i-1) != x(i) ) {
         res(++k) = i;
         if( k == rsize ) {
            grow, res, res;
            rsize *= 2;
         }
      }
   }
   return res(1:k);
}
/* Function fswap */

func fswap( &a, &b )
/* DOCUMENT fswap, a, b

   returns the value of 'a' in 'b' and vice versa

   2007-02-06/NJW
*/
{ x = a; a = b; b = x; }

/* Function fullpath */

func fullpath( filename )
/* DOCUMENT res = fullpath( filename )

   Returns the entire path to the named file(s).

*/
{
   n = numberof( filename );
   if( n == 1 ) return _fullpath( filename );
   res = array(string,n);
   for( i = 1; i <= n; i++ ) res(i) = _fullpath( filename(i) );
   return res;
}

func _fullpath( filename )
/* DOCUMENT res = _fullpath( filename )

     Returns the entire path to the named file.

     2007-01-29/NJW
*/
{
   local dir, fname;

   if( strlen(get_env("OSTYPE")) == 0 ) { // Windows OS

      if( strpart(filename,2:3) == ":/" ) return filename;

      if( filename == "." ) return strpart( get_cwd(), 1:-1);

      if( strpart(filename,1:2) == "./" ) {
         filename = strpart(filename, 3:0 );
      }
      return get_cwd()+filename;

   } else { // Linux or Solaris OS

      if( strpart(filename,1:1) == "/" ) return filename;

      if( filename == "." ) return strpart( get_cwd(), 1:-1);

      if( filename == ".." ) {
         cwd = get_cwd();
         cwd = cwd == "/" ? cwd : rem_slash(cwd);
         splitfname, cwd, dir, fname;
         return dir;
      }

      if( strpart(filename,1:2) == "./" ) {
         filename = strpart(filename, 3:0 );
         return get_cwd()+filename;
      }

      if( strpart(filename,1:3) == "../" ) {
         filename = strpart(filename, 4:0 );
         splitfname, rem_slash(get_cwd()), dir, fname;
         return dir+"/"+filename;
      }
 
      // a relative filename has been given
      return get_cwd()+filename;

   }
}

/*  Function  cat */

func cat( file1, file2, outfile )
/* DOCUMENT cat, file1, file2, outfile
   Works as UNIX csh command 'cat'; puts file1 and file2
   into outfile

   2004-09-09/NJW

*/

{
   f1 = open( file1 );
   f2 = open( file2 );
   fout = open( outfile, "w" );

   while( line = rdline(f1) ) write, fout, format="%s\n", line;
   while( line = rdline(f2) ) write, fout, format="%s\n", line;
   close, f1;
   close, f2;
   close, fout;

}

/* Function cp */

func cp( file_from, file_to )
/* DOCUMENT cp, file_from, file_to

   Works almost like the Unix/Linux 'cp' command.
   'file_from' cannot be a directory.

   Examples:  cp,"./*","mysubdir";  will copy all files
                  from this directory to directory: mysubdir

   2008-12-11/NJW
*/
{
   local basename, dirname;

   // 'file_from' may not be a directory

   if( is_dir(file_from) ) {
      write,format="%s is a directory\n", file_from;
      return;
   }

   // if 'file_to' is a directory then check the
   // possibility for wild cards i.e. multi-copying

   if( is_dir(file_to) ) {
      splitfname, file_from, dirname, basename;
      filelist = file_search( basename, dirname );
      n = numberof( filelist );
      if( n == 0 ) {
         write,format="%s not found\n", file_from;
         return;
      }
      for( i = 1; i <= n; i++ ) {
         splitfname, filelist(i), dirname, basename;
         filename = file_to+"/"+basename;
         _cp, filelist(i), filename;
      }
      return;
   }

   // from here it is a single file copy

   if( !file_test( file_from ) ) {
      write,format="%s not found\n", file_from;
      return;
   }
   // 'file_to' must be a file name, get the directory
   // where it resides
   splitfname, file_to, dirname, basename;
   if( !file_test(dirname) ) {
      write,format="Directory: %s not found\n", dirname;
      return;
   }
   _cp, file_from, file_to;
   return;
}

/*  Function  _cp */

func _cp( file1, outfile )
/* DOCUMENT    _cp, file1, outfile
   Works as UNIX csh command 'cp'; copies file1 into outfile
   but only single file copying and 'outfile' cannot be a
   directory.

   2004-09-09/NJW
   2007-08-11/NJW, updated to operate on binary files
   2008-12-11/NJW, updated to see all files as binary

*/
{
   f1 = open( file1, "rb" );
   fout = open( outfile, "wb" );
   address = 0;
   v = array(char,1);

   while( _read( f1, address, v) == 1 ) _write, fout, address++, v;

   close, f1;
   close, fout;

   remove, outfile+"L"; // An unwanted log file is produced

}

/*  Function  cmp */

func cmp( file1, file2 )
/* DOCUMENT    cmp, file1, file2
   Works as UNIX csh command 'cmp'; compares file1 with file2
   and reports on the first differing byte.

   The byte number returned starts counting with 1 (one);
   Returning 0 (zero) indicates identical files.
   Returning -1 tells that file1 is bigger than file2
   Returning -2 tells that file2 is bigger than file1

   2012-01-02/NJW

*/
{
   f1 = open( file1, "rb" );
   f2 = open( file2, "rb" );

   //  Check for differing sizes

   a = sizeof(f1) - sizeof(f2);
   if( a ) {
      close, f1; close, f2;
      r = a > 0 ? -1 : -2;
      return r;
   }

   //  Well, they have the same size, check byte by byte

   address = 0;
   v = array(char,1);
   w = array(char,1);

   while( _read( f1, address, v) == 1 ) {
      _read, f2, address++, w;
      if( v(1) != w(1) ) {
         r = address;
         close, f1; close, f2;
         return r;
      }
   }

   close, f1; close, f2;
   return 0; // A perfect match

}


/* Function grep */

func grep( str, dir, sel=, filelist=, nocap= )
/* DOCUMENT  list = grep( str, dir, sel=, filelist=, nocap= )

     Returns a list of findings of string 'str' in the files
     in directory 'dir'. A file name selection can be given
     with keyword 'sel'.
     Keyword 'filelist' can contain a string array with a
     file list that then will override the directory selection.
     Keyword 'nocap' will cause it to disregard upper/lower case.

*/

{

   if( numberof(filelist) ) {
      files = filelist;
   } else {
      if( !is_void(sel) ) {
         files = file_search( sel, dir );
      } else {
         files = file_search( "*", dir );
      }
   }

   if( nocap ) str = strlowcase(str);

   n = numberof(files);
   if( n == 0 ) return [];

   first = 1;
   for( i = 1; i <= n; i++ ) {
      f = open( files(i),"r", 1 );
      if( !f ) continue;
      s = swrite(format="// file = %s", files(i));
      fw = 0;
      while( line = rdline(f) ) {
         if( nocap ) cline = strlowcase(line);
         else cline = line;
         if( strmatch( cline, str ) ) {
            if( fw == 0 ) {
               fw = 1;
               if( first ) {
                  result = s;
                  first = 0;
               } else {
                  grow, result, s;
               }
            }
            grow, result, line;
         }
      }
      close, f;
   }
   return result;

}

/* Function nan2zero */

func nan2zero( arr )
/* DOCUMENT newarr = nan2zero( arr )

   Uses the standard function ieee_test (in 'ieee.i') to
   test for "not normal" i.e. NaN,-Inf,or Inf in array 'arr'.
   The returned array has the same type and size as the input array.

   2006-01-23/NJW

*/
{

   require,"ieee.i";

   newarr = arr;
   wnan = ieee_test(arr);
   w = where( wnan != 0 ); // Rather a test for 'normal'
   if( numberof(w) > 0 ) newarr(w) = 0;

   return newarr;

}

/* Function wherenan */

func wherenan( arr, not= )
/* DOCUMENT idx = wherenan( arr, not= )

   similar to "where( arr is NaN )"
   or - when keyword 'not' is set -
   "where( arr is not NaN )"

   2010-02-16/NJW
*/
{

   require,"ieee.i";
   wnan = ieee_test(arr);
   if( not ) return where( wnan == 0 );
   return where( wnan != 0 );

}

/* Function t2s */

func t2s( filename )
/* DOCUMENT t2s,filename

   "Tab to space" function.
   Convert the tab character ('\t' or ASCII '9') to
   the appropriate number of spaces.

*/
{

   require, "idlx.i";

   text = read_slist( filename );
   nt = numberof( text );
   for( i = 1; i<= nt; i++ ) {
      line = text(i);
      len = strlen( line );
      newline = "";
      pos = 0;
      for( j = 1; j <= len; j++ ) {
         c = strpart( line, j:j );
         if( c == "\t" ) {
            nsp = 8 - (pos % 8);
            for( k = 1; k <= nsp; k++ ) newline += " ";
            pos += nsp;
         } else {
            newline += c;
            pos++;
         }
      }
      text(i) = newline;
   }
   write_slist, filename, text;

}

/* Function inter_step */

func inter_step( y, x, xp )
/* DOCUMENT yp = inter_step( y, x, xp )

   Returns the value y_i where x_i is the largest x_i smaller than xp

   2005-01-30/NJW

*/

{

   w = where( x <= xp );
   if( numberof(w) > 0 ) {
      return y(w(0));
   } else {
      return y(1);
   }

}

func back( filename )
/* DOCUMENT back, filename

   copies filename to filename.nnn where nnn is one larger than
   all other instances of filename.xxx

   2007-08-10/NJW
*/
{
   require,"idlx.i";

   local dirname, basename;

   if( !file_test( filename ) ) {
      write,format="BACK: %s was not found\n", filename;
      return;
   }

   splitfname, filename, dirname, basename;

   list = file_search(basename+"*", dirname);
   n = numberof(list);
   len = strlen( basename );
   list = list(sort(list));
   //+ write,format="%i files considered:\n",n;
   //+ write,list;
   next = 1;
   if( n > 1 ) {
      for(i=2;i<=n;i++) {
         if( strlen(list(i)) < len+4 ) continue; // not part of 'family'
         if( strpart(list(i),-3:-3) != "." ) continue; // not part of 'family'
         s = strpart(list(i),-2:0);
         if( !is_digit(s) ) continue; // not part of 'family'
         //+ write,format="Evaluating %s\n", list(i);
         k = 0;
         sread,format="%d",s,k;
         if( k+1 > next ) next = k+1;
      }
   }
   s = swrite(format=".%03i",next);
   cp, filename, filename+s;
   write,format="Copied into: %s\n", filename+s;
   if( file_test(filename+s+"L") ) remove, filename+s+"L";
}

/* Function bit_extract */

func bit_extract( m, pwr2=, bitn= )
/* DOCUMENT bit = bit_extract( m, pwr2=, bitn= )

   Returns a (long) array of same dimension as 'm'
   indicating whether the bit specified by one of the keywords
   is set.

   pwr2 is one of: 1, 2, 4, 8, 16, ...
   bitn is one of: 1,2,3,4, ...

   pwr2 = 2^(bitn-1)

   2008-01-02/NJW
*/
{
   m = long(m);

   if( pwr2 ) {
      bitn = 0;
      while( pwr2 ) {
         pwr2 = pwr2>>1;
         bitn++;
      }
   } else if( !bitn ) {
      error,"BIT_EXTRACT missing keyword";
   }
   if( bitn <= 0 ) error,"BIT_EXTRACT illegal value of bitn";
   //+ write,format="bitn = %i\n", bitn;

   return (m>>(bitn-1))%2;

}

/* Function bitpatt2arr */

func bitpatt2arr( m )
/* DOCUMENT arr = bitpatt2arr( m )

   Returns bitpattern in an array with
   least significant bit first

   2010-01-08/NJW
*/
{
   if( m == 0 ) return [0];
   r = [];
   while( m > 0 ) {
      grow, r, m%2;
      m = m>>1;
   }
   return r;
}

/* Function filter_done */

func filter_done( done_list, list )
/* DOCUMENT diff_list = filter_done( done_list, list )

   Return an array with values from "list" except
   those that are found in "done_list"

   The functionality is parallel to the C-program "filter_done.c"

    2007-09-25/NJW
    2008-01-09/NJW updated to operate on all types of arrays
*/

{

   if( is_void(done_list) ) return list;

   if( is_void(list) ) return list;

   if( typeof(done_list) != typeof(list) ) {
      error,"FILTER_DONE mismatching argument types";
   }

   // Step through "list"

   ndone_list = numberof(done_list);
   nlist = numberof(list);

   outlist = [];
   for( i = 1; i <= nlist; i++ ) {

      w = where( done_list  ==  list(i) );
      nw = numberof(w);
      if( nw  ==  0 ) {
         grow, outlist, list(i);
      }

   }

   return outlist;

}

/* Function filter_common */

func filter_common( list1, list2 )
/* DOCUMENT common_list = filter_common( list1, list2 )

   Return an array with values that are found both in "list2"
   and in "list1"

   The functionality is parallel to the shell script "filter_common"

    2008-01-09/NJW
    2009-10-27/NJW improved (faster) algorithm
*/
{
   if( is_void(list1) ) return [];
   if( is_void(list2) ) return [];
   if( typeof(list1) != typeof(list2) ) {
      error,"FILTER_DONE mismatching argument types";
   }

   // sort arrays and keep only unique elements

   list1w = list1(sort(list1));
   list2w = list2(sort(list2));
   list1w = list1w(uniq(list1w));
   list2w = list2w(uniq(list2w));

   // only keep the overlap parts

   w = where( list1w >= list2w(1) );
   if( numberof(w) ) list1w = list1w(w);
   else return [];
   w = where( list2w >= list1w(1) );
   if( numberof(w) ) list2w = list2w(w);
   else return [];
   w = where( list1w <= list2w(0) );
   if( numberof(w) ) list1w = list1w(w);
   else return [];
   w = where( list2w <= list1w(0) );
   if( numberof(w) ) list2w = list2w(w);
   else return [];

   // prepare stepping through both arrays

   nlist1w = numberof(list1w);
   nlist2w = numberof(list2w);

   i = j = 1;
   osize = 500;
   outlist = array(structof(list1w),osize);

   k = 0;
   while( i <= nlist1w && j <= nlist2w ) {

      // stepping while indices 'i' and 'j' point to
      // array elements to be compared

      if( list1w(i) == list2w(j) ) {
         outlist(++k) = list1w(i);
         if( k == osize ) {
            grow, outlist, outlist;
            osize *= 2;
         }
         i++; j++;
      } else if( list1w(i) > list2w(j) ) {
         j++;
      } else {
         i++;
      }

   }

   return k == 0 ? [] : outlist(1:k);

}

/* Function near */

func near( x, a, epsilon )
/* DOCUMENT answer = near( x, a, epsilon )

   Result of x > a - epsilon & x < a + epsilon

   2008-01-30/NJW
*/
{ return x > a - epsilon & x < a + epsilon; }

/* Function near360 */

func near360( x, a, epsilon )
/* DOCUMENT answer = near360( x, a, epsilon )

   Result of abs(zero360(x)-zero360(a)) < epsilon |
      360 - abs(zero360(x)-zero360(a)) < epsilon

   2011-01-18/NJW
*/
{
   zz = abs(zero360(x)-zero360(a));
   return zz < epsilon | 360.0 - zz < epsilon;
}

/* Function splitfname */

func splitfname( filenamepath, &dirname, &basename )
/* DOCUMENT  splitfname, filenamepath, &dirname, &basename

    separates a file path into directory name and file name
    using the '/' character as separator. If it does no exist
    in the filenamepath then '.' is given as the directory name.

   2006-02-09/NJW

*/
{
   p = strpos( filenamepath, "/", 0, rev=1); // reversed search direction
   if( p < 1 ) {
      dirname = ".";
      basename = filenamepath;
   } else {
      if( p == 1 ) {
         dirname = "/";
         basename = strpart(filenamepath,2:);
      } else {
         dirname = strpart(filenamepath, 1:p-1);
         basename = strpart(filenamepath,p+1:);
      }
   }
}

/* Function set_time */

func set_time( a )
/* DOCUMENT set_time

   Defines an external variable 'LIMIT_TIME_0' with the current number of
   seconds since 1970-01-01. This is used by function 'check_time' that will
   compare the current time with this time origin.

   SEE ALSO: check_time

   2008-11-01/NJW

*/
{
   extern LIMIT_TIME_0;
   local starttime;

   timestamp, starttime; // returns the number of seconds since Jan 1, 1970
                         // in 'starttime'

   LIMIT_TIME_0 = starttime;

}

/* Function check_time */

func check_time( period, unit= )
/* DOCUMENT within_time_period = check_time( period, unit= )

   Returns 1 (yes) as long as the time elapsed is shorter than
   'period'. The default time unit is hours but it can be set
   to 's' (seconds), 'm' (minutes) in stead by keyword 'unit'.
   (unit='h' will work as well).

   The time origin (saved in external 'LIMIT_TIME_0') must have
   been set by a call of 'set_time'
   or 'check_time()' that returns 1 and resets the time origin.
   If 'LIMIT_TIME_0' has not been defined then it will be set to
   the current time and '1' will be returned.

   SEE ALSO: set_time

   2008-11-01/NJW
*/
{
   extern LIMIT_TIME_0;
   local nowtime;

   if( is_void(LIMIT_TIME_0) && is_void(period) ) {
      set_time;
      return 1;
   }

   timestamp, nowtime;

   if( is_void(unit) ) {
      per = period * 3600.;
   } else if( unit == 's' ) {
      per = double(period);
   } else if( unit == 'm' ) {
      per = period * 60.;
   } else if( unit == 'h' ) {
      per = period * 3600.;
   } else error,"Illegal unit keyword";

   if( double(nowtime - LIMIT_TIME_0) < per ) {
      return 1;
   } else return 0;

}

/* Function get_time */

func get_time( void )
/* DOCUMENT time_in_sec = get_time( )

   Returns number of seconds since the last call of 'set_time'.

   The time origin (saved in external 'LIMIT_TIME_0') must have
   been set by a call of 'set_time'.

   SEE ALSO: set_time

   2009-07-12/NJW
*/
{
   extern LIMIT_TIME_0;
   local nowtime;

   if( is_void(LIMIT_TIME_0) ) {
      write,"set_time must be called first";
      return [];
   }

   timestamp, nowtime;

   return nowtime - LIMIT_TIME_0;

}

/* Function setbatch */

func setbatch( orig_arr, begin= )
{
   extern Orig_batch_arr, Num_batch_arr, Last_batch_index;

   Orig_batch_arr = orig_arr;
   if( is_void(begin) ) {
      Last_batch_index = 0;
   } else {
      if( begin < 1 ) begin = 1;
      Last_batch_index = begin - 1;
   }
   Num_batch_arr = numberof( orig_arr );
}

/* Function nextbatch */

func nextbatch( number )
{
   extern Orig_batch_arr, Num_batch_arr, Last_batch_index;

   i = Last_batch_index + 1;
   j = Last_batch_index + number;
   if( i > Num_batch_arr ) return [];
   if( j > Num_batch_arr ) j = Num_batch_arr;
   Last_batch_index = j;
   return Orig_batch_arr(i:j);

}

/* Function setup_dir */

func setup_dir( file, type= )
/* DOCUMENT setup_dir, file, type=

   if( type=='f' ) // default
      Assumes that 'file' is a file name (not a directory).
      Checks the existence of the directory where it is
      supposed to reside and create it if missing.
   if( type=='d' )
      Check the existence of the directory and create it if
      missing.
   Directory creation by Yorick command: mkdirp

   Default for type : 'f'

   2008-12-01/NJW
*/
{
   local filedir, filename;

   if( is_void(type) ) type = 'f';

   if( type == 'f' ) {
      file = fullpath(file);
      splitfname, file, filedir, filename;
   } else {
      filedir = file;
   }
   mkdirp, filedir;
}

/* Function mkdirp */

func mkdirp(dir)
/* DOCUMENT mkdirp, directory_name
     Create DIRECTORY_NAME, creating any missing parent directories
     (like UNIX utility mkdir -p).  Unlike mkdir, signals error if
     the creation is unsuccessful.  If DIRECTORY_NAME already exists
     and is a directory, mkdirp is a no-op.
   SEE ALSO: mkdir
*/
{
   dir = strtrim(dir, 2, blank="/") + "/";
   list = strfind("/", dir, n=1024);  /* assume <1024 components in dir */
   i = list(1:-1:2);
   list = i(where((i>0) & (list(2:0:2)>0)));
   for (i=numberof(list) ; i>=1 ; i--) {
      name = strpart(dir, [0,list(i)]);
      if (lsdir(name) != 0) break;
   }
   for (i++ ; i<=numberof(list) ; i++)
       mkdir, strpart(dir, [0,list(i)]);
   if (lsdir(dir) == 0) error, "mkdirp: failed to create "+dir;
}

/* Function wrdig */

func wrdig( x, ndec, sci= )
/* DOCUMENT wrdig, x, ndec, sci=
     prints scalar with indicated number of decimals
     Keyword 'sci' forces (scientific) e-format.
*/
{
   if( sci ) {
      fmt = "%."+swrite(format="%ie\n", n);
   } else {
      fmt = "%."+swrite(format="%if\n", n);
   }
   write,format=fmt, x;
}

/* Function fndeci */

func fndeci( x, ndec )
/* DOCUMENT res = fndeci( x, ndec )

    Returns a double representation of 'x' with 'ndec' decimals

   2013-01-09/NJW
*/
{
   if( ndec < 0 ) error,"No negative number of decimals is accepted!";
   if( x < 0 ) {
      s = -1.0;
      ax = -x;
   } else {
      s = 1.0;
      ax = x;
   }
   f = 10.^ndec;
   return s * (floor(ax*f + 0.5)) / f;
}


/* Function rm */

func rm( filename, inq= )
/* DOCUMENT rm, filename, inq=

   Similar to the Unix/Linux 'rm' command
   Keyword 'inq' to be set for inquries

    2008-12-11/NJW
*/
{
   local basename, dirname;

   splitfname, filename, dirname, basename;

   list = file_search( basename, dirname );
   n = numberof(list);

   if( n == 0 ) {
      write,format="%s not found\n", filename;
      return;
   }

   for( i = 1; i <= n; i++ ) {
      ans = "y";
      if( inq ) read,prompt="Remove "+list(i)+" ? ... ", ans;
      if( ans == "y" ) remove, list(i);
   }
}

/* Function mv */

func mv( file_from, file_to, inq= )
/* DOCUMENT mv, file_from, file_to, inq=

   Similar to the Unix/Linux 'mv' command
   Unlike 'rename' mv accepts 'file_to' as a directory and
   then a file with same basename as 'file_from' will be
   created in that directory.
   If 'file_to' is a directory then wild cards may be used
   in 'file_from'.
   Keyword 'inq' for inquiry.

   SEE ALSO: rename, cp, _cp

   2008-12-10/NJW
*/
{
   local basename, dirname;

   // 'file_from' may not be a directory

   if( is_dir(file_from) ) {
      write,format="%s is a directory\n", file_from;
      return;
   }

   // if 'file_to' is a directory then check the
   // possibility for wild cards i.e. multi-moving

   if( is_dir(file_to) ) {
      splitfname, file_from, dirname, basename;
      filelist = file_search( basename, dirname );
      n = numberof( filelist );
      if( n == 0 ) {
         write,format="%s not found\n", file_from;
         return;
      }
      for( i = 1; i <= n; i++ ) {
         ans="y"; if(inq)read,prompt="Move "+filelist(i)+" ? ... ", ans;
         if( ans == "y" ) {
            splitfname, filelist(i), dirname, basename;
            filename = file_to+"/"+basename;
            _cp, filelist(i), filename;
            remove, filelist(i);
         }
      }
      return;
   }

   // from here it is a single file move

   if( !file_test( file_from ) ) {
      write,format="%s not found\n", file_from;
      return;
   }
   // 'file_to' must be a file name, get the directory
   // where it resides
   splitfname, file_to, dirname, basename;
   if( !file_test(dirname) ) {
      write,format="Directory: %s not found\n", dirname;
      return;
   }
   ans="y"; if(inq)read,prompt="Move "+file_from+" ? ... ", ans;
   if( ans == "y" ) {
      _cp, file_from, file_to;
      remove, file_from;
   }
   return;
}

/* Function is_dir */

func is_dir( pathname )
/* DOCUMENT res = is_dir( pathname )

   returns 1 if 'pathname' is a directory, 0 if it is a file,
   and void if it does not exist.

   2008-12-10/NJW
*/
{
   local dir, subdirs, fname;

   if( pathname == "." ) return 1;
   if( pathname == ".." ) return 1;
   if( !file_test( pathname ) ) return [];

   splitfname, pathname, dir, fname;
   lsdir, dir, subdirs;
   return anyof(fname==subdirs);
}

/* Function priarr */

func priarr( i_arr )
/* DOCUMENT priarr, i_arr

   Print integer array on screen on one line
*/
{
   for(i=1;i<=numberof(i_arr);i++) {
      write,format=" %i", i_arr(i);
   }
   write,"";
}


/* Function prstrarr */

func prstrarr( str_arr )
/* DOCUMENT prstrarr, str_arr

   Print string array on screen, one line per element
*/
{
   for(i=1;i<=numberof(str_arr);i++) {
      write,format="%s\n", str_arr(i);
   }
}

/* Function sixty */

func sixty( val_in )
/* DOCUMENT res = sixty
 *+
 * NAME:
 *       SIXTY()
 * PURPOSE:
 *       Converts a decimal number to sexigesimal.
 * EXPLANATION:
 *       Reverse of the TEN() function.
 *
 * CALLING SEQUENCE:
 *       X = SIXTY( SCALAR )
 *
 * INPUTS:
 *       SCALAR -- Decimal quantity.
 * OUTPUTS:
 *       Function value returned = floating real vector of three elements,
 *       sexigesimal equivalent of input decimal quantity.
 *       A negative number is signified by making the first non-zero
 *       element of the output vection negative.
 *
 * PROCEDURE:
 *       Mostly involves checking arguments and setting the sign.
 *
 * EXAMPLE:
 *       If x = -0.345d then sixty(x) = [0.0, -20.0, 24.0]
 *
 * MODIFICATION HISTORY:
 *       Written by R. S. Hill, STX, 19-OCT-87
 *       Output changed to single precision.  RSH, STX, 1/26/88
 *       Accept single element vector   W. Landsman   Sep. 1996
 *       Converted to IDL V5.0   W. Landsman   September 1997
 */
{

   ss = abs(3600.0 * val_in );
   mm = abs(60.0 * val_in );
   dd = abs( val_in );
   result = array(double,3);
   result(1) = double(int(dd));
   result(2) = double(int(mm - 60.0 * result(1)));
   result(3) = double(ss - 3600. * result(1) - 60.0 * result(2));
   if(  val_in  <  0.0 ) {
      if( result(1)  !=  0 ) {
         result(1) = -result(1);
      } else if( result(2)  !=  0 ) {
         result(2) = -result(2);
      } else {
         result(3) = -result(3);
      }
   }

   return result;
}
/* Function radec2sxg */

func radec2sxg(ra, dec, &ihr, &imin, &xsec, &ideg, &imn, &xsc)
/* DOCUMENT radec2sxg, >ra, >dec, >ihr, >imin, >xsec, >idet, >imn, >xsc

 *Convert from decimal to hrs,min
 *+
 * NAME:
 *       RADEC2SXG
 * PURPOSE:
 *       To convert right ascension and declination from decimal degrees to
 *       sexigesimal hours (for( R.A.)  and degrees( for Dec.).
 * CALLING SEQUENCE:
 *       radec,ra,dec,ihr,imin,xsec,ideg,imn,xsc
 * INPUTS:
 *       ra   - right ascension in decimal DEGREES, scalar or vector
 *       dec  - declination in decimal DEGREES, scalar or vector, same number
 *              of elements as RA
 * OUTPUTS:
 *       ihr  - right ascension hours   (INTEGER*2)
 *       imin - right ascension minutes (INTEGER*2)
 *       xsec - right ascension seconds  (REAL*4 or REAL*8)
 *       ideg - declination degrees (INTEGER*2)
 *       imn  - declination minutes (INTEGER*2)
 *       xsc  - declination seconds (REAL*4 or REAL*8)
 * RESTRICTIONS:
 *       RADEC does minimal parameter checking.
 * REVISON HISTORY:
 *       Written by B. Pfarr, STX, 4/24/87
 *-
 * Compute RA
 *
 */
{
   dr = pi / 180.0;
   ra = zero2pi(ra*dr)/dr;

   ihr = toint(ra/15.);
   xmin = abs(ra*4.0-ihr*60.0);
   imin = toint(xmin);
   xsec = (xmin-imin)*60.0;
   //
   // Compute Dec
   //
   ideg= toint(dec);
   xmn = abs(dec-ideg)*60.0;
   imn = toint(xmn);
   xsc = (xmn-imn)*60.0;
   //
   // Now test for the special case of zero degrees
   //
   zero_deg = (ideg  ==  0) & (dec  <  0);
   imn = imn - 2*imn*toint(zero_deg*(imn  !=  0));
   xsc = xsc - 2*xsc*zero_deg*(imn  ==  0);
   return;
}

/* Function ten */

func ten(dd,mm,ss)
/* DOCUMENT res = ten( dd, mm, ss)

   Returns degrees, minutes, seconds as decimal number.
   dd, mm, and ss may be arrays

*/
{

   if( is_void(dd) ) error,"TEN: bad input";
   if( is_void(mm) ) {
      return double(dd);
   }
   vector = [double(dd),double(mm)];
   if( !is_void(ss) ) {
      grow, vector, double(ss);
   }
   dms = dimsof(vector);
   if(dms(1)==1) {
      n_arr = 1;
      nv = dms(2);
      vector = reform(vector,1,dms(2));
   } else {
      n_arr = dms(2);
      nv = dms(3);
   }
   facs = [1.0,60.0,3600.0];
   res = array(double,n_arr);

   for( j = 1; j <= n_arr; j++ ) {
      sgn = anyof( vector(j,) < 0.0 ) ? -1.0 : 1.0;
      vector(j,) = abs(vector(j,));
      decim = vector(j,1);
      for(i=2;i<=nv;i++) decim += vector(j,i)/facs(i);
      res(j) = decim*sgn;
   }
   return n_arr > 1 ? res : res(1);
}

/* Function adstring */

func adstring(ra, dec, precision, truncate=)
/* DOCUMENT
   Return RA and Dec as character string(s) in sexigesimal format.
   EXPLANATION:
         RA and Dec should be entered as
         two separate vectors (or scalars).  One can also specify the precision
         of the declination in digits after the decimal point.

   INPUTS:

         RA     - Right ascension in decimal degrees, numeric scalar or vector
         DEC    - Declination in decimal degrees, numeric scalar or vector

   OPTIONAL INPUT:
         PRECISION  - Integer scalar (0-4) giving the number of digits after the
                 decimal of DEClination.   The RA is automatically 1 digit more.
                 If no PRECISION parameter is passed, a
                 precision of 1 for both RA and DEC is returned to maintain
                 compatibility with past ADSTRING functions.    Values of
                 precision larger than 4 will be truncated to 4.    If
                 PRECISION is 3 or 4, RA and Dec should be input as
                 double precision.
   OPTIONAL INPUT KEYWORD:
         /TRUNCATE - if( set, ) the last displayed digit in the output is
                 truncated in precision rather than rounded.   This option is
                 useful if( ADSTRING() is used to form an official IAU name
                 (see http://vizier.u-strasbg.fr/Dic/iau-spec.htx) with
                 coordinate specification.   The IAU name will typically be
                 be created by applying STRCOMPRESS/REMOVE) after the ADSTRING()
                 call, e.g.
                strcompress( adstring(ra,dec,0,/truncate), /remove)   ;IAU format
   OUTPUT:
         RESULT - Character string(s) containing HR,MIN,SEC,DEC,MIN,SEC formatted
                 as ( 2I3,F5.(p+1),2I3,F4.p ) where p is the PRECISION
                 parameter.    If only a single scalar is supplied it is
                 converted to a sexigesimal string (2I3,F5.1).

   EXAMPLE:
         (1) Display CRVAL coordinates in a FITS header, H

         IDL> crval = sxpar(h,"CRVAL*")  ;Extract 2 element CRVAL vector (degs)
         IDL> write, adstring(crval)     ;Print CRVAL vector sexigesimal format

         (2)  write,adstring(30.42,-1.23,1)  ==>  " 02 01 40.80  -01 13 48.0"
              write,adstring(30.42,+0.23)    ==>  " 02 01 40.8   +00 13 48.0"
              write,adstring(+0.23)          ==>  "+00 13 48.0"

         (3) The first two calls in (2) can be combined in a single call using
             vector input
                write,adstring([30.42,30.42],[-1.23,0.23], 1)
   PROCEDURES CALLED:
         FSTRING(), RADEC, SIXTY()

 */
{

   dr = pi / 180.0;

   nra = numberof(ra);
   if( numberof(dec) != nra ) error,"ADSTRING error, mismatch in array lengths";
   if( is_scalar(ra) ) ra = [ra];
   if( is_scalar(dec) ) dec = [dec];

   ra = zero2pi(ra*dr)/dr;

   if( anyof( dec < -90.0 | dec > 90.0 ) ) error,"adstring, dec values outside 90 deg";

   local ihr, imin, xsec, ideg, imn, xsc;

   radec2sxg, ra, dec, ihr, imin, xsec, ideg, imn, xsc;

   if( is_void(precision) ) precision = 2;
   if( precision < 0 ) precision = 0;
   if( precision > 5 ) precision = 4;

   if( !truncate ) {
      roundsec = [59.5,59.95,59.995,59.9995,59.99995,59.999995];
      carry = where(xsec > roundsec(precision+2));
      Ncarry = numberof(carry);
      if( Ncarry > 0 ) {
         imin(carry)++;
         xsec(carry) = 0.0;
         mcarry = where(imin(carry) == 60);
         Nmcarry = numberof(mcarry);
         if( Nmcarry > 0 ) {
            ic = carry(mcarry);
            ihr(ic) = (ihr(ic) + 1) % 24;
            imin(ic) = 0;
         }
      }
   } else {
      xsec = (long(xsec*10^(precision+1)))/10.0^(precision+1);
   }

/*
 *      Deal with Right Ascension
 */

   secfmt = swrite(format="%%0%i.%if", 3+precision+1, precision+1);
   result = array(string, nra);
   for(i = 1; i <= nra; i++ ) {
      result(i) = swrite(format="%3.2i%3.2i "+secfmt, ihr, imin, xsec );
   }

/*
 *  Deal with declination
 */

   if( precision == 0 ) {

      secfmt = "%2.2i" ;
      if( !truncate ) {
         xsc = floor(xsc+0.5);
         carry = where(xsc == 60);
         Ncarry = numberof(carry);
         if( Ncarry > 0 ) {
            xsc(carry) = 0;
            imn(carry) = imn(carry) + 1;
         }
      }

   } else {

      secfmt = swrite(format="%%0%i.%if", 3+precision, precision);
      if( !truncate ) {
         ixsc = long(xsc + 0.5/10^precision);
         carry = where(ixsc >= 60);
         Ncarry = numberof(carry);
         if( Ncarry > 0 ) {
            xsc(carry) = 0.;
            imn(carry) = imn(carry) + 1;
         }
      } else {
         xsc = (long(xsc*10^precision))/10.0^precision;
      }

   }

   pos = dec >= 0.0;
   carry = where(imn == 60);
   Ncarry = numberof(carry);
   if( Ncarry > 0  ) {
      ideg(carry) = ideg(carry) - 1 + 2*pos(carry);
      imn(carry) = 0;
   }

   deg = array(string,nra);
   for(i = 1; i <= nra; i++ ) {
      deg(i) = swrite(format="%3.2i", ideg(i));
   }
   zero = where(ideg == 0);
   Nzero = numberof(zero);
   if( Nzero > 0 ) {
       negzero = where( dec < 0);
       Nneg = numberof(negzero);
       if( Nneg > 0 ) {
          ineg = zero(negzero);
          deg(ineg) = "-00";
          if( is_scalar(imn) ) {
             imn = abs(imn);
             xsc = abs(xsc);
          } else {
             imn(ineg) = abs(imn(ineg));
             xsc(ineg) = abs(xsc(ineg));
          }
       }
   }

   ipos = where(pos);
   Npos = numberof(ipos);
   if( Npos > 0 ) deg(ipos) =  "+" + strtrim(deg(ipos));

   if( precision == 0 ) {
      for( i = 1; i <= nra; i++ ) {
         result(i) += " "+deg(i)+swrite(format="%3.2i "+secfmt, \
                      imn(i), long(floor(xsc(i)+0.5)));
      }
   } else {
      for( i = 1; i <= nra; i++ ) {
         result(i) += " "+deg(i)+swrite(format="%3.2i "+secfmt, imn(i), xsc(i));
      }
   }

   return nra == 1 ? result(1) : result;

}

/* Function facul */

func facul( i, j )
/* DOCUMENT res = facul( i [,j] )

    returns i!/(j-1)!
    i.e.:   i * (i-1) * (i-2) * ... * j
    where j < i.

    If 'j' is not given it is assumed to be one.

    2009-04-15/NJW
*/
{
   if( i < 2 ) return 1;
   if( is_void(j) ) j = 1;
   if( i == j ) return i;
   if( i == j-1 ) return 1;
   if( i < j+1 ) error,"Bad input to function 'facul'";
   r = j;
   for(k=j+1;k<=i;k++) r *= k;
   return r;
}

/* Function lfacul */

func lfacul( i, j )
/* DOCUMENT res = lfacul( i [,j] )

    returns log( i!/(j-1)! )
    i.e.:   log(i * (i-1) * (i-2) * ... * j)
    where j < i.

    If 'j' is not given it is assumed to be one.

    2010-05-26/NJW, based on 'facul'
*/
{
   if( i < 2 ) return 0.0;
   if( is_void(j) ) j = 1;
   if( i == j ) return log(i);
   if( i == j-1 ) return 0.0;
   if( i < j+1 ) error,"Bad input to function 'lfacul'";
   r = log(j);
   for(k=j+1;k<=i;k++) r += log(k);
   return r;
}

/* Function rem_elem */

func rem_elem( arr, i )
/* DOCUMENT new_arr = rem_elem( arr, i )

   Return an array of same type as 'arr' but with
   element(s) 'i' removed. 'i' may be an array.
   'arr' can have several dimensions but the action
   is on the last index.

*/
{
   if( numberof(i) == 0 ) return arr;
   new_arr = arr;
   dms = dimsof(arr);
   n = dms(0);
   // if last dimension is 1 and 1 is included in 'i' then return void
   if( n == 1 && nallof(i-1) ) return [];
   k = 0;
   for(j=1;j<=n;j++) {
      // if no match then keep the array element
      if( allof(i-j) ) new_arr(..,++k) = arr(..,j);
   }
   return new_arr(..,1:k);
}

/* Function filesize */

func filesize( filename )
/* DOCUMENT number_of_bytes = filesize( filename )
*/
{
   f = open(filename,"rb");
   s = sizeof(f);
   close,f;
   return s;
}

/* Function pfiles_path */

func pfiles_path( filename )
/* DOCUMENT parfile = pfiles_path( parfile_name )

   Returns the complete path to the parameter file given
   by 'parfile_name'. Searches first the current directory,
   then the directories given in the environment variable
   PFILES separated by colons but it stops at the (first)
   semicolon.

   2009-07-09/NJW
*/
{
   pfiles = get_env("PFILES");
   if( strlen(pfiles) == 0 ) {
      write,"Warning, PFILES is not set";
      return file_test(filename) ? filename : [];
   }
   // remove part following ';'
   pfiles = strsplit( pfiles,";")(1);
   str = strsplit( pfiles, ":");
   n_str = numberof(str);
   for( i = 1; i <= n_str; i++ ) {
      pth = str(i)+"/"+filename;
      if( file_test(pth) ) return pth;
   }
   return [];
}

/* Function delta */

func delta( arr )
/* DOCUMENT darr = delta( arr )

   Returns the pairwise difference between successive
   elements. The first one is copied to keep the
   number of elements.

*/
{
   d = arr - shift(arr,-1);
   d(1) = d(2);
   return d;
}

/* Function struc */

func struc( str )
/* DOCUMENT structure = struc( char_type )

   Returns the structure that corresponds to 'char_type'
   's' : string, 'i' : integer, 'j' : long,
   'f' : float, 'd' : double, 'c' : char

   e.g. a = array(struc('d'),10)
   will produce an array of doubles.

*/
{
   if( typeof(str) == "string" ) {
      cstr = (*pointer(str))(1);
   } else if( typeof(str) == "char" ) {
      cstr = str;
   } else error,"Bad argument for STRUC";

   if( cstr == 's' ) {
      return string;
   } else if( cstr == 'i' ) {
      return int;
   } else if( cstr == 'j' ) {
      return long;
   } else if( cstr == 'f' ) {
      return float;
   } else if( cstr == 'd' ) {
      return double;
   } else if( cstr == 'c' ) {
      return char;
   } else return [];
}

/* Function _str2x */

func _str2x( str, dtype )
/* DOCUMENT value = _str2x( str, dtype )

   Converts a string in 'str' to a value of
   type given by 'dtype':

   's' : string, 'i' : integer, 'j' : long,
   'f' : float, 'd' : double, 'c' : char
*/
{
   if( dtype == 's' ) {
      return str;
   } else if( dtype == 'i') {
      return int(atoi(str));
   } else if( dtype == 'j') {
      return atoi(str);
   } else if( dtype == 'f') {
      return float(atof(str));
   } else if( dtype == 'd') {
      return atof(str);
   } else if( dtype == 'c') {
      return char(atoi(str));
   } else return [];
}

/* Function ytar */

/*****************************************************
 *   A tar system operated by Yorick
 *****************************************************/

func ytar( option, ytarfilename, list_of_files_or_filename, safe= )
/* DOCUMENT ytar, option, ytarfilename, list_of_files_or_filename, safe=

   A tar like function that only operates on text files.

   Option  "c"  create archive
           "l"  list archive contents
           "x"  extract files or named file
                 Accepts space or comma separated list with
                 exact file names
        A  "v"  can be added for verbosity

   Keyword  safe : When set a backup will be done before replacing
                   if the file to be extracted already exists
*/
{
   if( 1 != strmatch(option,"c")+strmatch(option,"l")+strmatch(option,"x") ) {
      write,"Illegal option for ytar";
      return;
   }
   v = strmatch(option,"v"); // flag for verbosity


   if( strmatch(option,"c") ) {
      nfiles = numberof(list_of_files_or_filename);
      f = open(ytarfilename,"w");
      write,f,format="%%YTAR%% Header %s\n", ndate(3);
      for( i = 1; i <= nfiles; i++ ) {
         text = rdfile(list_of_files_or_filename(i));
         if( !(ntext=numberof(text)) ) continue;
         if(v) write,format="Adding %s (%i lines)\n", list_of_files_or_filename(i), ntext;
         write,f,format="%%FILE%% %s\n", list_of_files_or_filename(i);
         for( j = 1; j <= ntext; j++ ) write,f,format="%s\n",text(j);
      }
      close,f;
   } else if( strmatch(option,"x") ) {
      text = rdfile(ytarfilename);
      // test file contents
      if( strpart(text(1),1:6) != "%YTAR%" ) {
         write,"Not a ytar file - quit";
         return;
      }
      // see if named files are to be extracted
      nxlist = 0;
      if( !is_void(list_of_files_or_filename) ) {
         llist = strcharrepl( list_of_files_or_filename," ",",");
         xlist = strsplit(llist,",");
         nxlist = numberof(xlist);
      }
      ntext = numberof(text);
      file_is_open = 0;
      for( j = 2; j <= ntext; j++ ) {
         if( strpart(text(j),1:6) == "%FILE%" ) {
            if( file_is_open ) {
               close, f;
               file_is_open = 0;
            }
            filename = strtrim(strpart(text(j),7:0));
            ok = 1;
            if( nxlist ) { // see if this is wanted
               ok = anyof( filename == xlist );
            }
            if( ok ) {
               if( safe ) back, filename;
               if(v) write,"Creating "+filename;
               f = open(filename,"w");
               file_is_open = 1;
            }
         } else {
            if( ok ) write,f,format="%s\n", text(j);
         }
      }
      close,f;
   } else if( strmatch(option,"l") ) {
      text = rdfile(ytarfilename);
      // test file contents
      if( strpart(text(1),1:6) != "%YTAR%" ) {
         write,"Not a ytar file - quit";
         return;
      }
      ntext = numberof(text);
      for( j = 2; j <= ntext; j++ ) {
         if( strpart(text(j),1:6) == "%FILE%" ) {
            filename = strtrim(strpart(text(j),7:0));
            write,format="%s\n", filename;
         }
      }
   } else {
      write,"Illegal option - quit";
   }
}

/* Function bytar */

/*****************************************************
 *   A binary tar system operated by Yorick
 *****************************************************/

func bytar( option, ytarfilename, list_of_files_or_filename, safe= )
/* DOCUMENT bytar, option, ytarfilename, list_of_files_or_filename, safe=

   A tar like function with limited functionality  that operates
   on all kinds of files.

   Option  "c"  create archive
           "l"  list archive contents
           "x"  extract files or named file
                 Accepts space or comma separated list with
                 exact file names
           A "v" can be added for verbosity

   Keyword  safe : When set a backup will be done before replacing
                   if the file to be extracted already exists

   The archive is formatted as

      %BYTAR% YYYY-MM-DDTHH:MM:SS {filename number_of_bytes file_content}

   where {...} is repeated as many times as required.

*/
{
   c = char(0);
   cheader = array(char,35);
   nb = int(0);

   // check the integrity of the option
   nsum = 0;
   if( strmatch(option,"c") ) nsum++;
   if( strmatch(option,"l") ) nsum++;
   if( strmatch(option,"x") ) nsum++;
   if( nsum != 1 ) {
      write,"Illegal option for bytar";
      return;
   }
   v = strmatch(option,"v"); // flag for verbosity

   if( strmatch(option,"c") ) {
      nfiles = numberof(list_of_files_or_filename);
      f = open(ytarfilename,"wb");
      signature = swrite(format="%%BYTAR%% Header %s", ndate(3));
      csig = *pointer(signature);
      address = 0;
      _write,f,address,csig;
      address += sizeof(csig);
      for( i = 1; i <= nfiles; i++ ) {
         nbytes = filesize(list_of_files_or_filename(i));
         if( !nbytes ) continue;
         if(v)write,format="%s (%i)\n", list_of_files_or_filename(i), nbytes;
         cname = *pointer(list_of_files_or_filename(i));
         _write,f,address,cname;     address += sizeof(cname);
         _write,f,address,nbytes;    address += sizeof(nbytes);
         fi = open(list_of_files_or_filename(i),"rb");
         for( j = 0; j < nbytes; j++ ) {
            _read,fi,j,c;
            _write,f,address+j,c;
         }
         close,fi;
         address += nbytes;
      }
      close,f;
      remove, ytarfilename+"L";

   } else if( strmatch(option,"x") ) {

      nbtar = filesize(ytarfilename);
      f = open(ytarfilename,"rb");
      address = 0;
      _read,f,address,cheader;   address += sizeof(cheader);
      header = string(&cheader);
      // test file signature
      if( strpart(header,1:15) != "%BYTAR% Header " ) {
         write,"Not a bytar file - quit";
         close,f;
         return;
      }
      fdate = strpart(header,16:34);
      write,format="Date of bytar file: %s\n", fdate;

      // see if named files are to be extracted
      nxlist = 0;
      if( !is_void(list_of_files_or_filename) ) {
         llist = strcharrepl( list_of_files_or_filename," ",",");
         xlist = strsplit(llist,",");
         nxlist = numberof(xlist);
      }
      file_is_open = 0;

      while( address < nbtar-1 ) {

         // get filename of next file in archive
         cname = [];
         do {
            _read,f,address++,c;
            grow,cname,c;
         } while( c );
         filename = string(&cname);

         _read,f,address,nb; address += sizeof(nb);

         // set 'ok' flag if this file is to be extracted

         ok = 1;
         if( nxlist ) { // see if this is wanted
            ok = anyof( filename == xlist );
         }
         if( ok ) {
            if(v)write,format="%s (%i)\n", filename, nb;
            if( safe ) {
               if( file_test(filename) ) back, filename;
            }
            fi = open(filename,"wb");
            for( j = 0; j < nb; j++ ) {
               _read,f,address+j,c;
               _write,fi,j,c;
            }
            close,fi;
            remove,filename+"L";
         }
         address += nb;
      }
      close,f;

   } else if( strmatch(option,"l") ) {

      nbtar = filesize(ytarfilename);
      f = open(ytarfilename,"rb");
      address = 0;
      _read,f,address,cheader;   address += sizeof(cheader);
      header = string(&cheader);
      // test file signature
      if( strpart(header,1:15) != "%BYTAR% Header " ) {
         write,"Not a bytar file - quit";
         close,f;
         return;
      }
      fdate = strpart(header,16:34);
      write,format="Date of bytar file: %s\n", fdate;

      while( address < nbtar-1) {

         // get filename of next file in archive
         cname = [];
         do {
            _read,f,address++,c;
            grow,cname,c;
         } while( c );
         filename = string(&cname);

         _read,f,address,nb; address += sizeof(nb);
         write,format="%s (%i)\n", filename, nb;

         address += nb;
      }
      close,f;


   } else {

      write,"Illegal option - quit";

   }

}

/* Function lettername */

func lettername( n, nlet, lc= )
/* DOCUMENT res = lettername( n, nlet, lc= )

   Returns a string (or an array of strings) with letter representation
   of the number 'n' (that can be an array). The number of letters is 'nlet'
   Default is basis 'A' but lower case can be selected with keyword 'lc'

   2009-11-13/NJW
*/
{
   nn = numberof(n);
   if( nn > 1 ) {
      s = array(string,nn);
      for( i = 1; i <= nn; i++ ) s(i) = _lettername( n(i), nlet, lc=lc );
   } else s = _lettername( n, nlet, lc=lc );
   return s;
}

func _lettername( n, nlet, lc= )
{
   if( n > 26^nlet ) error,"_LETTERNAME n is too large";
   cA = lc ? *pointer("a") : *pointer("A");
   la = array(int,nlet);
   for(i=1;i<nlet;i++) {
      la(i) = (n-1)/26^(nlet-i);
      n -= la(i)*26^(nlet-i);
   }
   la(i) = n-1;
   c = char(la)+cA(1);
   grow,c,cA(2);
   return string(&c);
}

func _letternamex( n, nlet )
/* DOCUMENT str = _letternamex( n, nlet )

   Return n'th string starting with "0000" (size depends
   on 'nlet' in the 62 period sequence 0-9,A-Z,a-z
   2009-11-18/njw
*/
{
   if( n > 62^nlet ) error,"_LETTERNAMEX n is too large";
   la = array(int,nlet);
   ca = array(char,nlet);
   for(i=1;i<nlet;i++) {
      la(i) = (n-1)/62^(nlet-i);
      n -= la(i)*62^(nlet-i);
      ca(i) = _tochar(la(i));
   }
   la(i) = n-1;
   ca(i) = _tochar(la(i));
   grow,ca,0;
   return string(&ca);
}
func _letternamey( n, nlet )
/* DOCUMENT str = _letternamey( n, nlet )

   Return n expressed in a base 62 number system
   using the symbol sequence: 0-9,A-Z,a-z
   2009-11-18/njw
*/
{
   if( n >= 62^nlet ) error,"_LETTERNAMEY n is too large";
   la = array(int,nlet);
   ca = array(char,nlet);
   for(i=1;i<nlet;i++) {
      la(i) = n/62^(nlet-i);
      n -= la(i)*62^(nlet-i);
      ca(i) = _tochar(la(i));
   }
   la(i) = n;
   ca(i) = _tochar(la(i));
   grow,ca,0;
   return string(&ca);
}
func _tochar( n )
{
   if( n > 61 ) return '?';
   ca = 'a'; cA = 'A'; c0 = '0';
   if( n <= 9 ) return char(c0 + n);
   if( n <= 35 ) return char(cA + n - 10);
   return char(ca + n - 36);
}

/* Function pwd */

func pwd( void )
/* DOCUMENT pwd

    prints the current directory name
*/
{  get_cwd(); }

/* Function indices */

func indices( arr, j )
/* DOCUMENT indices( arr, j )

    If 'arr' is scalar then return 1
    If 'arr' is 1D then
       If 'j' is scalar then return [j]
       Else return j(1)
    If 'arr' is 2D or more then
       If 'j' is scalar return array with
           indices of 'arr'
       If 'j' is a vector and has as many elements as
           'arr' has dimensions then return single index

    2010-01-07/NJW
*/
{
   dms = dimsof(arr);
   if( dms(1) == 0 ) return 1;
   ndms = dms(1);
   jdms = dimsof(j);
   if( dms(1) == 1 ) {
      if( jdms(1) == 0 ) return [j];
      if( jdms(1) == 1 && jdms(2) == 1 ) return j(1);
      error,"INDICES ##1##";
   }

   // When you come here then 'arr' has 2 or more dimensions
   // so decide it 'j' is a scalar or has as many dimensions
   // as 'arr'

   if( jdms(1) != 0 && jdms(2) != ndms ) error,"INDICES ##2##";

   far = gar = dms(1:-1);
   far(1) = 1;
   for( k = 3; k <= dms(1); k++ ) {
      gar(k:0) = dms(k-1);
      gar(1:k-1) = 1;
      far *= gar;
   }

   // Case for determining single index

   if( jdms(1) == 1 ) {

      return sum((j-1)*far)+1;

   } else {  // Case for determining index vector

      idx = array(int,dms(1));
      id = j-1;
      for( k = dms(1); k >= 1; k-- ) {
         idx(k) = id/far(k) + 1;
         id -= (idx(k)-1)*far(k);
      }
      return idx;
   }
}

/* Function indexclose */

func indexclose( arr, value )
/* DOCUMENT indexclose( arr, value )

   Returns the index (or indices) of 'arr' where
   the value is closest to 'value'

*/
{
   return where(min(abs(arr-value)) == abs(arr-value));
}

/* Function ls */

func ls( arg1, arg2, type=, width= )
/* DOCUMENT ls, dir, sel, type=, width=
            ls, sel, type=, width=
            ls, type=, width=

   First version: Displays files in directory 'dir' using   
                  selection string 'sel'
   Second version: Displays files in current directory using   
                  selection string 'sel'
   Third version: Displays files in current directory without
                  any selection

   'type' can be "f" or "d" (files or directories)
           default is both
   'width' is terminal width (default: 80)
*/
{
   local subdirs;

   if( is_void(arg2) ) {
      dir = "."; // second or third version
      sel = arg1;
   } else {
      if( is_void(arg1) ) {
         write,"Illegal arguments for 'ls'";
         return;
      } else {
         dir = arg1; // first version
         sel = arg2;
      }
   }
   if( is_void(width) ) width = 80;
   if( typeof(sel) == "string" ) { // search by 'file_search'

      files = file_search( sel, dir );
      nfiles = numberof(files);
      if( nfiles ) {
         w = where(strpart(files,1:2)=="./");
         if( numberof(w) ) files(w) = strpart(files,3:0);
      }
      nsubd = 0;
      type = "f"; // avoid directories, override user's choice

   } else { //   search by 'lsdir'

      files = lsdir( dir, subdirs );
      nfiles = numberof(files);
      // remove files where names begin with "."
      if( nfiles ) {
         w = where( strpart(files,1:1) != "." );
         if( (nfiles = numberof(w)) ) files = files(w);
      }
      nsubd  = numberof(subdirs);
      if( nsubd ) {
         subdirs += "/";
         w = where( strpart(subdirs,1:1) != "." );
         if( (nsubd = numberof(w)) ) subdirs = subdirs(w);
      }
   }

   ntyp = 3;
   if( typeof(type) == "string" ) {
      if( type == "f" ) ntyp = 1; 
      if( type == "d" ) ntyp = 2; 
   }
   if( ntyp == 1 && nfiles == 0 ) {
      write,"No plain files found";
      return;
   }
   if( ntyp == 2 && nsubd == 0 ) {
      write,"No directories found";
      return;
   }
   list = [];
   if( ntyp%2 == 1 ) grow, list, files;
   if( ntyp   >= 2 ) grow, list, subdirs;

   if( am_subroutine() ) {
      maxlen = max(strlen(list));
      ncol = maxlen > width ? 1 : width / (maxlen+2);
      arrange_words_in_columns,list,ncol,maxlen+2;
   }
   return list;
}

/* Function more */

func more( filename, nl= )
/* DOCUMENT more, filename, nl=

     displays the contents of the file on the screen.

     Keyword 'nl' gives the number of lines per display
                  (defaults to 20).
                  Setting it to zero causes the entire file
                  to be written.
*/
{
   if( is_void(nl) ) nl = 20;
   if( nl == 0 ) nl = 1000000;
   ans = "";
   text = rdfile(filename);
   ntext = numberof(text);
   nchunks = (ntext-1)/nl + 1;
   for( i = 1; i <= nchunks; i++ ) {
      i1 = (i-1)*nl + 1;
      i2 = i*nl;
      if( i2 > ntext ) i2 = ntext;
      prstrarr,text(i1:i2);
      if( i2 == ntext ) {
         write,format="      *** Done! *** line: %i, %.1f %% ***\n", i2, (100.*i2)/ntext;
      } else {
         write,format="      *** line: %i, %.1f %% ***\n", i2, (100.*i2)/ntext;
      }
      if( i < nchunks ) {
         // read,prompt=" ...",ans;
         ans = rdline(prompt=" ... ");
         if( ans == "x" || ans == "q" ) break;
      }
   }
}

/* Function vi */

func vi( filename )
/* DOCUMENT vi, filename

   Wrapper to call the 'vi' editor
*/
{
   system,"vi "+filename;
}

/* Function whereany */

func whereany( arr, target )
/* DOCUMENT idx = whereany( arr, target)

   Returns the list of indices where 'arr' matches any
   of the values in 'target'
*/
{
   idx = [];
   nt = numberof(target);
   for(i=1;i<=nt;i++) {
      w = where( arr == target(i) );
      if( numberof(w) ) grow, idx, w;
   }
   if( is_void(idx) ) return [];
   idx = idx(sort(idx));
   return idx(uniq(idx)); // remove duplicate values
}

/* Function n_yoricks */

func n_yoricks( a )
/* DOCUMENT n_processes = n_yoricks()

   Returns the current number of yorick processes running.

   Works only on Unix/Linux systems.
*/
{
   user = get_env("USER");
   return atoi(rdfile(popen("ps -u "+user+" | grep yorick | wc -l",0))(1));
}

/* Function n_idls */

func n_idls( a )
/* DOCUMENT n_processes = n_idls()

   Returns the current number of IDL processes running.

   Works only on Unix/Linux systems.
*/
{
   user = get_env("USER");
   return atoi(rdfile(popen("ps -u "+user+" | grep idl | wc -l",0))(1));
}

/* Function docu */

/************************************************************

    Functions for PostScript image (picture) documentation
    in the PostScript file itself.

    2011-11-24/NJW

************************************************************/

extern docudoc;
/* DOCUMENT Functions for image documentation

    docui       Initalization of next documentation file
    docuf       Insert name of used function into the documentation file
    docud       Insert name of data file into the documentation file
    docuc       Insert name of file with code into the documentation file
    docup       Update PostScript file with documentation
    docum       Prints current doc. file on terminal
    docus       Insert string or string array into the documentation file
    docut       Append text file to the documentation file

    Example sequence:
      > docui; // Start a new documentation file
      > docuc,"my_bunch_of_functions.i";
      > docuf,"butanification";
      > docus,"used on the data file:";
      > docud,"measurements.fits";
      > docum; // Check the current documentation file
      > docup, "yplot_0033.ps"; // Append documentation
*/

/* Function docui */

func docui( void )
{
   extern Docu_filename;
   Docu_filename = get_next_filename("docu_????.txt");
   write,"External: Docu_filename is now "+Docu_filename;
   f = open( Docu_filename,"w" );
   write,f,format="%s","\n";
   write,f,format="Documentation from %s\n", fullpath(Docu_filename);
   write,f,format="%s","\n";
   close, f;
}
func docum( void )
{
   extern Docu_filename;
   if( is_void(Docu_filename) ) {
      write,"No documentation file has been defined";
      return;
   }
   prstrarr,rdfile(Docu_filename);
}
func docuf( funcname )
{
   extern Docu_filename;
   if( is_void(Docu_filename) ) docui; // Create if missing
   f = open( Docu_filename,"a" );
   write,f,format="Function name: %s\n", funcname;
   close,f;
}
func docus( instring )
{
   extern Docu_filename;
   if( is_void(Docu_filename) ) docui; // Create if missing
   f = open( Docu_filename,"a" );
   for( i = 1; i <= numberof(instring); i++ ) write,f,format="%s\n", instring(i);
   close,f;
}
func docud( filename )
{
   extern Docu_filename;
   if( is_void(Docu_filename) ) docui; // Create if missing
   f = open( Docu_filename,"a" );
   write,f,format="Data file name: %s\n", filename;
   close,f;
}
func docut( filename )
{
   extern Docu_filename;
   if( !file_test(filename) ) {
      write,"Did not find "+filename;
      return;
   }
   if( is_void(Docu_filename) ) docui; // Create if missing
   docus, rdfile(filename);
}
func docuc( codefile )
{
   extern Docu_filename;
   if( is_void(Docu_filename) ) docui; // Create if missing
   f = open( Docu_filename,"a" );
   write,f,format="Code file: %s\n", codefile;
   close,f;
}
func docup( psfilename )
{
   extern Docu_filename;
   if( !file_test(psfilename) ) {
      write,"Did not find "+psfilename;
      return;
   }
   if( is_void(Docu_filename) ) docui; // Create if missing
   f = open( psfilename,"a" );
   text = rdfile( Docu_filename );
   for( i = 1; i <= numberof(text); i++ ) {
      write,f,format="%% %s\n", text(i);
   }
   close,f;
}

/* Function cleanl */

func cleanl( void )
/* DOCUMENT cleanl

    Remove all files in current directory whose names end with 'L'.

*/
{
   list = file_search("*L");
   if( (n = numberof(list)) ) {
      for( i = 1; i <= n; i++ ) remove,list(i);
      write,"Removed "+itoa(n)+" files.";
   } else {
      write,"Nothing to do.";
   }
}

/* Function ghost */

func ghost( void )
/* DOCUMENT hostname = ghost()
         or  ghost

    If the hostname is composed of several terms like
    tesla.spacecenter.dk then only the first part ('tesla')
    is returned.
*/
{
   host = get_env("HOST");
   if( am_subroutine() ) {
      write,host;
   } else return strsplit(host,".")(1);
}

/* Function prmat */

func prmat( arr, fmt= )
/* DOCUMENT prmat, arr, fmt=

     Nice print of 2D matrix

     'fmt' is for a single number e.g. "%8.3f" or "%13.5e"
     Default for float is "%11.3e", default for int is "%8i".

     If 'fmt' is given then it will decide the whether int's or floats
     are printed. Else the type of 'arr' will determine.
*/
{
   dms = dimsof( arr );
   if( dms(1) != 2 ) error,"Not a 2D array";
   // define 'natural' type
   tp = typeof(arr);
   tp = tp == "long" || tp == "int" ? 0 : 1;

   // check if 'fmt' forces a type
   if( typeof(fmt) == "string" ) {
      if( strpart(fmt, 0:0 ) == "i" ) tp = 0;
      else tp = 1;
   } else {
      fmt = tp == 1 ? "%11.3e" : "%8i";
   }
   ty = tp == 1 ? double : long;

   for( i = 1; i <= dms(2); i++ ) {
      write,format="%3i:", i;
      for( j = 1; j <= dms(3); j++ ) write,format=fmt, ty(arr(i,j));
      write,"";
   }
}

/* Function add13 */

func add13( file_in, file_out )
/* DOCUMENT add, file_in, file_out

     Insert a CR (13) before each occurrence of LF (10)
     in a similar way for Unix to Dos file conversion.
 
     SEE ALSO remove13 and tdosunix.
*/
{
   if( !file_test(file_in) ) error,"Did not find "+file_in;

   f_in = open( file_in,"rb" );
   f_out = open( file_out,"wb" );

   i = 0;  j = 0;

   v = array(char,1);
   v13 = array(char(13),1);
   address_in = 0;
   address_out = 0;
   while( _read( f_in, address_in++, v ) == 1 ) {
      i++;
      if( v(1) == 10 ) {
         _write,f_out, address_out++, v13;
         j++;
      }
      _write,f_out,address_out++, v;
      j++;
   }
   close, f_in;
   close, f_out;
   write,format="%i bytes input, %i bytes output\n", i, j;
   remove, file_out+"L";
}

/* Function remove13 */

func remove13( file_in, file_out )
/* DOCUMENT remove13, file_in, file_out

    Remove all occurrences of CR (13)
    in a similar way as DOS to Unix file conversion.
 
     SEE ALSO add13 and tdosunix.
*/
{
   if( !file_test(file_in) ) error,"Did not find "+file_in;

   f_in = open( file_in,"rb" );
   f_out = open( file_out,"wb" );

   i = 0;  j = 0;

   v = array(char,1);
   address_in = 0;
   address_out = 0;
   while( _read( f_in, address_in++, v ) == 1 ) {
      i++;
      if( v(1) != 13 ) {
         _write,f_out, address_out++, v;
         j++;
      }
   }
   close, f_in;
   close, f_out;
   write,format="%i bytes input, %i bytes output\n", i, j;
   remove, file_out+"L";
}

/* Function tdosunix */

func tdosunix( filename )
/* DOCUMENT tdosunix, filename
      or    res = tdosunix( filename )

     "Test DOS or UNIX"
  
     Count the number of occurrences of '10' and '13'
     both as singles and as pairs in a file.
     On the basis of that decide if file is in DOS style (res = 1)
     or in UNIX style (res = 0).
  
     Prints counts of 10 and 13 bytes (and pairs) when called as a
     subroutine. If called as a function 1 or 0 will be returned.
  
     Returns -1 and prints the counts if in doubt.
  
     SEE ALSO add13 and remove13.
 */
{
   i10 = 0;
   i13 = 0;
   i1310 = 0;
   i1013 = 0;
   p10 = 0;
   p13 = 0;

   if( !file_test(filename) ) error,"Did not find "+filename;
   f = open( filename, "rb" );

   v = array(char,1);

   address = 0;

   while( _read( f, address++, v ) == 1 ) {
      if( v(1) == 13 ) {
         i13++;
         if( p10 ) i1013++;
         p13 = 1;
      } else {
         if( v(1) != 10 ) p13 = 0;
      }
      if( v(1) == 10 ) {
         i10++;
         if( p13 ) i1310++;
         p10 = 1;
      } else {
         if( v(1) != 13 ) p10 = 0;
      }
   }
   close,fp;
   if( am_subroutine() ) {
      write,format="   In file %s:\n", filename;
      write,format="Found %i occurrences of LF (10)\n", i10;
      write,format="Found %i occurrences of CR (13)\n", i13;
      write,format="Found %i occurrences of pairs of CR+LF (13+10)\n", i1310;
      write,format="Found %i occurrences of pairs of LF+CR (10+13)\n", i1013;
   } else {
      if( i1310 == i10 ) return 1; // Definitely in DOS style
      if( i1310 == 0 ) return 0; // Definitely in UNIX style
      write,format="Found %i occurrences of LF (10)\n", i10;
      write,format="Found %i occurrences of CR (13)\n", i13;
      write,format="Found %i occurrences of pairs of CR+LF (13+10)\n", i1310;
      write,format="Found %i occurrences of pairs of LF+CR (10+13)\n", i1013;
      return -1; // Indeterminate
   }
}

/* Function is_link */

func is_link( filename )
/* DOCUMENT res = is_link( filename )

   Returns 1 if 'filename' is a symbolic link
   0 otherwise.

   This function is only useful for Linux/Unix operative systems.

   Uses the 'targetname' script.

   2012-04-30/NJW
*/
{
   OSTYPE = get_env("OSTYPE");
   if( strlen(OSTYPE) == 0 ) error,"Not for this OS";

   target = rdline(popen("targetname "+filename,0));
   ffilename = fullpath(filename);
   ftarget = fullpath(target);
   if( ftarget == ffilename ) return 0;
   else return 1;

}

/* Function reldif */

func reldif( x, y )
/* DOCUMENT r = reldif( x, y )

    Returns max( abs(x/y), abs(y/x) )

    So neither x nor y can be zero. Makes no sense if of opposite sign.

*/
{
   x = double(x);
   y = double(y);
   if( nallof(x) ) error,"Called reldif with x == 0";
   if( nallof(y) ) error,"Called reldif with y == 0";
   return max( abs(x/y), abs(y/x) );
}

/* Function gettimetag */

func gettimetag( filename, fmt= )
/* DOCUMENT res = gettimetag( filename, fmt= )

     Returns the modification time of the mentioned file.

     Keyword 'fmt':
            1 (default) : long,   number of seconds since Jan 1, 1970
            2           : string, Date string YYYY-MM-DD
            3           : string, Dattim string YYYY-MM-DDTHH:MM:SS

     Based on the shell function 'date'.

     2012-10-09/NJW
*/
{
   if( get_env("OSTYPE") != "linux" ) {
      write,"gettimetag is not implemented for your OS: "+get_env("OSTYPE");
      return [];
   }
   if( fmt == 2 ) return rdline(popen("date -r "+filename+" +%F",0));
   if( fmt == 3 ) return rdline(popen("date -r "+filename+" +%FT%T",0));
   return atoi(rdline(popen("date -r "+filename+" +%s",0)));
}

/* Function cronjob */

func cronjob( sys_string, interval, ntimes=, until= )
/* DOCUMENT cronjob, sys_string, interval, ntimes=, until=

    Executes system,sys_string with a timeinterval of
    'interval' seconds. When keyword 'ntimes' is given then
    the command will be repeated this number of times.
    When keyword 'until' is given, then the command is repeated
    until this number of seconds have elapsed since the
    function was called. A second option for 'until' is
    to give a string like "100m" i.e. number followed by unit.
    "s", "m", "h", "d" (seconds, minutes, hours, days) are
    accepted.

    2012-11-12/NJW
*/
{
   local tstart, tnow;
   nti = 0;
   timestamp, tstart;
   if( until ) {
      if( typeof(until) == "string" ) {
         uni = strpart(until,0:0);
         until = atoi(strpart(until,1:-1));
         if( uni == "s" ) {
         } else if( uni == "m" ) {
            until *= 60;
         } else if( uni == "h" ) {
            until *= 3600;
         } else if( uni == "d" ) {
            until *= 86400;
         } else error,"Illegal unit";
      }
      tstop = tstart + until;
   }

   do {
      system, sys_string;
      nti++;
      timestamp, tnow;
      pause, interval*1000; // convert to ms
      done = 0;
      if( ntimes ) done = nti > ntimes;
      if( until ) done = tnow >= tstop;
   } while( !done );
}

/* Function vsave */

func vsave( a, file )
/* DOCUMENT vsave, a, file

    Uses yorick's 'save' command to save variable 'a' to
    the binary file 'file' (under the name of 'a').

    SEE ALSO: vrest (for restoring)
*/
{
   stream = createb(file);
   save,stream,a;
   close,stream;
}

/* Function vrest */

func vrest( &a, file )
/* DOCUMENT vrest, >a, file

    Uses yorick's 'restore' command to restore variable 'a' from
    the binary file 'file' (under the name of 'a').

    SEE ALSO: vsave (for saving a variable)
*/
{
   stream = openb(file);
   restore,stream,a;
   close,stream;
}

/* Function plural */

func plural( n )
/* DOCUMENT ending = plural( n )

     returns "s" if n == 0 or abs(n) > 1, "" otherwise i.e. when abs(n) == 1

*/
{ return abs(n) == 1 ? "" : "s" ; }
%FILE% bicub.i
// Fast bicubic interpolation routine for equidistantly sampled 2D functions
// Author: Georg Michel <georg@itpgyro1.fzk.de>
// Date: 10/19/97

func bicub(x0,y0,z,xmin,xmax,ymin,ymax) 
/* DOCUMENT z0=bicub(x0,y0,z,xmin,xmax,ymin,ymax)
  gives the bicubic interpolate of the two dimensional array Z, which is
  an equidistantly sampled (complex) function, at point(s) (X0,Y0). First index
  corresponds to x, second index corresponds to y. XMIN corresponds to z(1,)
  YMAX corresponds to z(,dimsof(z)(3)).  For the sake of speed, the user is
  responsible for not having any points (X0,Y0) in the outermost regions
  and beyond.  
*/
{
  i0= int((x0-xmin)/(xmax-xmin)*(dimsof(z)(2)-1))+1;
  // for j0 the +1 is omitted because of the indexing scheme for zvec
  j0= int((y0-ymin)/(ymax-ymin)*(dimsof(z)(3)-1));
  t= ((x0-xmin)/(xmax-xmin)*(dimsof(z)(2)-1))%1;
  u= ((y0-ymin)/(ymax-ymin)*(dimsof(z)(3)-1))%1;
  posvec= [t^3*u^3, t^3*u^2, t^3*u, t^3, t^2*u^3, t^2*u^2, t^2*u, t^2, 
           t*u^3, t*u^2, t*u, t, u^3, u^2, u, 1];
  fd=dimsof(z)(2);
  zvec= [.2777777778e-1*z(i0-1+ fd*(j0-1))-.8333333333e-1*z(i0+
        fd*(j0-1))+ .8333333333e-1*z(i0+ 1+
        fd*(j0-1))-.2777777778e-1*z(i0+ 2+
        fd*(j0-1))-.8333333333e-1*z(i0-1+ fd*j0)+ .25*z(i0+
        fd*j0)-.25*z(i0+ 1+ fd*j0)+ .8333333333e-1*z(i0+ 2+
        fd*j0)+ .8333333333e-1*z(i0-1+ fd*(j0+ 1))-.25*z(i0+
        fd*(j0+ 1))+ .25*z(i0+ 1+ fd*(j0+
        1))-.8333333333e-1*z(i0+ 2+ fd*(j0+ 1))-.2777777778e-1*z(i0-1+
        fd*(j0+ 2))+ .8333333333e-1*z(i0+ fd*(j0+
        2))-.8333333333e-1*z(i0+ 1+ fd*(j0+ 2))+ .2777777778e-1*z(i0+
        2+ fd*(j0+ 2)), -.8333333333e-1*z(i0-1+ fd*(j0-1))+
        .25*z(i0+ fd*(j0-1))-.25*z(i0+ 1+ fd*(j0-1))+
        .8333333333e-1*z(i0+ 2+ fd*(j0-1))+ .1666666667*z(i0-1+
        fd*j0)-.5*z(i0+ fd*j0)+ .5*z(i0+ 1+
        fd*j0)-.1666666667*z(i0+ 2+ fd*j0)-.8333333333e-1*z(i0-1+
        fd*(j0+ 1))+ .25*z(i0+ fd*(j0+ 1))-.25*z(i0+
        1+ fd*(j0+ 1))+ .8333333333e-1*z(i0+ 2+ fd*(j0+ 1)),
        .5555555556e-1*z(i0-1+ fd*(j0-1))-.1666666667*z(i0+
        fd*(j0-1))+ .1666666667*z(i0+ 1+
        fd*(j0-1))-.5555555556e-1*z(i0+ 2+ fd*(j0-1))+
        .8333333333e-1*z(i0-1+ fd*j0)-.25*z(i0+ fd*j0)+
        .25*z(i0+ 1+ fd*j0)-.8333333333e-1*z(i0+ 2+
        fd*j0)-.1666666667*z(i0-1+ fd*(j0+ 1))+ .5*z(i0+
        fd*(j0+ 1))-.5*z(i0+ 1+ fd*(j0+ 1))+
        .1666666667*z(i0+ 2+ fd*(j0+ 1))+ .2777777778e-1*z(i0-1+
        fd*(j0+ 2))-.8333333333e-1*z(i0+ fd*(j0+ 2))+
        .8333333333e-1*z(i0+ 1+ fd*(j0+ 2))-.2777777778e-1*z(i0+ 2+
        fd*(j0+ 2)), -.1666666667*z(i0-1+ fd*j0)+ .5*z(i0+
        fd*j0)-.5*z(i0+ 1+ fd*j0)+ .1666666667*z(i0+ 2+
        fd*j0), -.8333333333e-1*z(i0-1+ fd*(j0-1))+ .1666666667*z(i0+
        fd*(j0-1))-.8333333333e-1*z(i0+ 1+ fd*(j0-1))+
        .25*z(i0-1+ fd*j0)-.5*z(i0+ fd*j0)+
        .25*z(i0+ 1+ fd*j0)-.25*z(i0-1+ fd*(j0+ 1))+
        .5*z(i0+ fd*(j0+ 1))-.25*z(i0+ 1+ fd*(j0+
        1))+ .8333333333e-1*z(i0-1+ fd*(j0+ 2))-.1666666667*z(i0+
        fd*(j0+ 2))+ .8333333333e-1*z(i0+ 1+ fd*(j0+ 2)),
        .25*z(i0-1+ fd*(j0-1))-.5*z(i0+ fd*(j0-1))+
        .25*z(i0+ 1+ fd*(j0-1))-.5*z(i0-1+ fd*j0)+
        1.*z(i0+ fd*j0)-.5*z(i0+ 1+ fd*j0)+
        .25*z(i0-1+ fd*(j0+ 1))-.5*z(i0+ fd*(j0+ 1))+
        .25*z(i0+ 1+ fd*(j0+ 1)), -.1666666667*z(i0-1+
        fd*(j0-1))+ .3333333333*z(i0+ fd*(j0-1))-.1666666667*z(i0+ 1+
        fd*(j0-1))-.25*z(i0-1+ fd*j0)+ .5*z(i0+
        fd*j0)-.25*z(i0+ 1+ fd*j0)+ .5*z(i0-1+
        fd*(j0+ 1))-1.*z(i0+ fd*(j0+ 1))+ .5*z(i0+ 1+ fd*(j0+
        1))-.8333333333e-1*z(i0-1+ fd*(j0+ 2))+ .1666666667*z(i0+
        fd*(j0+ 2))-.8333333333e-1*z(i0+ 1+ fd*(j0+ 2)),
        .5*z(i0-1+ fd*j0)-1.*z(i0+ fd*j0)+ .5*z(i0+
        1+ fd*j0), .5555555556e-1*z(i0-1+ fd*(j0-1))+
        .8333333333e-1*z(i0+ fd*(j0-1))-.1666666667*z(i0+ 1+
        fd*(j0-1))+ .2777777778e-1*z(i0+ 2+
        fd*(j0-1))-.1666666667*z(i0-1+ fd*j0)-.25*z(i0+
        fd*j0)+ .5*z(i0+ 1+ fd*j0)-.8333333333e-1*z(i0+ 2+
        fd*j0)+ .1666666667*z(i0-1+ fd*(j0+ 1))+ .25*z(i0+
        fd*(j0+ 1))-.5*z(i0+ 1+ fd*(j0+ 1))+
        .8333333333e-1*z(i0+ 2+ fd*(j0+ 1))-.5555555556e-1*z(i0-1+
        fd*(j0+ 2))-.8333333333e-1*z(i0+ fd*(j0+ 2))+
        .1666666667*z(i0+ 1+ fd*(j0+ 2))-.2777777778e-1*z(i0+ 2+
        fd*(j0+ 2)), -.1666666667*z(i0-1+ fd*(j0-1))-.25*z(i0+
        fd*(j0-1))+ .5*z(i0+ 1+
        fd*(j0-1))-.8333333333e-1*z(i0+ 2+ fd*(j0-1))+
        .3333333333*z(i0-1+ fd*j0)+ .5*z(i0+ fd*j0)-1.*z(i0+
        1+ fd*j0)+ .1666666667*z(i0+ 2+ fd*j0)-.1666666667*z(i0-1+
        fd*(j0+ 1))-.25*z(i0+ fd*(j0+ 1))+ .5*z(i0+
        1+ fd*(j0+ 1))-.8333333333e-1*z(i0+ 2+ fd*(j0+ 1)),
        .1111111111*z(i0-1+ fd*(j0-1))+ .1666666667*z(i0+
        fd*(j0-1))-.3333333333*z(i0+ 1+ fd*(j0-1))+
        .5555555556e-1*z(i0+ 2+ fd*(j0-1))+ .1666666667*z(i0-1+
        fd*j0)+ .25*z(i0+ fd*j0)-.5*z(i0+ 1+ fd*j0)+
        .8333333333e-1*z(i0+ 2+ fd*j0)-.3333333333*z(i0-1+ fd*(j0+
        1))-.5*z(i0+ fd*(j0+ 1))+ 1.*z(i0+ 1+ fd*(j0+
        1))-.1666666667*z(i0+ 2+ fd*(j0+ 1))+ .5555555556e-1*z(i0-1+
        fd*(j0+ 2))+ .8333333333e-1*z(i0+ fd*(j0+
        2))-.1666666667*z(i0+ 1+ fd*(j0+ 2))+ .2777777778e-1*z(i0+ 2+
        fd*(j0+ 2)), -.3333333333*z(i0-1+ fd*j0)-.5*z(i0+
        fd*j0)+ 1.*z(i0+ 1+ fd*j0)-.1666666667*z(i0+ 2+ fd*j0),
        -.1666666667*z(i0+ fd*(j0-1))+ .5*z(i0+
        fd*j0)-.5*z(i0+ fd*(j0+ 1))+ .1666666667*z(i0+
        fd*(j0+ 2)), .5*z(i0+ fd*(j0-1))-1.*z(i0+ fd*j0)+
        .5*z(i0+ fd*(j0+ 1)), -.3333333333*z(i0+
        fd*(j0-1))-.5*z(i0+ fd*j0)+ 1.*z(i0+ fd*(j0+
        1))-.1666666667*z(i0+ fd*(j0+ 2)),1.*z(i0+ fd*j0)];
  return((posvec*zvec)(..,sum)); 
}
%FILE% binning.i
func binning( energy, elo, ehi, &res_err )
/* DOCUMENT res = binning( energy, elo, ehi, >res_err )

   Produces a histogram of the array 'energy' where the boundaries
   are given in 'elo' and 'ehi'.
   Returns a (double) array with same number of elements as each of 'elo'
   and 'ehi' has.
   The statistical error is returned in 'res_err'.

     2007-02-15/NJW
*/

{
   if( anyof(dimsof(elo)-dimsof(ehi)) ) {
      write,"Mismatching boundaries";
      return [];
   }
   n = numberof(elo);
   res = array(double, n);
   for( i = 1; i <= n; i++ ) {
      w = where( energy >= elo(i) & energy < ehi(i) );
      nw = numberof(w);
      if( nw > 0 ) res(i) = double(nw);
   }

   res_err = sqrt(res);
   return res;

}
%FILE% bmptools.i
#include "image.i"
#include "plot.i"
#include "idlx.i"
#include "fconvol.i"

write,"";
write,"The BMP manipulation package is now loaded.";
write,"hdr = bmp_open( filename, >stream ) returns struct bmphdr";
write,"ima = get_bmp_segment( stream, hdr, i0, j0, width, height) returns partial image";
write,"";
write,"Conversion from JPEG to BMP by the 'xv' program (greyscale) works fine";
write,"";


struct bmphdr {
   int bfSize;
   int bfOffBytes;
   int biSize;
   int biWidth;
   int biHeight;
   short biBitCount;
}

func bmp_open( filename, &stream )
/* DOCUMENT hdr = bmp_open( filename, &filestream )
   opens a BMP file and returns a struct {bfSize, bfOffBytes,
   biSize, biWidth, iHeight, biBitCount}

   2005-07-23/NJW
*/
{

   stream = open( filename, "rb" );
   i86_primitives, stream;
   address = 0;
   bfType = array(char,2);
   n = _read(stream,0,bfType);
   nwr = write(format="%i bfType: %c%c Identification, must be BM\n", n, bfType(1), bfType(2));
   bfSize = int(0);
   address += sizeof(bfType);
   n = _read(stream,address,bfSize);
   nwr = write(format="%i bfSize: %i File size in bytes\n", n, bfSize );
   bfRes = array(short,2);
   address += sizeof(bfSize);
   n = _read(stream,address,bfRes);
   nwr = write(format="%i bfRes: %i %i Reserved, must be 0 0\n", n, bfRes(1), bfRes(2));
   bfOffBytes = int(0);
   address += sizeof(bfRes);
   n = _read(stream,address,bfOffBytes);
   nwr = write(format="%i bfOffBytes: %i Offset to start of pixel data in bytes\n", n, bfOffBytes );
   biSize = int(0);
   address += sizeof(bfOffBytes);
   n = _read(stream,address,biSize);
   nwr = write(format="%i biSize: %i Header size, must be at least 40\n", n, biSize );
   biWidth = int(0);
   address += sizeof(biSize);
   n = _read(stream,address,biWidth);
   nwr = write(format="%i biWidth: %i Image width in pixels\n", n, biWidth );
   biHeight = int(0);
   address += sizeof(biWidth);
   n = _read(stream,address,biHeight);
   nwr = write(format="%i biHeight: %i Image height in pixels\n", n, biHeight );
   biPlanes = short(0);
   address += sizeof(biHeight);
   n = _read(stream,address,biPlanes);
   nwr = write(format="%i biPlanes: %i Number of planes, must be 1\n", n, biPlanes );
   biBitCount = short(0);
   address += sizeof(biPlanes);
   n = _read(stream,address,biBitCount);
   nwr = write(format="%i biBitCount: %i Bits per pixel - 1,2,4,8,16,24, or 32\n", n, biBitCount );
   biCompression = int(0);
   address += sizeof(biBitCount);
   n = _read(stream,address,biCompression);
   nwr = write(format="%i biCompression: %i Compression type (0=uncompressed)\n", n, biCompression );

   return bmphdr(bfSize=bfSize, bfOffBytes=bfOffBytes, biSize=biSize, biWidth=biWidth, \
                 biHeight=biHeight, biBitCount=biBitCount);
}
//
// function to read segment of the image
//
func get_bmp_segment( stream, hdr, i0, j0, m, n )
/* DOCUMENT segment = get_bmp_segment( stream, hdr, i0, j0, m, n)

   where (i0,j0) is lower left corner of image (count starts with 0)
   and (m,n) is the size of (width, height)

   It is assumed that the BMP image has 8 bits per pixel

   2005-07-20/NJW
*/
{

   if( i0 + m > hdr.biWidth ) {
      print,"Too far to the right";
      return [];
   }
   if( j0 + n > hdr.biHeight ) {
      print,"Too far up";
      return [];
   }
   brow = array(char, m);
   im = array(short, m, n);

   for( q = 1; q <= n; q++ ) {

      nrd = _read( stream, (j0 + q - 1) * hdr.biWidth + i0 + hdr.bfOffBytes, brow );
      im(,q) = brow;

   }

   return im;

}
%FILE% boxoverlap.i
/* Function boxoverlap */

func boxoverlap( box1, box2 )
/* DOCUMENT boxoverlap
;
;   Returns 1 if( there is an overlap between box1 && box2
;
;   "box" is an array of 4 numbers [x1,y1,x2,y2]
;
*/
{

   if( numberof(box1)  !=  4 ) {
      write,"BOXOVERLAP first argument must have 4 elements";
      return -1;
   }

   if( numberof(box2)  !=  4 ) {
      write,"BOXOVERLAP second argument must have 4 elements";
      return -1;
   }

   // Test for one corner of a box inside the other box

   if( box1(1)  >=  box2(1) && box1(1)  <=  box2(3) && \
      box1(2)  >=  box2(2) && box1(2)  <=  box2(4)      ) return 1;

   if( box1(1)  >=  box2(1) && box1(1)  <=  box2(3) && \
      box1(4)  >=  box2(2) && box1(4)  <=  box2(4)      ) return 1;

   if( box1(3)  >=  box2(1) && box1(3)  <=  box2(3) && \
      box1(2)  >=  box2(2) && box1(2)  <=  box2(4)      ) return 1;

   if( box1(3)  >=  box2(1) && box1(3)  <=  box2(3) && \
      box1(4)  >=  box2(2) && box1(4)  <=  box2(4)      ) return 1;

   if( box2(1)  >=  box1(1) && box2(1)  <=  box1(3) && \
      box2(2)  >=  box1(2) && box2(2)  <=  box1(4)      ) return 1;

   if( box2(1)  >=  box1(1) && box2(1)  <=  box1(3) && \
      box2(4)  >=  box1(2) && box2(4)  <=  box1(4)      ) return 1;

   if( box2(3)  >=  box1(1) && box2(3)  <=  box1(3) && \
      box2(2)  >=  box1(2) && box2(2)  <=  box1(4)      ) return 1;

   if( box2(3)  >=  box1(1) && box2(3)  <=  box1(3) && \
      box2(4)  >=  box1(2) && box2(4)  <=  box1(4)      ) return 1;

   // Test for overlap with no points inside

   if( box1(1)  <  box2(1) && box1(3)  >  box2(3) && \
      box2(2)  <  box1(2) && box2(4)  >  box1(4)      ) return 1;

   if( box2(1)  <  box1(1) && box2(3)  >  box1(3) && \
      box1(2)  <  box2(2) && box1(4)  >  box2(4)      ) return 1;

   return 0;

}
%FILE% br.i
/*******************************************************************

   Regnskabsfoering til bridge

   2010-04-11/NJW
   2010-11-21/NJW opdatering til bedre version

   Angiv kontrakt, spilfoerer og antal vundne stik

   -----------------
   '1' er Nord/Syd, '2' er Oest/Vest

   Extern   Farzon[2,50]   Flag for 'i farezonen'
            Points[2,antal_spil] Points for hvert spil i en omgang
            Melding[antal_spil] Melding i hvert spil
            Antalstik[antal_spil] Antal stik (for spilfoerer) i hvert spil
            Spilnummer

   Bygges op som kommando 'r' Regnskab -> Meldt, resultat, Points, Farezone
                                          summerede points
                          'g' Gem regnskab i.e. skriv til fil
                          'n' Nyt spil -> indtastning af nyt resultat
                          'x' Exit
                          '?' Skriv disse muligheder

********************************************************************/

if( is_void(Farzon) ) {
   Farzon = array(long,2,50);
    //  N/S svarer til indeks 1
    //  O/V svarer til indeks 2
   Points = array(long,2,50);
   HPoints = array(long,4,50);
   Melding = array(long,50);
   Antalstik = array(long,50);
   Kontr_haver = array(long,50);
   farvekode = ["s","h","r","k","u"," "];
   spillerkode = ["S","V","N","O","-"];
   Spilnummer = 0;
}

/* Function nyt_spil */

func nyt_spil( void ) // comn  -  skriv resultat fra nyt spil
{
   extern Spilnummer, Udvidet;

   if( is_void(Spilnummer) ) Spilnummer = 0;
   Spilnummer++;
   write,format="Dette er spil nummer %i\n", Spilnummer;

   svar = "";
   do {
      read,prompt="Kontrakthaver : ... ", svar;
      svar = strlowcase( strpart(svar,1:1) );
      igen = 0;
      if( svar == "s" ) {
         kontr_haver = 1; // Syd
      } else if( svar == "v" ) {
         kontr_haver = 2; // Vest
      } else if( svar == "n" ) {
         kontr_haver = 3; // Nord
      } else if( svar == "o" ) {
         kontr_haver = 4; // Oest
      } else if( svar == "-" ) {
         kontr_haver = 5; // Oest
      } else {
         write,"Ups, proev igen ('s', 'v', 'n', 'o' eller '-') ...";
         igen = 1;
      }
   } while( igen );
   Kontr_haver(Spilnummer) = kontr_haver;
   if( kontr_haver == 5 ) return;

   do {
      read,prompt="Slutmelding : ... ", svar;
      svar = strlowcase( svar );
      strnstik = strpart(svar,1:1);
      igen = 0;
      if( !is_digit(strnstik) ) {
         igen = 1;
         write,"Der forventes et antal traek og en farvekode, f.eks. '4h'";
         write,"Er der doblet eller redoblet tilfoejes 'd' eller 'r'";
         write,"f.eks. '6ud'";
      } else {
         ntraek_kontrakt = atoi(strnstik);
         farve = strpart(svar,2:2);
         ifarve = where( farve == farvekode )(1);
         doblet = 0;
         if( strlen(svar) == 3 ) {
            dobstr = strpart(svar,3:3);
            if( dobstr == "d" ) {
               doblet = 100;
            } else if( dobstr == "r" ) {
               doblet = 200;
            } else {
               igen = 1;
               write,"Det tredje tegn skal vaere 'd' eller 'r'";
               ifarve = [];
            }
         }
         if( numberof(ifarve) == 0 ) {
            igen = 1;
            write,"Farvekoden kan vaere en af 'shrku' ('u' for sans)";
         } else {
            // enere: antal traek
            // tiere: farven
            // hundreder: +100 doblet, +200 redoblet
            Melding(Spilnummer) = doblet + ifarve*10 + ntraek_kontrakt;
            n = 0;
            read,prompt="Antal stik taget: ... ", n;
            Antalstik(Spilnummer) = n;
            write,format="Antal traek: %i\n", n - 6;
            vundne = n - ntraek_kontrakt - 6;
            igen = 0;
         }
      }
   } while( igen);

   if( Udvidet ) { // Spoerg efter honnoer points
      igen = 1;
      do {
         write,"Tast honnoerpoints for S, V, N, og O:";
         ind = rdline(prompt="                   -> ");
         hp1 = hp2 = hp3 = hp4 = 0;
         sread, ind, format="%i %i %i %i", hp1, hp2, hp3, hp4;
         hpsum = hp1+hp2+hp3+hp4;
         if( hpsum != 40 ) {
            write,"Ups, en skrivefejl - proev igen ...";
         } else {
            HPoints(1,Spilnummer) = hp1;
            HPoints(2,Spilnummer) = hp2;
            HPoints(3,Spilnummer) = hp3;
            HPoints(4,Spilnummer) = hp4;
            igen = 0;
         }
      } while( igen );
   }
}

/* Function beregn_points */

func beregn_points( void )
{
   extern Spilnummer;

   if( Kontr_haver(Spilnummer) == 5 ) return 0; // pas over hele linjen

   udgang_traek = [4,4,5,5,3];

   kh_indeks = 2 - Kontr_haver(Spilnummer)%2;
   i_farzon = Farzon(kh_indeks,Spilnummer);
   melding = Melding(Spilnummer);
   // ---   se om der er blevet doblet/redoblet
   doblet = melding/100;
   melding -= 100*doblet;
   // ---   find farven
   ifarve = melding / 10;
   // ---   find antal meldte traek
   ntraek_kontrakt = melding - 10*ifarve;
   // ---   find antal vundne traek
   antal_traek = Antalstik(Spilnummer) - 6;

   // find antal traek i kontrakten
   // og beregn points opnaaet med disse, da de er afgoerende
   // for om der er udgang (kraever 100 points i traekvaerdi)

   if( ifarve <= 2 ) { // spar eller hjerter
      points_per_stik = 30;
      if( doblet == 1 ) points_per_stik *= 2;
      if( doblet == 2 ) points_per_stik *= 4;
      points_foerste_stik = 30;
      if( doblet == 1 ) points_foerste_stik *= 2;
      if( doblet == 2 ) points_foerste_stik *= 4;
   } else if( 2 < ifarve && ifarve <= 4 ) { // ruder eller kloer
      points_per_stik = 20;
      if( doblet == 1 ) points_per_stik *= 2;
      if( doblet == 2 ) points_per_stik *= 4;
      points_foerste_stik = 20;
      if( doblet == 1 ) points_foerste_stik *= 2;
      if( doblet == 2 ) points_foerste_stik *= 4;
   } else {
      points_per_stik = 30;
      if( doblet == 1 ) points_per_stik *= 2;
      if( doblet == 2 ) points_per_stik *= 4;
      points_foerste_stik = 40;
      if( doblet == 1 ) points_foerste_stik *= 2;
      if( doblet == 2 ) points_foerste_stik *= 4;
   }
  /*
   *  -----  Er kontrakten vundet?
   */

   if( antal_traek >= ntraek_kontrakt ) { // Vundet! points laegges til

      write,"Spillet er vundet!";
      antal_overtraek = antal_traek - ntraek_kontrakt;
      // points for stik = traekvaerdi
      //+ Points(kh_indeks,Spilnummer) = points_foerste_stik;
      //+ Points(kh_indeks,Spilnummer) += points_per_stik*(antal_traek - 1);
      traekvaerdi = points_foerste_stik;
      traekvaerdi += points_per_stik*(antal_traek - 1);
      kontrakt_traekvaerdi = points_foerste_stik;
      kontrakt_traekvaerdi += points_per_stik*(ntraek_kontrakt - 1);

      write,"Traekvaerdi for kontrakt : ", kontrakt_traekvaerdi;
      write,"Traekvaerdi for spillet  : ", traekvaerdi;
      if( kontrakt_traekvaerdi >= 100 ) {
         udgang = 1; // tilstraekkeligt til udgang
         bonus = 300;
         if( i_farzon ) bonus += 200;
         // fra nu af er dette makkerpar i farezonen
         Farzon(kh_indeks,Spilnummer+1:0) = 1;
         write,"Godt nok til udgang med bonus ", bonus;
         if( !i_farzon ) write,"Er fra nu af i farezonen";
      } else {
         udgang = 0; // nej - ikke udgang
         bonus = 50; // bonus for vundet delkontrakt
         write,"Delkontrakt med bonus    ", bonus;
      }

      // Lilleslem!

      s_bonus = 0;
      if( ntraek_kontrakt == 6 ) {
         s_bonus = 500;
         if( i_farzon ) s_bonus += 250;
         write,"Lilleslem!!   Bonus  ", s_bonus;
      }

      // Storeslem!

      if( ntraek_kontrakt == 7 ) {
         s_bonus = 1000;
         if( i_farzon ) s_bonus += 500;
         write,"Storeslem!!   Bonus  ", s_bonus;
      }

      bonus += s_bonus;

      if( doblet == 1 ) {
         bonus += antal_overtraek*100;
         bonus += 50;
         write,"Bonus for doblet : ", 50+antal_overtraek*100;
      }
      if( doblet == 2 ) {
         bonus += antal_overtraek*200;
         bonus += 100;
         write,"Bonus for redoblet : ", 100+antal_overtraek*200;
      }
      Points(kh_indeks,Spilnummer) = traekvaerdi + bonus;

   } else { // Tabt! points traekkes fra

      antal_undertraek = ntraek_kontrakt - antal_traek;
      sunob = 0;
      if( doblet == 0 ) {
         vaerdi = i_farzon ? 100 : 50;
         sunob += antal_undertraek * vaerdi;
      } else if( doblet == 1 ) {  // Doblet
         vaerdi = i_farzon ? 200 : 100;
         sunob += vaerdi; // foerste undertraek
         if( antal_undertraek > 1 ) { // andet undertraek
            vaerdi = i_farzon ? 300 : 200;
            sunob += vaerdi;
         }
         if( antal_undertraek > 2 ) { // tredje undertraek
            vaerdi = i_farzon ? 300 : 200;
            sunob += vaerdi;
         }
         if( antal_undertraek > 3 ) { // yderligere undertraek
            vaerdi = i_farzon ? 300 : 300;
            sunob += vaerdi*(antal_undertraek-3);
         }
      } else { //   Redoblet
         vaerdi = i_farzon ? 400 : 200;
         sunob += vaerdi; // foerste undertraek
         if( antal_undertraek > 1 ) { // yderligere undertraek
            vaerdi = i_farzon ? 600 : 400;
            sunob += vaerdi*(antal_undertraek-3);
         }
      }

      Points(kh_indeks,Spilnummer) = -sunob;
   }

   return Points(kh_indeks,Spilnummer);
}

func vis_regnskab( filnavn ) //  comr  -  vis regnskab paa skaermen
                             // eller skriv til fil
{
   extern Spilnummer, Udvidet;

   kh_navn = ["N/S","O/V"," - "];
   dob_str = ["  ","X ","XX"];

   if( is_void(filnavn) ) {
      stream = [];
   } else {
      stream = open(filnavn,"w");
      write,stream,format="Resultat af bridge %s\n", ndate(3);
      write,stream,"";
   }

   if( Spilnummer > 0 ) {
      write,stream,"Spil  KontrHaver Kontrakt   Antal stik    Points";
      for( i = 1; i <= Spilnummer; i++ ) {
         if( Kontr_haver(i) == 5 ){
            kh_indeks = 1;
            ifarve = 6;
            fz_str = " ";
            ntraek = 0;
            dobling = 0;
         } else {
            kh_indeks = 2 - Kontr_haver(i)%2;
            fz_str = Farzon(kh_indeks,i) == 1 ? "*" : " ";
            melding = Melding(i);
            dobling = melding/100;
            melding -= dobling*100;
            ifarve = melding/10;
            ntraek = melding - 10*ifarve;
         }
         write,stream,format="%4i       %s%s       %1i%s%s      %6i      %6i\n", \
            i, spillerkode(Kontr_haver(i)), fz_str, \
            ntraek, farvekode(ifarve), dob_str(dobling+1), \
            Antalstik(i), Points(kh_indeks,i);
         if( Udvidet ) {
            write,stream,format="        HP S: %2i,  V: %2i,  N: %2i,  O: %2i\n", \
                HPoints(1,i), HPoints(2,i), HPoints(3,i), HPoints(4,i);
         }
      }
      write,stream,"";
      write,stream,"     Stilling";
      write,stream,"";
      for( i = 1; i <= 2; i++ ) {
         write,stream,format=" %s    %5i points\n", \
           kh_navn(i), Points(i,sum);
      }
      write,stream,"";
   } else {
     write,"Der er ikke nogen spil endnu ...";
   }
   if( !is_void(stream) ) close,stream;
}

/*
 *   Hoved programmet
 */

/* Function spil */

func spil( udvidet )
{
   extern Spilnummer, Farzon, Udvidet;

   Udvidet = is_void(udvidet) ? 0 : udvidet;

   cont = 1;
   while( cont ) {
      kommando = rdline(prompt="Hvad nu? BR: ");
      if( kommando == "?" ) {
         write,"r  - regnskab";
         write,"n  - nyt spil";
         write,"g  - gem resultatet";
         write,"b  - begynd forfra";
         write,"x  - afslut";
      } else if( kommando == "x" ) {
         cont = 0;
      } else if( kommando == "n" ) { // comn - nyt spil
         nyt_spil;
         antal_points = beregn_points();
         write,format=" Antal points i alt: %i\n", antal_points;
      } else if( kommando == "r" ) {
         vis_regnskab;
      } else if( kommando == "g" ) { // comg - gem resultatet
         filnavn = get_next_filename("br_????.txt");
         vis_regnskab, filnavn;
         write,"Gemt i filen: "+filnavn;
      } else if( kommando == "b" ) { // comb - begynd forfra
         Spilnummer = 0;
         Farzon = array(long,2,50);
         write,"Klar til at begynde forfra ...";
      }
   }

}

write,"";
write,"   VELKOMMEN TIL BRIDGE REGNSKAB";
write,"";
write,"Kommandoer for 'spil':";
write,"     n   -  nyt spil";
write,"     r   -  regnskab";
write,"     g   -  gem regnskab i fil";
write,"     b   -  begynd forfra";
write,"     x   -  begynd afslut";
write,"     ?   -  denne oversigt";
write,"";
write,"  Begynd med at skrive 'spil[,1]'"
write,"";
write,"     Tilfoejelsen '1' betyder, at HP ogsaa skal tastes ind.";
write,"";
%FILE% bridge_regnskab.i
/*******************************************************************

   Regnskabsfoering til bridge

   2010-04-11/NJW
   2010-11-21/NJW opdatering til bedre version

   Angiv kontrakt, spilfoerer og antal vundne stik

   -----------------
   '1' er Nord/Syd, '2' er Oest/Vest

   Extern   Farzon[2,50]   Flag for 'i farezonen'
            Points[2,antal_spil] Points for hvert spil i en omgang
            Melding[antal_spil] Melding i hvert spil
            Antalstik[antal_spil] Antal stik (for spilfoerer) i hvert spil
            Spilnummer

   Bygges op som kommando 'r' Regnskab -> Meldt, resultat, Points, Farezone
                                          summerede points
                          'g' Gem regnskab i.e. skriv til fil
                          'n' Nyt spil -> indtastning af nyt resultat
                          'x' Exit
                          '?' Skriv disse muligheder

********************************************************************/

if( is_void(Farzon) ) {
   Farzon = array(long,2,50);
    //  N/S svarer til indeks 1
    //  O/V svarer til indeks 2
   Points = array(long,2,50);
   HPoints = array(long,4,50);
   Melding = array(long,50);
   Antalstik = array(long,50);
   Kontr_haver = array(long,50);
   farvekode = ["s","h","r","k","u"," "];
   spillerkode = ["S","V","N","O","-"];
   Spilnummer = 0;
}

/* Function nyt_spil */

func nyt_spil( void ) // comn  -  skriv resultat fra nyt spil
{
   extern Spilnummer, Udvidet;

   if( is_void(Spilnummer) ) Spilnummer = 0;
   Spilnummer++;
   write,format="Dette er spil nummer %i\n", Spilnummer;

   svar = "";
   do {
      read,prompt="Kontrakthaver : ... ", svar;
      svar = strlowcase( strpart(svar,1:1) );
      igen = 0;
      if( svar == "s" ) {
         kontr_haver = 1; // Syd
      } else if( svar == "v" ) {
         kontr_haver = 2; // Vest
      } else if( svar == "n" ) {
         kontr_haver = 3; // Nord
      } else if( svar == "o" ) {
         kontr_haver = 4; // Oest
      } else if( svar == "-" ) {
         kontr_haver = 5; // Oest
      } else {
         write,"Ups, proev igen ('s', 'v', 'n', 'o' eller '-') ...";
         igen = 1;
      }
   } while( igen );
   Kontr_haver(Spilnummer) = kontr_haver;
   if( kontr_haver == 5 ) return;

   do {
      read,prompt="Slutmelding : ... ", svar;
      svar = strlowcase( svar );
      strnstik = strpart(svar,1:1);
      igen = 0;
      if( !is_digit(strnstik) ) {
         igen = 1;
         write,"Der forventes et antal traek og en farvekode, f.eks. '4h'";
         write,"Er der doblet eller redoblet tilfoejes 'd' eller 'r'";
         write,"f.eks. '6ud'";
      } else {
         ntraek_kontrakt = atoi(strnstik);
         farve = strpart(svar,2:2);
         ifarve = where( farve == farvekode )(1);
         doblet = 0;
         if( strlen(svar) == 3 ) {
            dobstr = strpart(svar,3:3);
            if( dobstr == "d" ) {
               doblet = 100;
            } else if( dobstr == "r" ) {
               doblet = 200;
            } else {
               igen = 1;
               write,"Det tredje tegn skal vaere 'd' eller 'r'";
               ifarve = [];
            }
         }
         if( numberof(ifarve) == 0 ) {
            igen = 1;
            write,"Farvekoden kan vaere en af 'shrku' ('u' for sans)";
         } else {
            // enere: antal traek
            // tiere: farven
            // hundreder: +100 doblet, +200 redoblet
            Melding(Spilnummer) = doblet + ifarve*10 + ntraek_kontrakt;
            n = 0;
            read,prompt="Antal stik taget: ... ", n;
            Antalstik(Spilnummer) = n;
            write,format="Antal traek: %i\n", n - 6;
            vundne = n - ntraek_kontrakt - 6;
            igen = 0;
         }
      }
   } while( igen);

   if( Udvidet ) { // Spoerg efter honnoer points
      igen = 1;
      do {
         write,"Tast honnoerpoints for S, V, N, og O:";
         ind = rdline(prompt="                   -> ");
         hp1 = hp2 = hp3 = hp4 = 0;
         sread, ind, format="%i %i %i %i", hp1, hp2, hp3, hp4;
         hpsum = hp1+hp2+hp3+hp4;
         if( hpsum != 40 ) {
            write,"Ups, en skrivefejl - proev igen ...";
         } else {
            HPoints(1,Spilnummer) = hp1;
            HPoints(2,Spilnummer) = hp2;
            HPoints(3,Spilnummer) = hp3;
            HPoints(4,Spilnummer) = hp4;
            igen = 0;
         }
      } while( igen );
   }
}

/* Function beregn_points */

func beregn_points( void )
{
   extern Spilnummer;

   if( Kontr_haver(Spilnummer) == 5 ) return 0; // pas over hele linjen

   udgang_traek = [4,4,5,5,3];

   kh_indeks = 2 - Kontr_haver(Spilnummer)%2;
   i_farzon = Farzon(kh_indeks,Spilnummer);
   melding = Melding(Spilnummer);
   // ---   se om der er blevet doblet/redoblet
   doblet = melding/100;
   melding -= 100*doblet;
   // ---   find farven
   ifarve = melding / 10;
   // ---   find antal meldte traek
   ntraek_kontrakt = melding - 10*ifarve;
   // ---   find antal vundne traek
   antal_traek = Antalstik(Spilnummer) - 6;

   // find antal traek i kontrakten
   // og beregn points opnaaet med disse, da de er afgoerende
   // for om der er udgang (kraever 100 points i traekvaerdi)

   if( ifarve <= 2 ) { // spar eller hjerter
      points_per_stik = 30;
      if( doblet == 1 ) points_per_stik *= 2;
      if( doblet == 2 ) points_per_stik *= 4;
      points_foerste_stik = 30;
      if( doblet == 1 ) points_foerste_stik *= 2;
      if( doblet == 2 ) points_foerste_stik *= 4;
   } else if( 2 < ifarve && ifarve <= 4 ) { // ruder eller kloer
      points_per_stik = 20;
      if( doblet == 1 ) points_per_stik *= 2;
      if( doblet == 2 ) points_per_stik *= 4;
      points_foerste_stik = 20;
      if( doblet == 1 ) points_foerste_stik *= 2;
      if( doblet == 2 ) points_foerste_stik *= 4;
   } else {
      points_per_stik = 30;
      if( doblet == 1 ) points_per_stik *= 2;
      if( doblet == 2 ) points_per_stik *= 4;
      points_foerste_stik = 40;
      if( doblet == 1 ) points_foerste_stik *= 2;
      if( doblet == 2 ) points_foerste_stik *= 4;
   }
  /*
   *  -----  Er kontrakten vundet?
   */

   if( antal_traek >= ntraek_kontrakt ) { // Vundet! points laegges til

      write,"Spillet er vundet!";
      antal_overtraek = antal_traek - ntraek_kontrakt;
      // points for stik = traekvaerdi
      //+ Points(kh_indeks,Spilnummer) = points_foerste_stik;
      //+ Points(kh_indeks,Spilnummer) += points_per_stik*(antal_traek - 1);
      traekvaerdi = points_foerste_stik;
      traekvaerdi += points_per_stik*(antal_traek - 1);
      kontrakt_traekvaerdi = points_foerste_stik;
      kontrakt_traekvaerdi += points_per_stik*(ntraek_kontrakt - 1);

      write,"Traekvaerdi for kontrakt : ", kontrakt_traekvaerdi;
      write,"Traekvaerdi for spillet  : ", traekvaerdi;
      if( kontrakt_traekvaerdi >= 100 ) {
         udgang = 1; // tilstraekkeligt til udgang
         bonus = 300;
         if( i_farzon ) bonus += 200;
         // fra nu af er dette makkerpar i farezonen
         Farzon(kh_indeks,Spilnummer+1:0) = 1;
         write,"Godt nok til udgang med bonus ", bonus;
         if( !i_farzon ) write,"Er fra nu af i farezonen";
      } else {
         udgang = 0; // nej - ikke udgang
         bonus = 50; // bonus for vundet delkontrakt
         write,"Delkontrakt med bonus    ", bonus;
      }

      // Lilleslem!

      s_bonus = 0;
      if( ntraek_kontrakt == 6 ) {
         s_bonus = 500;
         if( i_farzon ) s_bonus += 250;
         write,"Lilleslem!!   Bonus  ", s_bonus;
      }

      // Storeslem!

      if( ntraek_kontrakt == 7 ) {
         s_bonus = 1000;
         if( i_farzon ) s_bonus += 500;
         write,"Storeslem!!   Bonus  ", s_bonus;
      }

      bonus += s_bonus;

      if( doblet == 1 ) {
         bonus += antal_overtraek*100;
         bonus += 50;
         write,"Bonus for doblet : ", 50+antal_overtraek*100;
      }
      if( doblet == 2 ) {
         bonus += antal_overtraek*200;
         bonus += 100;
         write,"Bonus for redoblet : ", 100+antal_overtraek*200;
      }
      Points(kh_indeks,Spilnummer) = traekvaerdi + bonus;

   } else { // Tabt! points traekkes fra

      antal_undertraek = ntraek_kontrakt - antal_traek;
      sunob = 0;
      if( doblet == 0 ) {
         vaerdi = i_farzon ? 100 : 50;
         sunob += antal_undertraek * vaerdi;
      } else if( doblet == 1 ) {  // Doblet
         vaerdi = i_farzon ? 200 : 100;
         sunob += vaerdi; // foerste undertraek
         if( antal_undertraek > 1 ) { // andet undertraek
            vaerdi = i_farzon ? 300 : 200;
            sunob += vaerdi;
         }
         if( antal_undertraek > 2 ) { // tredje undertraek
            vaerdi = i_farzon ? 300 : 200;
            sunob += vaerdi;
         }
         if( antal_undertraek > 3 ) { // yderligere undertraek
            vaerdi = i_farzon ? 300 : 300;
            sunob += vaerdi*(antal_undertraek-3);
         }
      } else { //   Redoblet
         vaerdi = i_farzon ? 400 : 200;
         sunob += vaerdi; // foerste undertraek
         if( antal_undertraek > 1 ) { // yderligere undertraek
            vaerdi = i_farzon ? 600 : 400;
            sunob += vaerdi*(antal_undertraek-3);
         }
      }

      Points(kh_indeks,Spilnummer) = -sunob;
   }

   return Points(kh_indeks,Spilnummer);
}

func vis_regnskab( filnavn ) //  comr  -  vis regnskab paa skaermen
                             // eller skriv til fil
{
   extern Spilnummer, Udvidet;

   kh_navn = ["N/S","O/V"," - "];
   dob_str = ["  ","X ","XX"];

   if( is_void(filnavn) ) {
      stream = [];
   } else {
      stream = open(filnavn,"w");
      write,stream,format="Resultat af bridge %s\n", ndate(3);
      write,stream,"";
   }

   if( Spilnummer > 0 ) {
      write,stream,"Spil  KontrHaver Kontrakt   Antal stik    Points";
      for( i = 1; i <= Spilnummer; i++ ) {
         if( Kontr_haver(i) == 5 ){
            kh_indeks = 1;
            ifarve = 6;
            fz_str = " ";
            ntraek = 0;
            dobling = 0;
         } else {
            kh_indeks = 2 - Kontr_haver(i)%2;
            fz_str = Farzon(kh_indeks,i) == 1 ? "*" : " ";
            melding = Melding(i);
            dobling = melding/100;
            melding -= dobling*100;
            ifarve = melding/10;
            ntraek = melding - 10*ifarve;
         }
         write,stream,format="%4i       %s%s       %1i%s%s      %6i      %6i\n", \
            i, spillerkode(Kontr_haver(i)), fz_str, \
            ntraek, farvekode(ifarve), dob_str(dobling+1), \
            Antalstik(i), Points(kh_indeks,i);
         if( Udvidet ) {
            write,stream,format="        HP S: %2i,  V: %2i,  N: %2i,  O: %2i\n", \
                HPoints(1,i), HPoints(2,i), HPoints(3,i), HPoints(4,i);
         }
      }
      write,stream,"";
      write,stream,"     Stilling";
      write,stream,"";
      for( i = 1; i <= 2; i++ ) {
         write,stream,format=" %s    %5i points\n", \
           kh_navn(i), Points(i,sum);
      }
      write,stream,"";
   } else {
     write,"Der er ikke nogen spil endnu ...";
   }
   if( !is_void(stream) ) close,stream;
}

/*
 *   Hoved programmet
 */

/* Function spil */

func spil( udvidet )
{
   extern Spilnummer, Farzon, Udvidet;

   Udvidet = is_void(udvidet) ? 0 : udvidet;

   cont = 1;
   while( cont ) {
      kommando = rdline(prompt="Hvad nu? BR: ");
      if( kommando == "?" ) {
         write,"r  - regnskab";
         write,"n  - nyt spil";
         write,"g  - gem resultatet";
         write,"b  - begynd forfra";
         write,"x  - afslut";
      } else if( kommando == "x" ) {
         cont = 0;
      } else if( kommando == "n" ) { // comn - nyt spil
         nyt_spil;
         antal_points = beregn_points();
         write,format=" Antal points i alt: %i\n", antal_points;
      } else if( kommando == "r" ) {
         vis_regnskab;
      } else if( kommando == "g" ) { // comg - gem resultatet
         filnavn = get_next_filename("br_????.txt");
         vis_regnskab, filnavn;
         write,"Gemt i filen: "+filnavn;
      } else if( kommando == "b" ) { // comb - begynd forfra
         Spilnummer = 0;
         Farzon = array(long,2,50);
         write,"Klar til at begynde forfra ...";
      }
   }

}

write,"";
write,"   VELKOMMEN TIL BRIDGE REGNSKAB";
write,"";
write,"Kommandoer for 'spil':";
write,"     n   -  nyt spil";
write,"     r   -  regnskab";
write,"     g   -  gem regnskab i fil";
write,"     b   -  begynd forfra";
write,"     x   -  begynd afslut";
write,"     ?   -  denne oversigt";
write,"";
write,"  Begynd med at skrive 'spil[,1]'"
write,"";
write,"     Tilfoejelsen '1' betyder, at HP ogsaa skal tastes ind.";
write,"";
%FILE% bug_show.i
/**************************************************************

   Demonstrate the fits.i (version 1.16) writing of vector bins
   (2D array in a binary table column)

   2006-02-28/NJW

***************************************************************/

#include "fits.i"

dat = array(float, 3, 5); // Make 3 rows, each with 5 values
dat(1,) = float(indgen(5));
dat(2,) = dat(1,) + 1.0;
dat(3,) = dat(2,) + 1.0;
filename = "bug_show1.fits";

fh = fits_create(filename);
fh = fits_set(fh,"EXTEND",'T',"There may be extensions");
fits_write_header, fh;
fits_new_bintable, fh;
p = array(pointer, 1);

numcol = 1;
ttype = "TTYPE"+swrite(format="%i",numcol);
nrows = 3;
p(1) = &dat;
fits_set, fh, ttype, "COLDAT", "Name of column 1";


fits_write_bintable, fh, p;
fits_close, fh;
%FILE% build_distarr.i
/*
    Assume a map 360x180 covering a sphere
    Build array so that one can easily get the pixels
    that are within a certain angular distance from a given pixel.

    Take advantage of the rotational symmetry in longitude
    and mirror symmetry in latitude.

    Roughly:
    i = (floor(180 - lon) + 1) % 360
    j =  floor( 90 + lat) + 1

    lon(center) = 181 - i + 0.5
    lat(center) =   j - 91 + 0.5

    but see file 'conv.i'

    2008-03-05/NJW
*/

IIARR = [];
JJARR = [];
WARR  = [];
IDXARR = array(1,180);

index = 1;
i0 = 180;
for( j0 = 1; j0 <= 180; j0++ ) {
   write,format="j0 = %4i\n", j0;
   IDXARR(j0) = index;
   conv, i0, j0, ri0, rj0; // basic position ri0, rj0
   for( ii = 1; ii <= 360; ii++ ) {
      for( jj = 1; jj <= 180; jj++ ) {
         conv, ii, jj, ri, rj; // position ri,rj
         dist = arcdist(ri0,rj0,ri,rj);
         if( dist > 5.0 ) continue;
         weight = 1.0 - 0.2*dist;
         index++;
         grow,IIARR,ii;
         grow,JJARR,jj;
         grow,WARR,weight;
      }
   }
}
file = createb("IJWarr.ysav");
save,file,IIARR,JJARR,WARR,IDXARR;
close,file;
write,"IIARR,JJARR,WARR,IDXARR have been saved into IJWarr.ysav";
%FILE% button_pack.i
/***************************************************

   2005-06-14/NJW

   A package for home-made button definition

****************************************************/

#include "idlx.i"
#include "plot.i"

/* A structure to hold each button: */

struct button {
      double xll;
      double yll;
      double xur;
      double yur;
      string text;
      double chsiz;
      long id;
}

func button_init( pos, text, charsize= )
/* DOCUMENT id = button_init( pos, text, charsize= )
;
;  Define a button on a graphics window
;
;  'pos' is [xloleft,yloleft,xupright,yupright]
;  'text' is text on button
;
*/

{

   extern button_arr;
   
   //
   //  Include the new button in the array of buttons
   //
   if(is_void(button_arr)) { //  First button defined
      button_arr = array(button,1);
      n = 1;
      button_arr(1).id = 1;
   } else {
      n = numberof(button_arr)+1;
      new_arr = array(button,n);
      new_arr(1:n-1) = button_arr;
      button_arr = new_arr;
      button_arr(n).id = 1 + max(button_arr.id);
   }
   button_arr(n).xll = pos(1);
   button_arr(n).yll = pos(2);
   button_arr(n).xur = pos(3);
   button_arr(n).yur = pos(4);
   button_arr(n).text = text;
   if( !is_void(charsize)) {
      button_arr(n).chsiz = charsize;
   } else {
      button_arr(n).chsiz = 1.0;
   }
   print,"New button got id = ", button_arr(n).id;
   //
   //  Add the button to the plot
   //
   oplot, [pos(1),pos(3),pos(3),pos(1),pos(1)],  \
          [pos(2),pos(2),pos(4),pos(4),pos(2)];
   xyouts,0.5*(pos(1)+pos(3)),pos(2)+0.2*(pos(4)-pos(2)), text, \
          align=0.5, charsize=charsize;

   return button_arr(n).id;

}


/* Function button_disp */

func button_disp(a)
/* DOCUMENT  button_disp
;
;  Display all buttons on the current graphics window
;

*/

{

   extern button_arr;
   
   
   n = numberof(button_arr);
   if( n == 0 ) {
      print,"No buttons defined!";
      return;
   }
   
   for( i = 1; i <= n; i++ ) {
      //
      //  Add the button to the plot
      //
      oplot, [button_arr(i).xll,button_arr(i).xur,button_arr(i).xur, \
              button_arr(i).xll,button_arr(i).xll], \
             [button_arr(i).yll,button_arr(i).yll,button_arr(i).yur, \
              button_arr(i).yur,button_arr(i).yll];
      xyouts,0.5*(button_arr(i).xll+button_arr(i).xur), \
                  button_arr(i).yll+0.2*(button_arr(i).yur-button_arr(i).yll), \
                  button_arr(i).text,\
                  align=0.5,charsize=button_arr(i).chsiz;
   
   }

}

/* Function button_query */

func button_query(a)
/* DOCUMENT id = button_query()
;
;  Ask for cursor action and return button pressed
;  Returns is identifier (id) of the button or 0 (zero)
;  if no button was hit.
;
*/

{

   n = numberof(button_arr);
   if( n == 0 ) {
      print,"No buttons defined!";
      return 0;
   }
   
   print," ... press a button on the plot ...";
   cpos = curmark1( nomark=1 );
   
   for( i = 1; i <= n; i++ ) {
      //
      //  Find the button that was pressed
      //
      if(     button_arr(i).xll < cpos(1) \
         && button_arr(i).xur > cpos(1) \
         && button_arr(i).yll < cpos(2) \
         && button_arr(i).yur > cpos(2) ) return button_arr(i).id;
   }
   
   return 0;

}
%FILE% c.i
#include "kfits.i"
#include "mfits.i"
#include "basic.i"
#include "plot.i"
#include "scom.i"
#include "image.i"
#include "random.i"
#include "jemx.i"
#include "mem_storage.i"
#include "string_2106.i"
#include "idlx.i"
#include "fconvol.i"
#include "xray.i"
#include "datafit.i"
#include "euler.i"
#include "organize.i"
#include "tempus.i"
#include "ebm.i"
#include "specfit.i"
#include "stat.i"
#include "mcomplex.i"
#include "util_fr_2106.i"
/*
 *  Define some useful external variables
 */
GISTDIR = "/home/njw/yorick/yorick-2.1/g/";
write,format="GISTDIR: %s\n", GISTDIR;
%FILE% c_code.i
extern c_codedoc;
/* DOCUMENT ******************************************************
 *
 *   Tools to facilitate the maintenance and cleaning of C-codes
 *
 *   Step one is to remove the comments by
 *         $ t2s mycode.c     # convert 'tab' to 'space'
 *         $ c_rm_comment mycode.c
 *   that produces the file mycode.cnc ready for these tools
 *
 *    report_var_names( filename, chat=, out=, limit= )
 *
 *
 *
 ****************************************************************/

// External variable for general use:
C_letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_";
C_types = ["long","int","short","short int","double","float", "unsigned", \
           "char", "unsigned char", "Events", "dal_element", "dal_dataType", \
           "OBTime", "TCOR_flag"];

func report_var_names( filename, chat=, out=, limit= )
/* DOCUMENT report_var_names, filename, chat=, out=, limit=

      filename:   A 'c_rm_comment' cleaned c code
          chat:   Verbosity level
           out:   output file name
         limit:   Max number of reported occurrences

*/
{
   code = rdfile( filename );
   ncode = numberof(code);

   if( typeof(out) == "string" ) {
      fout = open( out, "w" );
      o = 1;
   } else {
      fout = [];
      o = 0;
   }
   if( is_void(limit) ) limit = 2000000000;
   if( limit < 2 ) limit = 2;

   // find first '('

   i = 1;
   while( strpos(code(i),"(" ) == 0 ) i++;
      // now code(i) contains the starting '('
   if( strpos( code(i), ")") ) { // finishes on the same line
      fct_preamble = code(i);
   } else {
      fct_preamble = "";
      while( strpos(code(i),")" ) == 0 ) {
         fct_preamble += code(i);
         i++;
      }
      fct_preamble += code(i);
   }
   fct_preamble = strcompress(fct_preamble);
   if( chat ) {
      write,fout," ---   fct_preamble:"
      write,fout,fct_preamble;
   }
   pos1 = strpos(fct_preamble,"(");
   pos2 = strpos(fct_preamble,")");
   fct_name = get_word_before( fct_preamble, pos1 );
   write,fout,"Function name: "+fct_name;

   // scan to extract variables defined in the call

   var_str = strpart( fct_preamble, pos1+1:pos2-1 );
   v_arr = strsplit( var_str, "," );
   nv_arr = numberof( v_arr );
   vnames = [];
   for( j = 1; j <= nv_arr; j++ ) {
      if( chat ) write,fout,"v_arr: "+v_arr(j);
      vname = get_word_before( v_arr(j), 0 );
      if( chat ) write,fout,"     extracted var name: "+vname;
      // disregard 'chatter' and 'status'
      if( vname != "status" && vname != "chatter" ) grow, vnames, vname;
   }
   n_vnames = numberof( vnames );

   // find the start of the code i.e. the first '{'

   while( strpos(code(i), "{") == 0 ) i++;

   code_start = i;
   write,fout,"Code starts in line "+itoa(code_start);

   for( j = 1; j <= n_vnames; j++ ) {
      write,fout,"---------------------------------------------------"
      write,fout,"   CALL - Reporting on: "+vnames(j);
      write,fout,"---------------------------------------------------"
      heureka = 0;
      for( i = code_start; i <= ncode; i++ ) {
         if( locate_word( code(i), vnames(j) ) ) {
            heureka = 1;
            write,fout,format="%4i %s\n", i, code(i);
         }
      }
      if( !heureka ) write,fout,"  NB: not used";
   }

  /************************************************************
       Get variables from inside the code
       by identifying lines starting with one of 'C_types'

   ************************************************************/

   vnames = [];
   for( i = code_start; i <= ncode; i++ ) {
      line = strtrim( code(i) );
      w = get_word_after( line );
      if( is_void(w) ) continue;
      p = locate_word( line, w );
      // something before?
      if( p != 1 ) continue;
      m = where( C_types == w );
      if( numberof(m) != 1 ) continue;

      // now we have a declaration line
      if(chat)write,fout,"Decl.line: "+line;
      // check for ending ';', add following lines
      // until found
      psc = strpos( line, ";" );
      while( !psc ) {
         line += strtrim( code(++i) );
         psc = strpos( line, ";" );
      }
      if(chat)write,fout,"Completed decl.line: "+line;
      v_arr = strsplit( line,",");
      nv_arr = numberof(v_arr);
      for( j = 1; j <= nv_arr; j++ ) {
         // Assume at most a single pair of '[' ']' and
         // erase what is between them
         v_arr(j) = erase_between_sqbrack( v_arr(j) );
         peq = strpos( v_arr(j), "=" );
         vname = get_word_before( v_arr(j), peq );
         if( chat ) write,fout,v_arr(j)+" -> "+vname;
         grow, vnames, vname;
      }
      
   }

   n_vnames = numberof(vnames);

   for( j = 1; j <= n_vnames; j++ ) {
      write,fout,"---------------------------------------------------"
      write,fout,"   Declarations - reporting on: "+vnames(j);
      write,fout,"---------------------------------------------------"
      heureka = 0;
      for( i = code_start; i <= ncode; i++ ) {
         if( locate_word( code(i), vnames(j) ) ) {
            heureka++;
            if( heureka <= limit ) write,fout,format="%4i %s\n", i, code(i);
         }
      }
      if( heureka > limit ) write,fout,format="   ... and %i times more\n", heureka-limit;
      if( !heureka ) write,fout,"  NB: not used";
   }

}

func get_word_before( line, pos )
{
   if( is_void(pos) ) pos = 0;
   len = strlen(line);
   if( !len ) return [];
   if( pos == 0 ) pos = len; // i.e. word at end of string
   if( pos > len ) error,"GET_WORD_BEFORE ##1##";
   // locate the ending of the word - we know that it is less than or equal to 'pos'
   while( !strmatch( C_letters, strpart(line,pos:pos) ) && pos > 0 ) pos--;
   if( !pos ) return [];
   p = pos;
   while( strmatch( C_letters, strpart(line,p:p) ) && p > 0 ) p--;
   return strpart(line,p+1:pos);
}

func get_word_after( line, pos )
{
   len = strlen(line);
   if( !len ) return [];
   if( is_void(pos) ) pos = 1;
   if( pos == 0 ) pos = len; // i.e. word at end of string
   if( pos > len ) error,"GET_WORD_AFTER ##1##";
   // locate the beginning of the word - we know it is greater than or equal to 'pos'
   while( !strmatch( C_letters, strpart(line,pos:pos) ) && pos <= len ) pos++;
   if( pos == len+1 ) return [];
   p = pos;
   while( strmatch( C_letters, strpart(line,p:p) ) && p <= len ) p++;
   return strpart(line,pos:p-1);
}

func locate_word( line, word, start )
{
   if( is_void(start) ) start = 1;
   if( (pos = strpos( line, word, start )) == 0 ) return 0;

   // has been found in 'line'. Is it a word?

   // before
   if( pos > 1 ) {
      char_before = strpart( line, pos-1:pos-1 );
      if( strmatch( C_letters, char_before ) ) return 0;
   }

   // after

   lenword = strlen(word);
   lenline = strlen(line);
   if( pos <= lenline-lenword ) {
      char_after = strpart( line, pos+lenword:pos+lenword );
      if( strmatch( C_letters, char_after ) ) return 0;
   }

   // no objections

   return pos;

}

func erase_between_sqbrack( line )
{
   p = strpos( line ,"[" );
   if( !p ) return line;
   q = strpos( line, "]", rev=1 );
   if( !q ) return line;

   len = q - p - 1;
   if( !len ) return line;

   s = " ";
   s = strpadd( s, len, " " );
   return strput( line, s, p+1 );
}
%FILE% cat_merge.i
/* Function cat_merge */

func cat_merge( dol_cat_1, dol_cat_2, outfile, logfile=, silent=, \
          minrad= )
/* DOCUMENT cat_merge, dol_cat_1, dol_cat_2, outfile, logfile=, silent=,
             minrad=

   Keywords:
      logfile  : will override default name 'cat_merge_0000.txt'
      silent   : to suppress output on terminal
      minrad      : minimum error radius [degrees], defaults to 0.01

   2009-12-16/NJW   from cat_compare.pro
*/
{

   vb = is_void(silent);
   if( is_void(logfile) ) logfile = get_next_filename("cat_merge_????.txt");
   lun = open(logfile, "w");

   if( is_void(minrad) ) {min_err_rad = 0.01;} else {min_err_rad = minrad;}

   cat1 = dol_cat_1;
   cat2 = dol_cat_2;
   write,lun,"  Output file of \"cat_merge\",    "+ndate(3);

   write,lun,"CAT1: "+fullpath(cat1);
   write,"Reading "+cat1+" ...";
   name1 = rdfitscol(cat1,"NAME");
   nrows1 = numberof(name1);
   ra_obj1 = rdfitscol(cat1,"RA_OBJ");
   dec_obj1 = rdfitscol(cat1,"DEC_OBJ");
   err_rad1 = rdfitscol(cat1,"ERR_RAD");
   class1 = rdfitscol(cat1,"CLASS");
   write,lun,"           with "+itoa(nrows1)+" sources";

   w = where( err_rad1 < min_err_rad );
   if(numberof(w)) err_rad1(w) = min_err_rad;

   write,lun, "CAT2: "+fullpath(cat2);
   write,"Reading "+cat2+" ...";
   name2 = rdfitscol(cat2,"NAME");
   nrows2 = numberof(name2);
   ra_obj2 = rdfitscol(cat2,"RA_OBJ");
   dec_obj2 = rdfitscol(cat2,"DEC_OBJ");
   err_rad2 = rdfitscol(cat2,"ERR_RAD");
   class2 = rdfitscol(cat2,"CLASS");
   write,lun,"           with "+itoa(nrows2)+" sources";

   w = where( err_rad2 < min_err_rad );
   if(numberof(w)) err_rad2(w) = min_err_rad;

   // report keyword settings

   write,lun,"Keywords have been set as";
   write,lun,"   minrad   = "+swrite(format="%.4f",min_err_rad);

/*****************************************************************************

   Strategy: Walk through cat1 {
                   Find matching position in cat2 (dist < err_rad1+err_rad2)
                   if( one or more ) {
                      if( a single ) {
                         The case is clear
                      } else { // there are several candidates
                         Select by the smallest relative radius
                          ( dist/(err_rad1+err_rad2) )
                      }
                      Remove the cat2 source from candidates
                   }
             }
             Append remaining cat2 sources
**************************************************************************************/

   idx2 = indgen(nrows2); // keeps track of remaining sources in cat2
   // initialization of resulting variables:
   ra_obj3 = dec_obj3 = err_rad3 = name3 = flag3 = class3 = [];

  /*
   *  Walk through cat1
   */
   for( isrc1 = 1; isrc1 <= nrows1; isrc1++ ) {

      r = arcdist( ra_obj1(isrc1), dec_obj1(isrc1), ra_obj2(idx2), dec_obj2(idx2) );
      // positionel coincidence if r < err_rad1 + err_rad2
      w = where( r < err_rad1(isrc1) + err_rad2(idx2) ); // 'w' in idx2 space
      nw = numberof(w);
      if( nw ) { // a match has been found
         if( nw == 1 ) {
            isrc2 = idx2(w(1));
            i_to_remove = w(1);
            write,lun,format="Cat1 src #%i is connected with cat2 src#%i\n", isrc1, isrc2;
         } else {
            write,lun,format="Cat1 src #%i is connected with cat2 srcs:";
            for(i=1;i<=nw;i++) write,lun,format=" %i", idx2(w(i));
            write,lun,"";
            r_rel = r(idx2(w))/(err_rad1(isrc1) + err_rad2(idx2(w)));
            write,lun,format="err_rad1 = %8.5f\n", err_rad1(isrc1);
            write,lun,format="isrc2    r      err_rad2      %s\n", "r_rel";
            for( i = 1; i <= nw; i++ ) {
               write,lun,format="%3i %8.5f %8.5f %8.5f\n", \
                       idx2(w(i)), r(w(i)), err_rad2(idx2(w(i))), r_rel(i);
            }
            v = where( min(r_rel) == r_rel);
            isrc2 = idx2(w(v(1)));
            i_to_remove = w(v(1));
            write,lun,format="Chosen source isrc2 = %i\n", isrc2;
         }
         idx2 = rem_elem(idx2, i_to_remove); // remove source from
               // current version of cat2
         comb_pos = best_skypos([ra_obj1(isrc1),ra_obj2(isrc2)], \
                                [dec_obj1(isrc1),dec_obj2(isrc2)], \
                                [1./err_rad1(isrc1),1./err_rad2(isrc2)]);
         grow, ra_obj3, comb_pos(1);
         grow, dec_obj3, comb_pos(2);
         grow, err_rad3, 1./(1./err_rad1(isrc1) + 1./err_rad2(isrc2));
         grow, flag3, 10000*isrc1 + isrc2; // 10000*(pos in cat1) + (pos in cat2)
         newname = name1(isrc1) == name2(isrc2) ? name1(isrc1) : "UNDEFINED NAME      ";
         newclass = class1(isrc1) == class2(isrc2) ? class1(isrc1) : 0;
         grow, name3, newname;
         grow, class3, newclass;
      } else { // no match found so include just this one
         grow, ra_obj3, ra_obj1(isrc1);
         grow, dec_obj3, dec_obj1(isrc1);
         grow, err_rad3, err_rad1(isrc1);
         grow, flag3, 10000*isrc1;
         grow, name3, name1(isrc1);
         grow, class3, class1(isrc1);
      }

   }

  /**********************************

       Finished stepping through Cat1

       Append remaining sources in Cat2

   *************************************/

   n_remain = numberof(idx2);
   for( i = 1; i <= n_remain; i++ ) {
      isrc2 = idx2(i);
      grow, ra_obj3, ra_obj2(isrc2);
      grow, dec_obj3, dec_obj2(isrc2);
      grow, err_rad3, err_rad2(isrc2);
      grow, flag3, isrc2;
      grow, name3, name2(isrc2);
      grow, class3, class2(isrc2);
   }

   kwds_init;
   kwds_set,"DATE",ndate(3),"Date and time of creation";
   kwds_set,"ORIGIN","cat_merge.i","Software used for creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible for file creation";
   kwds_set,"AFFILIAT","NSI/DTU, Copenhagen, Denmark","Affiliation of responsible person";
   kwds_set,"EMAIL","njw@space.dtu.dk","Email address";
   kwds_set,"CATALOG1",fullpath(cat1),"First input catalog";
   kwds_set,"CATALOG2",fullpath(cat2),"Second input catalog";
   kwds_set,"MINRAD",min_err_rad,"[deg] Chosen minimum error radius";
   kwds_set,"COMMENT","This is a combination of two X-ray source catalogs";
   kwds_set,"COMMENT","The 'FLAG' value is 10000*(number in cat1) + (number in cat2)";
   kwds_set,"TUNIT2","deg","Unit of RA_OBJ";
   kwds_set,"TUNIT3","deg","Unit of DEC_OBJ";
   kwds_set,"TUNIT4","deg","Unit of ERR_RAD";

   wrmfitscols, outfile, "NAME", name3, "RA_OBJ", ra_obj3, "DEC_OBJ", dec_obj3, \
          "ERR_RAD", err_rad3, "CLASS", class3, \
          "FLAG", flag3, clobber=1,extname="SOURCE_CAT";

   write,lun,format="Resulting FITS file: %s\n", outfile;

   close,lun;

}

%FILE% cat_pack.i
/********************************************************

 A package for administration of the catalog production

          2008-10-17/NJW

The sky elements are listed in the file jmxi_dist_1476.fits
which also has a column that lists the SWIDs that are connected
with the given sky element.

Function

assign_sky_elements
      makes a list of all valid SWIDs and assigns each to the
      closest sky element. The file jmxi_dist_1476.fits is
      updated.

do_elem
      will initiate 'do_project' for the list of SWIDs that
      belong to a given sky element

do_swid
      will run a single SWID

fu_elem
      will initiate 'do_project' for the SWIDs that failed to be
      run succesfully in the previous run(s).

mdo_elem
      Start multiple runs of 'do_elem' with keyword 'next'
      set.

which_elems
      returns a list of sky elements that are connected with
      the input list of SWIDs

fverify
      Check the existence of 'sky_ima' and 'srcl_res' files against
      expectations (subtracted reported failures).

gverify
      Run 'verify' for all done sky elements and write the
      result to a log file: jmxi_verify_NNNN.log

verify
      Verify the existence of all output files expected from
      a sky element

org_repository
      Organize data repository

cp_non_verified
      Copy the part of the SWID list which couldn't be verified
      from file to file

status_plot
      Makes a sky map of how far the processing has come

get_status
      Returns status value

set_status
      (Re)Sets status value

reset_status
      Resets status information in jcat_status.fits

status_info
      Returns status information

mosa_updates
      Updates the jcat_status.fits file and returns completed
      sky elements where no mosaic file exists.

collect_src_info
      Produce FITS file with source information

do_mosaics
      Initiate the production of mosaic images for the sky elements
      with status 2 i.e. 'done'.

find_images
      From a given sky position find the images that overlap

mosa_check
      Check if mosaic files are reasonable

upd_status_file
      Update status file 'jcat_status.fits'

mk_jcat_status
      Delete old status files and redo.

remindme
      Show external variables with values

mk_srcl_res_cat
      Produce a catalog of sources in SRCL-RES files

setup_dist_1476
      Start from scratch on jmxi_dist_1476.fits
************************************************************/
#include "common.id"

extern cat_packdoc;
/* DOCUMENT   Functions:
          assign_sky_elements           mk_jcat_status                
          collect_src_info              mk_srcl_res_cat               
          cp_non_verified               mosa_check                    
          do_elem                       mosa_updates                  
          do_mosaics                    org_repository                
          do_swid                       reset_status                  
          find_images                   set_status                    
          fu_elem                       status_info                   
          fverify                       status_plot                   
          get_status                    upd_status_file               
          gverify                       verify                        
          mdo_elem                      which_elems                   
          remindme                      setup_dist_1476
    Externals:
          Dist_dol1/2               Swid_file1/2
          Status_dol                Ra_arr/Dec_arr
          Nswids_arr1/2
*/

vername = "nov10"; // Version name of present 'cat_pack'

Dist_dol1 = "/r9/njw/yorick/jcat/"+vername+"/jmx1_dist_1476.fits+1";
Dist_dol2 = "/r9/njw/yorick/jcat/"+vername+"/jmx2_dist_1476.fits+1";
Swid_file1 = "/r9/njw/yorick/jcat/"+vername+"/jmx1_swid_skye.fits";
Swid_file2 = "/r9/njw/yorick/jcat/"+vername+"/jmx2_swid_skye.fits";
Status_dol = "/r9/njw/yorick/jcat/"+vername+"/jcat_status.fits+1";
Ra_arr = rdfitscol(Dist_dol1,"RA");
Dec_arr = rdfitscol(Dist_dol1,"DEC");
Nswids_arr1 = rdfitscol(Dist_dol1,"NSWIDS");
Nswids_arr2 = rdfitscol(Dist_dol2,"NSWIDS");
Degrad = pi/180.0;
Basdir = "/jemx/njw";
if( file_test(Swid_file1) ) {
   Swids1 = rdfitscol( Swid_file1+"+1", "SWID" );
   Skyes1 = rdfitscol( Swid_file1+"+1", "SKY_ELEMENT" );
} else write,"NB: No Swids1/Skyes1 arrays read in";
if( file_test(Swid_file2) ) {
   Swids2 = rdfitscol( Swid_file2+"+1", "SWID" );
   Skyes2 = rdfitscol( Swid_file2+"+1", "SKY_ELEMENT" );
} else write,"NB: No Swids2/Skyes2 arrays read in";
Host = get_env("HOST");
Host_arr = ["gauss","node2","maxwell","tesla","euler"];
Proj_ids = ["r006","r007","r008","r009","r010"];
Nhosts = numberof(Host_arr);
whost = where( Host == Host_arr );
if( numberof(whost) != 1 ) {
   write,"To be run on gauss, orsted, maxwell, or tesla - so quit!";
   return;
}
Host_no = whost(1);
Proj_id = Proj_ids(Host_no);

/* Function remindme */

func remindme( void )
/* DOCUMENT remindme

   Displays the external variables on the terminal
*/
{
   write,format="Dist_dol1       %s\n", Dist_dol1;
   write,format="Dist_dol2       %s\n", Dist_dol2;
   write,format="Swid_file1      %s\n", Swid_file1;
   write,format="Swid_file2      %s\n", Swid_file2;
   write,format="Status_dol      %s\n", Status_dol;
   write,format="RA_arr          %s\n","RA of sky elements";
   write,format="Dec_arr         %s\n","Dec of sky elements";
   write,format="Nswids_arr1     %s\n","Number of swids in sky elements";
   write,format="Nswids_arr2     %s\n","Number of swids in sky elements";
   write,format="Swids1          %s\n","List of all SWIDs for JMX1";
   write,format="Skyes1          %s\n","Corresponding sky elements";
   write,format="Swids2          %s\n","List of all SWIDs for JMX2";
   write,format="Skyes2          %s\n","Corresponding sky elements";
}

/* Function assign_sky_elements */

func assign_sky_elements( jemxNum, only= )
/* DOCUMENT assign_sky_elements, jemxNum, only=

   Loop over all (validated) SWIDs and assign the nearest sky element
   for each of them. Update the jmxi_dist_1476.fits file.
   Keyword 'only' will cause program to stop after (re-)writing the
   SWID vs. sky element file: jmxi_swid_skye.fits

   2008-10-20/NJW as a result of changed strategy
*/
{
   local ra, dec, roll;

   if( jemxNum == 1 ) {
      Dist_dol = Dist_dol1;
      Swid_file = Swid_file1;
   } else {
      Dist_dol = Dist_dol2;
      Swid_file = Swid_file2;
   }
   // Setting revolutions as of 2010-11-02:
   swids = find_swid_radec( 0, 0, 180.0, rev="26-847,863-867,902,903,966-968",list=1,nof=1,silent=1 );
   swids = validate_swid_list( swids, jemxNum, silent=1 );
   nswids = numberof(swids);
   skye_list = array(long, nswids);

  /*
   *   Go through the list of all SWIDs and for each one determine which sky
   *   element is the closest one
   */

   rmin = 180.;
   rmax = 0.;
   for( i = 1; i<= nswids; i++ ) {
      status = get_pointing_for_swid( swids(i), ra, dec, roll, silent=1 );
      if( status != 0 ) error,"Problem with get_pointing_for_swid";
      r = arcdist( ra, dec, Ra_arr, Dec_arr );
      rm = r(min);
      w = where(r == rm);
      skye_list(i) = w(1);
      if( rm < rmin ) rmin = rm;
      if( rm > rmax ) rmax = rm;
   }
   write,format="Global rmin = %7.3f deg\n", rmin;
   write,format="Global rmax = %7.3f deg\n", rmax;

  /*
   *   Writing of the jmxi_swid_skye.fits file
   */

   kwds_init;
   kwds_set, "DATE", ndate(3), "Date/time for creation";
   kwds_set, "ORIGIN", "assign_sky_elements(cat_pack.i)","Software";
   kwds_set, "COMMENT","Part of jcat "+vername+" processes";
   wrmfitscols, Swid_file, "SWID", swids, "SKY_ELEMENT", skye_list, clobber=1;
   write,format="Has updated %s\n", Swid_file;

   if( only ) return;

  /*
   *   Sort the list of sky elements and rearrange the SWID list the same
   *   way. Then the SWIDs belonging to a particular sky element can be
   *   found by the 'uniq' function.
   *   The SWIDs are converted to type 'double' for the benefit of fits_bintable_poke
   *   that does not handle variable record lengths for type string.
   */

   is = sort(skye_list);
   skye_list = skye_list(is);
   swids = atof(swids(is));
   ulist = uniq(skye_list);
   nulist = numberof(ulist);

   for( i = 1; i <= nulist; i++ ) {
      first = ulist(i);
      last = i == nulist ?  nswids : ulist(i+1) - 1;
      write,format="%i SWIDs for element %i\n", last-first+1, skye_list(first);
      fits_bintable_poke, Dist_dol, skye_list(first), 3, last-first+1;
      fits_bintable_poke, Dist_dol, skye_list(first), 4, swids(first:last);
   }

   write,format="Global rmin = %7.3f deg\n", rmin;
   write,format="Global rmax = %7.3f deg\n", rmax;

}

/* Function which_elems */

func which_elems( jemxNum, swid_list )
/* DOCUMENT list = which_elems( jemxNum, swid_list )

   Returns a list of sky elements where the SWIDs in 'swid_list'
   belong.

   2008-10-20/NJW
*/
{
   local ra, dec, roll, swids, skyes;

   if( jemxNum == 1 ) {
      eq_nocopy, swids, Swids1;
      eq_nocopy, skyes, Skyes1;
   } else {
      eq_nocopy, swids, Swids2;
      eq_nocopy, skyes, Skyes2;
   }

   nsl = numberof(swid_list);
   list = array(long, nsl);
   for( i = 1; i <= nsl; i++ ) {
      w = where( swid_list(i) == swids );
      nw = numberof(w);
      if( nw == 0 ) {
         write,format="WARNING, SWID %s belongs to no sky element\n", swid_list(i);
         list(i) = -1;
      } else {
         list(i) = skyes(w(1));
      }
   }

   return list;

}

/* Function get_status */

func get_status( jemxNum, skye )
/* DOCUMENT res = get_status( jemxNum, skye )

*/
{
   if( jemxNum == 1 ) {
      colnumber = 1;
   } else if( jemxNum == 2 ) {
      colnumber = 2;
   } else error,"GET_STATUS: Illegal jemxNum";

   return fits_bintable_peek( Status_dol, skye, colnumber )(1);
}

/* Function set_status */

func set_status( jemxNum, skye, value )
/* DOCUMENT set_status, jemxNum, skye, value

*/
{
   if( jemxNum == 1 ) {
      colnumber = 1;
   } else if( jemxNum == 2 ) {
      colnumber = 2;
   } else error,"SET_STATUS: Illegal jemxNum";

   if( typeof(value) != "long" ) error,"SET_STATUS value has bad type";
   if( numberof(value) != 1 ) error,"SET_STATUS value has illegal number of elements";

   //+ fits_bintable_poke, Status_dol, skye, colnumber, value;
   upd_status_file, skye, colnumber, value;
}

/* Function reset_status */

func reset_status( jemxNum, skye, value, mosa=, global= )
/* DOCUMENT reset_status, jemxNum, skye, value, mosa=, global=

   Will reset the sky element 'skye' to 'not done' in the status
   file : jcat_status.fits(column DONE_J[1|2]) if argument 'value'
   is not given else it will be set to the value of 'value'.
   The 'mosa' keyword will change the action to be on column MOSA_J[1|2]

   If 'skye' is omitted and the keyword global set then a complete
   reset will be done.

   Status table (DONE_J1/2):
       0   not done
       1   do_elem has been run
       2   verified and found in order

   Status table (MOSA_J1/2):
       0   not done
       1   finished

   2008-10-22/NJW
   2009-06-08/NJW

*/
{
   if( jemxNum == 1 ) {
      js = "jmx1";
      if( mosa ) {
         colname = "MOSA_J1";
         colnumber = 3;
      } else {
         colname = "DONE_J1";
         colnumber = 1;
      }
   } else if( jemxNum == 2 ) {
      js = "jmx2";
      if( mosa ) {
         colname = "MOSA_J2";
         colnumber = 4;
      } else {
         colname = "DONE_J2";
         colnumber = 2;
      }
   } else error,"RESET_STATUS: Illegal jemxNum";

   if( skye && global ) error,"RESET_STATUS: Illegal argument/keyword combination";
   if( is_void(value) ) value = 0;  // default value - set to 'not done'

   if( global ) {
      done_arr = rdfitscol( Status_dol, colname );
      w = where( done_arr );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No sky elements to reset - skip";
         return;
      }
      // reset 'done_arr'
      done_arr() = 0;
      upd_status_file, 1, colnumber, done_arr;
   } else {
      upd_status_file, skye, colnumber, value;
   }


}

/* Function mdo_elem */

func mdo_elem( jemxNum, tlimit=, force=, rev= )
/* DOCUMENT mdo_elem, jemxNum, tlimit=, force=, rev=

   Multiple runs of 'do_elem'
   tlimit   :   Will stop calling do_elem when this number of hours has elapsed
   force    :   Will force to redo sky elements even if they are listed as 'done'
   rev      :   Reverse direction for choice of next sky element i.e.
                          call 'do_elem' with next=-1

   2008-10-22/NJW

*/
{
   local starttime;
   timestamp, starttime;
   nexthour = starttime + 3600;
   nowtime = 0;
   if( tlimit ) {
      tlimit = long(3600. * tlimit); // convert hours to seconds
   } else {
      tlimit = 8640000; // assume hundred days == eternity
   }

   next = rev ? -1 : 1; // Reverse direction if keyword 'rev' is set

   while( nowtime - starttime < tlimit ) {
      status = do_elem( jemxNum, next=next);
      timestamp, nowtime;
      if( nowtime > nexthour ) {
         nexthour = nowtime + 3600;
         gverify,jemxNum;
         org_repository,jemxNum;
      }
      // provoke a stop if irregularity has been encountered
      // or no more sky elements to do
      if( status != 0 ) {
         write,format="Terminates because status = %i\n", status;
         nowtime = starttime + tlimit;
      }
   }
}


/* Function do_elem */

func do_elem( jemxNum, skye, next=, limit=, force= )
/* DOCUMENT do_elem, jemxNum, skye, next=, limit=, force=
      or    status = do_elem( jemxNum, skye, next=, limit=, force= )

   Initiate the do_project jemxNum project_id with SWIDs from a
   sky element that can be
    - the next not-yet-done (next=1 or -1 for reversed direction)
    - the next not-yet-done with number of SWIDs < limit
              (next=1, limit=what_you_like)
    - a specific sky element number (skye=your_chosen_number)

    force  :  Suppress user interaction and force to rerun an element

    Proj_id is r006 when using 'gauss', r007 on 'orsted' alias 'node2'
               r008 on 'maxwell', r009 on 'tesla', and r010 on 'euler'

    When called as a function it returns 0 (zero) for nominal running
    and -1 for 'no SWIDs available'
        -2 for trouble

   2008-10-10/NJW
   2008-10-22/NJW updated with force keyword
   2009-03-31/NJW updated for maxwell and tesla
*/
{
   if( skye ) {
      if( next || limit ) error,"Illegal argument/keyword combination";
   } else {
      if( !next ) error,"One of next and skye must be given";
   }
   local Nswids_arr;
   if( jemxNum == 1 ) {
      colname = "done_j1";
      Dist_dol = Dist_dol1;
      eq_nocopy, Nswids_arr, Nswids_arr1;
   } else {
      colname = "done_j2";
      Dist_dol = Dist_dol2;
      eq_nocopy, Nswids_arr, Nswids_arr2;
   }

   // Read the information on current processing status
   status = rdfitscol( Status_dol, colname );

   ok = 0;
   if( skye ) {
      nsw = Nswids_arr(skye);
      if( nsw == 0 ) {
         write,format="No SWIDs for sky element #%i - quit", skye;
         return -1;
      }
      is_done = status(skye);
      if( is_done && !force ) {
         ans = ""
         read,prompt="Already done - want to proceed anyway ? ... ", ans;
         if( ans != "y" ) return -2;
      }
      ok = 1;
   } else {                 // keyword 'next' is set
      w = where( Nswids_arr );
      nw = numberof(w);
      if( nw == 0 ) {
         write,format="No more sky elements to process for JMX%i\n", jemxNum;
         return -1;
      }
      if( next < 0 ) w = w(0:1:-1); // reverse direction to avoid redoing elements
      for( i = 1; i <= nw; i++ ) {
         if( status(w(i)) ) continue;
         if( limit ) if( Nswids_arr(w(i)) > limit ) continue;
         // when you get here the sky element is the next one
         skye = w(i);
         ok = 1;
         break;
      }
   }

   if( !ok ) {
      write,format="No more sky elements to process for JMX%i\n", jemxNum;
      return -1;
   }

   // Make list of SWIDs
   dswids = fits_bintable_peek( Dist_dol, skye, 4 );
   n_dswids = numberof(dswids);
   dswids = dswids(sort(dswids)); // sort for better performance of do_project
   write,format="%i SWIDs attached to sky element #%i\n", n_dswids, skye;
   swid_list = array(string, n_dswids );
   for( i = 1; i <= n_dswids; i++ ) {
      swid_list(i) = swrite(format="%012.0f", dswids(i));
   }
   write_slist,"/r9/njw/jemx/analysis8/"+Proj_id+"/swid.list",swid_list;
   info_text = [];
   grow, info_text, ndate(3);
   grow, info_text, swrite(format="Current SWID list is sky element %i", skye);
   write_slist,"/r9/njw/jemx/analysis8/"+Proj_id+"/info.txt",info_text;

   curdir = get_cwd();
   cd,"/r9/njw/jemx/analysis8";
   write,format="Going to issue: %s\n", "do_project "+itoa(jemxNum)+" "+Proj_id;
   system,"do_project "+itoa(jemxNum)+" "+Proj_id; // Initiate the project
   system,"statrunj";     // wait until j_* processes have terminated
   cd, curdir;
   // update the status file but make sure it is not done simultaneously
   // with other process
   upd_status_file, skye, jemxNum, 1n;


   if( am_subroutine() ) {
      write,format="\n\nFinished running sky element #%i\n\n", skye;
   }

   return 0;  // signal nominal running

}

/* Function do_swid */

func do_swid( jemxNum, swid )
/* DOCUMENT do_swid, jemxNum, swid
*/
{
   curdir = get_cwd();
   cd,"/r9/njw/jemx/analysis8";
   write_slist,Proj_id+"/swid.list",swid;
   write,format="Going to issue: %s\n", "do_project "+itoa(jemxNum)+" "+Proj_id;
   system,"do_project "+itoa(jemxNum)+" "+Proj_id; // Initiate the project
   system,"statrunj";     // wait until j_* processes have terminated
   cd, curdir;
}

/* Function upd_status_file */

func upd_status_file( row, col, data )
/* DOCUMENT upd_status_file, row, col, data

   Implements a mechanism for reserving the file so that two write attempts
   will not be performed simultaneously.
*/
{

   curdir = get_cwd();
   cd,"/r9/njw/yorick/jcat/"+vername; // where the lock file should be placed

   mylock = "lock_"+Host;
   flag = 0;
   for(i = 1; i <= Nhosts; i++ ) {
      if( i == Host_no ) continue;
      flag += file_test("lock_"+Host_arr(i));
   }
   koun = 0;
   while( flag ) {
      write,format="%s is waiting to update status file (%i)\n", Host, ++koun;
      pause,1000; // wait for unlock
      flag = 0;
      for(i = 1; i <= Nhosts; i++ ) {
         if( i == Host_no ) continue;
         flag += file_test("lock_"+Host_arr(i));
      }
   }
   system,"touch "+mylock; // Reserve the file 'Status_dol'
   pause,500;
   fits_bintable_poke, Status_dol, row, col, data;
   pause,500;
   remove, mylock; // give access to 'Status_dol' for other processes

   cd, curdir; // back to where you came from

}

/* Function fu_elem */

func fu_elem( jemxNum, skye, next= )
/* DOCUMENT fu_elem, jemxNum, skye, next=
      or    status = fu_elem( jemxNum, skye, next= )

   Follow-up on a sky element that hasn't been completed.
   Initiate the do_project jemxNum project_id with SWIDs in a
   sky element that can be
    - the next not-yet-done (next=1)
         Grabs the next one from the most recent jmxi_verify_NNNN.log file
    - a specific sky element number (skye=your_chosen_number)

    Proj_id is r006 when using 'gauss', r007 on 'orsted' alias 'node2',
               r008 on 'maxwell', r009 on 'tesla', and r010 on 'euler'

    When called as a function it returns 0 (zero) for nominal running
    and -1 for 'no SWIDs available'
        -2 for trouble

   2008-10-23/NJW cloned from do_elem
*/
{
   local failed_swids;

   if( skye ) {
      if( next ) error,"Illegal argument/keyword combination";
   } else {
      if( !next ) error,"One of next and skye must be given";
   }
   if( jemxNum == 1 ) {
      js = "jmx1";
      colname = "done_j1";
   } else {
      js = "jmx2";
      colname = "done_j2";
   }

   // organize the identification of impossible SWIDs
   file1 = js+"_fail1.scm";
   file2 = js+"_fail2.scm";
   file3 = js+"_fail3.scm";
   file4 = js+"_fail4.scm";
   cp_non_verified, jemxNum, file2, file1; // save previously failed
   cp_non_verified, jemxNum, file3, file2; // save previously failed
   cp_non_verified, jemxNum, file4, file3; // save previously failed
                    // that are still failures
   cp, file3, file4; // Only keep the cleaned version
   // file4 is to be updated with failures from this run

   // The SWIDs in 'file1' are considered to be impossible
   // Make sure that they are not rerun indefinitely by requiring
   // 'verify' to take failures into account

 /*
  *hopeless = read_slist(file1);
  *n_hopeless = numberof(hopeless);
  *if( n_hopeless > 0 ) {
  *   skye_arr = which_elems( jemxNum, hopeless );
  *   skye_arr = skye_arr(sort(skye_arr));
  *   skye_arr = skye_arr(uniq(skye_arr));
  *   n_skye_arr = numberof(skye_arr);
  *   for(i = 1; i <= n_skye_arr; i++ ) {
  *      status = get_status( jemxNum, skye_arr(i) );
  *      if( status != 2 ) reset_status, jemxNum, skye_arr(i), 2;
  *   }
  *}
  */

   ok = 0;
   if( skye ) {
      nsw = verify( jemxNum, skye, failed_swids, force=1, kf=1, upd=1, chat=1 );
      if( nsw <= 0 ) {
         write,format="No SWIDs for follow up for sky element #%i - I quit\n", skye;
         return -1;
      }
      ok = 1;
   } else {                 // keyword 'next' is set
      // Identify latest gverify log file
      logfiles = file_search(js+"_verify_????.log",".");
      logfile = logfiles(sort(logfiles))(0);
      skye_arr = rscol( logfile, 1, block=3000, lng=1, silent=1,nomem=1);
      n_skye_arr = numberof(skye_arr);
      if( n_skye_arr == 0 ) {
         write,format="No more sky elements to follow up for JMX%i\n", jemxNum;
         return -1;
      }
      do {
         skye = next > 0 ? skye_arr(1) : skye_arr(0); // allow for reversed choice
         nsw = verify( jemxNum, skye, failed_swids, upd=1 );
         if( nsw <= 0 ) {
            if( n_skye_arr == 1 ) return -1;
            skye_arr = skye_arr(where( skye_arr != skye ));
            n_skye_arr--;
         }
      } while( nsw <= 0);

   }
   // The list of SWIDs has already been updated by the 'verify' call
   info_text = [];
   grow, info_text, ndate(3);
   grow, info_text, swrite(format="Current SWID list is sky element %i", skye);
   write_slist,"/r9/njw/jemx/analysis8/"+Proj_id+"/info.txt",info_text;

   curdir = get_cwd();
   cd,"/r9/njw/jemx/analysis8";
   write,format="Going to issue: %s\n", "do_project "+itoa(jemxNum)+" "+Proj_id;
   system,"do_project "+itoa(jemxNum)+" "+Proj_id; // Initiate the project
   system,"statrunj";     // wait until j_* processes have terminated
   cd, curdir;

   if( am_subroutine() ) {
      write,format="\n\nFinished running sky element #%i\n\n", skye;
   }

   verify, jemxNum, skye, failed_swids;
   if( numberof(failed_swids) > 0 ) {
      write_slist, file4, failed_swids, app=1;
   }

   return 0;  // signal nominal running

}

/* Function gverify */

func gverify( jemxNum )
/* DOCUMENT gverify, jemxNum

   Global verify - calls 'verify' for all 'status==1' sky elements
   as marked in file: jcat_status.fits

   2008-10-22/NJW
*/
{
   if( jemxNum == 1 ) {
      js = "jmx1";
      colname = "DONE_J1";
   } else if( jemxNum == 2 ) {
      js = "jmx2";
      colname = "DONE_J2";
   } else error,"GVERIFY: Illegal jemxNum";

   done_arr = rdfitscol( Status_dol, colname );
   w = where( done_arr == 1 );
   nw = numberof(w);
   if( nw == 0 ) {
      write,"No sky elements are ready for inspection";
      return;
   }
   logfile = get_next_filename(js+"_verify_????.log");
   flog = open( logfile, "w");
   write,flog,format="// Log file of gverify for %s, %s\n", strupcase(js), ndate(3);
   write,flog,format="%s\n","//";
   ok_skyes = [];
   ko_skyes = [];
   for( i = 1; i <= nw; i++ ) {
      n = verify( jemxNum, w(i), failed_swids, kf=1 );
      if( n == -1 ) error,"##333## _SHOULD_ not happen";
      if( n > 0 ) {
         grow, ko_skyes, w(i);
         write,flog,format="// block = %i\n", w(i);
         for(j=1;j<=n;j++) write,flog,format="      %s\n", failed_swids(j);
      } else grow, ok_skyes, w(i);
   }

   write,flog,format="// block = %i\n", 2000;
   write,flog,format="// Sky elements verified as %s\n","OK";
   close, flog;
   if( !is_void(ok_skyes) ) {
      write_slist,logfile,swrite(format="%5i", ok_skyes), app=1;
   }
   flog = open( logfile, "a");
   write,flog,format="// block = %i\n", 3000;
   write,flog,format="// Sky elements with missing %s\n","files";
   close, flog;
   if( !is_void(ko_skyes) ) {
      write_slist,logfile,swrite(format="%5i", ko_skyes), app=1;
   }

   write,format="Found %i OK sky elements\n", numberof(ok_skyes);
   write,format="Found %i failed sky elements\n", numberof(ko_skyes);
   write,format="Log file: %s\n", logfile;

}

/* Function verify */

func verify( jemxNum, sky_element, &failed_swids, upd=, force=, kf=, chat= )
/* DOCUMENT verify, jemxNum, sky_element, >failed_swids, upd=, force=, kf=, chat=

   Checks the presence of the SRCL-RES and SKY-IMA files for the given
   sky element or a list of SWIDs (string array) as the second argument.

   As a side-effect the status file will be updated with 2 when all files
   are found, with 1 if some (but not zero files) are found, and 0 if none
   are found.

   When called as a function it returns
              -1  if no SWIDs are attached to the given sky element
                  or all SWIDs have been processed with success
               0  if all files are present
       else    the number of failed SWIDs

   The SWIDs for which a file is missing is reported in the argument 'failed_swids'

   The keyword 'upd' will cause an update the file 'swid.list' in
    /r9/njw/jemx/analysis8/r006, r007, r008, r009, or r010
        Value:    1   : in r006 if run on gauss, in r007 if run on orsted
                        in r008 if on maxwell, in r009 if on tesla, and in r010 on euler
                  6   : in r006 irrespective of HOST
                  7   : in r007 irrespective of HOST
                  8   : in r008 irrespective of HOST
                  9   : in r009 irrespective of HOST
                 10   : in r010 irrespective of HOST
   The keyword 'force' will enforce the verification independently of the
   previous status information.

   Keyword 'kf' (known failures) will cause verify to disregard the
     already reported failures in 'jmxi_failed1.scm'

   2008-10-21/NJW
   2009-07-10/NJW, updated with keyword 'kf'

*/
{
   local Nswids_arr;
   if( is_void(chat) ) chat = 0;
   project_id = Proj_id; // standard running

   if( jemxNum == 1 ) {
      Dist_dol = Dist_dol1;
      //  Array with number of SWIDs in each sky element:
      eq_nocopy, Nswids_arr, Nswids_arr1;
      js = "jmx1";
      colname = "DONE_J1";
      known_fails_list = read_slist("/r9/njw/yorick/jcat/"+vername+"/jmx1_fail1.scm");
   } else {
      Dist_dol = Dist_dol2;
      eq_nocopy, Nswids_arr, Nswids_arr2;
      js = "jmx2";
      colname = "DONE_J2";
      known_fails_list = read_slist("/r9/njw/yorick/jcat/"+vername+"/jmx2_fail1.scm");
   }

   amsub = am_subroutine(); // to control output to terminal

   // Find out if a SWID list is to be checked or we have a sky element
   // Flagged by variable         mode = 1           mode = 0

   if( typeof( sky_element ) == "string" ) { // a list of SWIDs is expected
      swid_list = sky_element;
      n_swid_list = numberof( swid_list);
      skye_arr = which_elems( jemxNum, swid_list);
      mode = 1;
   } else {      // a sky element number is expected
      if( numberof(sky_element) == 1 && \
           (typeof( sky_element ) == "long" || typeof( sky_element ) == "int") ) {
             mode = 0;
      } else error,"VERIFY: Illegal second argument";
   }

   if( mode == 0 ) { // checking a sky-element
      nsw = Nswids_arr(sky_element);
      if( nsw == 0 ) {
         if( amsub ) {  // Only print text if called as subroutine
            write,format="No SWIDs for sky element %i - quit\n", sky_element;
         }
         return -1;
      }

      status = rdfitscol( Status_dol, colname )(sky_element);
      if( chat > 0 ) write,"Previous status = "+itoa(status);

      if( !force ) {
         if( status != 1 ) { // Either not processed at all or verified as OK
            failed_swids = [];
            if( amsub ) {
               if( status == 0 ) {
                  write,format="Sky element #%i not processed at all\n", sky_element;
               } else if( status == 2 ) {
                  write,format="Sky element #%i has already been verified as OK\n", sky_element;
               } else error,"Unexpected value of status: "+itoa(status);
            }
            return -1;
         }
      }

      // Make list of SWIDs
      dswids = fits_bintable_peek( Dist_dol, sky_element, 4 );
      n_swid_list = numberof(dswids);
      dswids = dswids(sort(dswids)); // sort
      // Convert from double representation to string representation:
      swid_list = swrite(format="%012.0f", dswids);
      if( amsub ) {
         write,format="%i SWIDs attached to sky element #%i\n", n_swid_list, sky_element;
      }
      subdir = swrite(format="skies/skye%04i", sky_element);
   }

   // Eliminate the swids already known to fail

   if( kf ) {
      swid_list = filter_done( known_fails_list, swid_list);
      n_swid_list = numberof(swid_list);
      if( n_swid_list == 0 ) {
         if( amsub ) {
            if( mode ) {
               write,"All SWIDs in list are know to fail";
            } else {
               write,format="skye%04i is known to fail completely\n", sky_element;
            }
         }
         return 0;
      }
   }

   //  ------  LOOP over all SWIDs in the list  -----------

   kounts = 0;
   kounti = 0;
   failed_swids = [];
   for( i = 1; i <= n_swid_list; i++ ) {
      if( mode == 1 ) {
         if( skye_arr(i) <= 0 ) {
            write,format="SWID %s does not belong to any sky element\n", swid_list(i);
            continue;
         }
         subdir = swrite(format="skies/skye%04i", skye_arr(i));
      }
      swidstr = swid_list(i);
      // SRCL-RES
      tjek = 0;
      file = Basdir+"/srcl_res/"+subdir+"/"+js+"_srcl_res_s003_"+swidstr+".fits";
      if( file_test(file) ) {
         if( filesize(file) >= 17280 ) { tjek++; goto done_srcl_res; }
      }
      for( iproj = 1; iproj <= Nhosts; iproj++ ) {
         file = Basdir+"/srcl_res/"+js+"_srcl_res_"+Proj_ids(iproj)+"_"+swidstr+".fits";
         if( file_test(file) ) {
            if( filesize(file) >= 17280 ) { tjek++; goto done_srcl_res; }
         }
      }

      done_srcl_res:

      if( !tjek ) {
         if( kounts < 10 && amsub ) write,format="SRCL-RES not found: %s\n", swidstr;
         grow, failed_swids, swidstr;
         kounts++;
      }
      // SKY-IMA
      tjek = 0;
      file = Basdir+"/sky_ima/"+subdir+"/"+js+"_sky_ima_s003_"+swidstr+".fits";
      if( file_test(file) ) {
         if( filesize(file) >= 1000000 ) { tjek++; goto done_sky_ima; }
      }
      for( iproj = 1; iproj <= Nhosts; iproj++ ) {
         file = Basdir+"/sky_ima/"+js+"_sky_ima_"+Proj_ids(iproj)+"_"+swidstr+".fits";
         if( file_test(file) ) {
            if( filesize(file) >= 1000000 ) { tjek++; goto done_sky_ima; }
         }
      }

      done_sky_ima:

      if( !tjek ) {
         if( kounti < 10 && amsub ) write,format="SKY.-IMA not found: %s\n", swidstr;
         grow, failed_swids, swidstr;
         kounti++;
      }
   }

   if( amsub ) {
      if( kounts > 0 ) write,format=" In total: %4i missing SRCL-RES files\n", kounts;
      if( kounti > 0 ) write,format=" In total: %4i missing SKY-IMA  files\n", kounti;
   }
   if( kounti+kounts == 0 ) {
      // Update status file - no need to check again
      if( mode == 0 ) {
         if( status != 2 ) {
            if( chat > 0 ) write,"Resetting status to 2";
            reset_status, jemxNum, sky_element, 2;
         }
      }
      if( amsub ) write,"Passed the test!";
      return 0;
   } else {
      failed_swids = failed_swids(sort(failed_swids));
      failed_swids = failed_swids(uniq(failed_swids));

      n_failed_swids = numberof(failed_swids);
      new_status = (n_failed_swids < n_swid_list);
      if( chat > 0 ) write,format="%i failed swids, new status = %i\n", \
             n_failed_swids, new_status;
      if( mode == 0 ) {
         if( new_status != status) {
            if( chat > 0 ) write,"Resetting status to "+itoa(new_status);
            reset_status, jemxNum, sky_element, new_status;
         }
      }
      if( upd ) {
         if( upd == 1 ) {
            project_id = Proj_id;
         } else {
            if( upd < 6 || upd > 10 ) error,"##54## Illegal project number";
            project_id = Proj_ids(upd-5);
         }
         write_slist, "/r9/njw/jemx/analysis8/"+project_id+"/swid.list", failed_swids;
         write,format="Has now updated /r9/njw/jemx/analysis8/%s/swid.list\n", project_id;
      }
      return n_failed_swids;

   }

}

/* Function org_repository */

func org_repository( jemxNum )
/* DOCUMENT org_repository, jemxNum

    2008-10-21/NJW
*/
{
   local dirname, basename, swids;

   if( jemxNum == 1 ) {
      js = "jmx1";
   } else if( jemxNum == 2 ) {
      js = "jmx2";
   } else error,"Illegal jemxNum";

  //   SRCL-RES

   sllist = file_search( js+"_srcl_res_r006_*.fits", "/jemx/njw/srcl_res" );
   grow, sllist, file_search( js+"_srcl_res_r007_*.fits", "/jemx/njw/srcl_res" );
   grow, sllist, file_search( js+"_srcl_res_r008_*.fits", "/jemx/njw/srcl_res" );
   grow, sllist, file_search( js+"_srcl_res_r009_*.fits", "/jemx/njw/srcl_res" );
   grow, sllist, file_search( js+"_srcl_res_r010_*.fits", "/jemx/njw/srcl_res" );
   if( is_void(sllist) ) {
      write,"No SRCL-RES files to process, jump to SKY-IMA";
   } else {
      n_swids = pick_swid_str( sllist, swids );
      skyes = which_elems( jemxNum, swids );
      is = sort(skyes);
      skyes = skyes(is);
      sllist = sllist(is);
      uskyes = skyes(uniq(skyes));
      n_uskyes = numberof(uskyes);

      files = lsdir( "/jemx/njw/srcl_res/skies", subdirs );
      for( i = 1; i <= n_uskyes; i++ ) {
         subdir = swrite(format="skye%04i", uskyes(i) );
         w = where( subdirs == subdir );
         nw = numberof(w);
         if( nw == 0 ) {
            write,format="New subdir: %s\n", "/jemx/njw/srcl_res/skies/"+subdir;
            system,"mkdir /jemx/njw/srcl_res/skies/"+subdir;
         }
      }
      write,"Reorganizing srcl_res ...";
      for( i = 1; i <= n_swids; i++ ) {
         splitfname, sllist(i), dirname, basename;
         // replace 'r0??' with 's003'
         pos = strpos( basename, "_r0", 1);
         newname = strput( basename, "s003", pos+1 );
         subdir = swrite(format="skye%04i", skyes(i) );
         system,"mv "+sllist(i)+" /jemx/njw/srcl_res/skies/"+subdir+"/"+newname;
      }
   }

  //   SKY-IMA

   imlist = file_search( js+"_sky_ima_r006_*.fits", "/jemx/njw/sky_ima" );
   grow, imlist, file_search( js+"_sky_ima_r007_*.fits", "/jemx/njw/sky_ima" );
   grow, imlist, file_search( js+"_sky_ima_r008_*.fits", "/jemx/njw/sky_ima" );
   grow, imlist, file_search( js+"_sky_ima_r009_*.fits", "/jemx/njw/sky_ima" );
   grow, imlist, file_search( js+"_sky_ima_r010_*.fits", "/jemx/njw/sky_ima" );
   if( is_void(imlist) ) {
      write,"No SKY-IMA files to process, terminate";
      return;
   }
   n_swids = pick_swid_str( imlist, swids );
   skyes = which_elems( jemxNum, swids );
   is = sort(skyes);
   skyes = skyes(is);
   imlist = imlist(is);
   uskyes = skyes(uniq(skyes));
   n_uskyes = numberof(uskyes);

   files = lsdir( "/jemx/njw/sky_ima/skies", subdirs );
   for( i = 1; i <= n_uskyes; i++ ) {
      subdir = swrite(format="skye%04i", uskyes(i) );
      w = where( subdirs == subdir );
      nw = numberof(w);
      if( nw == 0 ) {
         write,format="New subdir: %s\n", "/jemx/njw/sky_ima/skies/"+subdir;
         system,"mkdir /jemx/njw/sky_ima/skies/"+subdir;
      }
   }
   write,"Reorganizing sky_ima ...";
   for( i = 1; i <= n_swids; i++ ) {
      splitfname, imlist(i), dirname, basename;
      // replace 'r00?' with 's003'
      pos = strpos( basename, "_r0", 1);
      newname = strput( basename, "s003", pos+1 );
      oldname = strput( basename, "s002", pos+1 ); // This is the old name
      subdir = swrite(format="skye%04i", skyes(i) );
      system,"mv "+imlist(i)+" /jemx/njw/sky_ima/skies/"+subdir+"/"+newname;
      // delete the old image file:
      remove, "/jemx/njw/sky_ima/skies/"+subdir+"/"+oldname;
   }

   write,"done!";

}

/* Function cp_non_verified */

func cp_non_verified( jemxNum, file_in, file_out )
/* DOCUMENT cp_non_verified, jemxNum, file_in, file_out

   Copy SWID strings from file_in to file_out but only those that failed
   the verification test.
   Used in 'fu_elem' to find the SWIDs that continue to fail after three attempts.

   2008-10-23/NJW
*/
{
   local failed_swids;

   swids_in = rscol(file_in,1,str=1,silent=1,nomem=1);
   if( numberof(swids_in) == 0 ) {
      write,"No SWIDs to verify and copy";
      return;
   }
   nf = verify(jemxNum,swids_in,failed_swids);
   if( nf > 0 ) {
      write_slist, file_out, failed_swids;
   } else {
      write_slist, file_out, "";
   }

}

/* Function status_plot */

func status_plot( jemxNum, which=, pane= )
/* DOCUMENT status_plot, jemxNum, which=, pane=

   Make a sky map with sky element status symbols

   Keywords:

   Keyword 'which' (bit pattern) (defaults to 1)
             1 : Overview of sky elements
             2 : Sky elements with at least one SWID
             4 : Initiated (status==1) sky elements
             8 : Processed and verified (status==2) sky elements
            16 : To-be-done sky elements (status==0 with SWID(s))
            32 : Mosaic image exists

   Keyword 'pane' defines the window number (defaults to zero).

   2008-10-24/NJW, partially cloned from 'pointing_plot'
*/

{


   if( is_void(pane) ) pane = 0;
   if( is_void(which) ) which = 1;

   local Nswids_arr;
   if( jemxNum == 1 ) {
      eq_nocopy, Nswids_arr, Nswids_arr1;
      status = rdfitscol( Status_dol, "done_j1");
      js = "jmx1";
   } else if( jemxNum == 2 ) {
      eq_nocopy, Nswids_arr, Nswids_arr2;
      status = rdfitscol( Status_dol, "done_j2");
      js = "jmx2";
   } else error,"STATUS_PLOT: Illegal jemxNum";

   window,pane,style="nobox.gs";

   /*  Plot the grid */

   plot,[0],[0],xr=[180,-180],yr=1.4*[-90,90]-20;

   /* lon grid */

   b = span(-90,90,100);
   for( lon = -179.99; lon < 180.1; lon += 89.99 ) {
      l = array(0,100) + lon;
      xy = aitoff(l,b);
      listy = 2;
      if( lon < -179 || lon > 179 ) listy = 1;
      oplot,xy(1,),xy(2,),li=listy;
   }

   /* lat grid */

   l = span(-179.999,180,100);
   for( lat = -60.; lat < 60.01; lat += 30. ) {
      b = array(0,100) + lat;
      xy = aitoff(l,b);
      oplot,xy(1,),xy(2,),li=2;
   }

   glb = galactic(Ra_arr, Dec_arr);
   xy = aitoff(glb(,1),glb(,2));

   plt,"JMX"+itoa(jemxNum)+"    "+ndate(2),0.39,0.88,height=16,justify="CA";
   annot,mode="i"; // Initialize the annotations

   if( bit_extract( which, bitn=1 ) ) {
      // Overplot the sky elements (+1):
      oplot, xy(1,), xy(2,), ps=11, symsize=0.2;
      annot,"Sky elements",ps=11,symsize=0.2; // update annotation
   }
   if( bit_extract( which, bitn=2 ) ) {
      // Overplot the interesting sky elements (+2):
      w = where( Nswids_arr );
      if( numberof(w) > 0 ) {
         oplot, xy(1,w), xy(2,w), ps=11, symsize=0.3,color="green";
         annot,"Observed sky elements",ps=11,symsize=0.3,color="green"; // update annotation
      } else write,"No observed sky elements";
   }
   if( bit_extract( which, bitn=3 ) ) {
      // Overplot the status==1 sky elements (+4):
      w = where( status==1 );
      if( numberof(w) > 0 ) {
        oplot, xy(1,w), xy(2,w), ps=12, symsize=0.4,color="blue";
        annot,"Initiated sky elements",ps=12,symsize=0.4,color="blue"; // update annotation
      } else write,"No initiated sky elements";
   }
   if( bit_extract( which, bitn=4 ) ) {
      // Overplot the status==2 sky elements (+8):
      w = where( status==2 );
      if( numberof(w) > 0 ) {
         oplot, xy(1,w), xy(2,w), ps=13, symsize=0.4,color="magenta";
         annot,"Completed sky elements",ps=13,symsize=0.4,color="magenta"; // update annotation
      } else write,"No completed sky elements";
   }
   if( bit_extract( which, bitn=5 ) ) {
      // Overplot the status==0 and Nswids>0 sky elements - todo's (+16):
      w = where( status==0 & Nswids_arr!=0 );
      if( numberof(w) > 0 ) {
         oplot, xy(1,w), xy(2,w), ps=13, symsize=0.4,color="red";
         annot,"Todo sky elements",ps=13,symsize=0.4,color="red"; // update annotation
      } else write,"No todo sky elements";
   }
   if( bit_extract( which, bitn=6 ) ) {
      // Overplot the sky elements where a mosaic image file exists (+32):
      list = file_search(js+"_mosa_s003_skye????.fits","/jemx/njw/skye_mosa");
      if( numberof(list) > 0 ) {
         pos = strpos( list, "_skye", 1 );
         nlist = numberof(list);
         sskye = array(string,nlist);
         for( i = 1; i <= nlist; i++ ) sskye(i) = strpart( list(i), pos(i)+5:pos(i)+8 );
         w = atoi( sskye );
         oplot, xy(1,w), xy(2,w), ps=11, symsize=0.4,color="red";
         oplot, xy(1,w), xy(2,w), ps=12, symsize=0.4,color="red";
         oplot, xy(1,w), xy(2,w), ps=13, symsize=0.4,color="red";
         annot,"Mosaic exists",ps=[11,12,13],symsize=[0.4,0.4,0.4], \
               color=["red","red","red"]; // update annotation
      } else write,"No mosaic files found";
   }

   annot,pos=[0.1,0],height=16;

}

/* Function status_info */

func status_info( jemxNum, &skye, next=, oview= )
/* DOCUMENT status_info, jemxNum, >skye, next=, oview=

   Prints information about a sky element.
   'skye' is the element number (may be an array).

   Keywords:
     next     Finds the next sky element with SWIDs relative to 'skye'
              and updates argument 'skye'
     oview    For overview

   2008-11-07/NJW, cloned from 'status_plot'
*/

{


   local Nswids_arr;
   if( jemxNum == 1 ) {
      eq_nocopy, Nswids_arr, Nswids_arr1;
      status = rdfitscol( Status_dol, "done_j1");
      js = "jmx1";
   } else if( jemxNum == 2 ) {
      eq_nocopy, Nswids_arr, Nswids_arr2;
      status = rdfitscol( Status_dol, "done_j2");
      js = "jmx2";
   } else error,"STATUS_INFO: Illegal jemxNum";

   if( next ) {
      skye = skye(1);
      if( skye >= numberof(Nswids_arr) ) {
         write,"No more sky elements to consider";
         return;
      }
      w = where( Nswids_arr(skye+1:0) );
      if( numberof(w) > 0 ) {
         skye += w(1);
      } else {
         write,"No filled sky elements beyond given";
         return;
      }
   }
   for( i = 1; i <= numberof(skye); i++ ) {
      write,format="Sky element #%i\n", skye(i);
      write,format="      Number of SWIDs : %4i\n", Nswids_arr(skye(i));
      if( Nswids_arr(skye(i)) == 0 ) continue;
      write,format="               status : %4i\n", status(skye(i));
      if( status(skye(i)) == 1 ) {
         nfail = verify( jemxNum, skye(i) );
         if( nfail == -1 ) nfail = 0; // '-1' reports status == OK (2)
         write,format="  Number of failed SWIDs : %i\n", nfail;
      }
      // check presence of mosaic image file
      strskye = swrite(format="%04i",skye(i));
      if( file_test( "/jemx/njw/skye_mosa/"+js+"_mosa_s003_skye"+strskye+".fits" ) ) {
         write,"      Mosaic image exists";
      } else write,"      No mosaic image";
   }

   if( oview ) {
      wn = where( Nswids_arr > 0 );
      nwn = numberof(wn);
      w0 = where( status(wn) == 0 );
      nw0 = numberof(w0);
      w1 = where( status(wn) == 1 );
      nw1 = numberof(w1);
      w2 = where( status(wn) == 2 );
      nw2 = numberof(w2);
      write,format="%5i sky elements with pointings\n", nwn;
      write,format="%5i sky elements fully verified (%.1f%%)\n", numberof(w2), (100.0*nw2)/nwn;
      write,format="%5i sky elements initiated (%.1f%%)\n", nw1, (100.0*nw1)/nwn;
      write,format="%5i sky elements still not done (%.1f%%)\n", nw0, (100.0*nw0)/nwn;
   }

}


/* Function mosa_updates */

func mosa_updates( jemxNum, choice )
/* DOCUMENT res = mosa_updates( jemxNum )

   Returns a list of sky elements with status == 2 as found from file
   jcat_status.fits and where no mosaic file has been found
   in '/jemx/njw/skye_mosa'.

 How to avoid creating a mosaic image e.g. if the input images have failed
 completely: Set the MOSA_Ji value to -1 in jcat_status.fits

   2008-10-24/NJW
   2009-03-31/NJW, updated to get rid of jcat_statusx.fits

*/
{
   local Nswids_arr;
   if( jemxNum == 1 ) {
      mosacol = "MOSA_J1";
      statcol = "DONE_J1";
      statcoln = 1;
      mosacoln = 3;
      js = "jmx1";
      eq_nocopy, Nswids_arr, Nswids_arr1;
   } else if( jemxNum == 2 ) {
      mosacol = "MOSA_J2";
      statcol = "DONE_J2";
      statcoln = 2;
      mosacoln = 4;
      js = "jmx2";
      eq_nocopy, Nswids_arr, Nswids_arr2;
   } else error,"UPDATES: Illegal jemxNum";

   status = rdfitscol( Status_dol, statcol );
   nrows = numberof(status);

   // get currently known status of mosaic files in 'stat_mosa':
   stat_mosa = rdfitscol( Status_dol, mosacol );
   n_added = 0;
   n_removed = 0;
   // locate existing mosaic image files
   list = file_search(js+"_mosa_s003_skye????.fits","/jemx/njw/skye_mosa");
   nlist = numberof(list);

   if( nlist > 0 ) { // Count number of added and removed files
      pos = strpos( list, "_skye", 1 );
      sskye = array(string,nlist);
      for( i = 1; i <= nlist; i++ ) sskye(i) = strpart( list(i), pos(i)+5:pos(i)+8 );

      // update 'stat_mosa' status array with fresh information on mosaic files just found

      w = atoi( sskye );
      w = w(sort(w));
      k = 1;
      for( i = 1; i <= nrows; i++ ) {
         if( i == w(k) ) {
            if( stat_mosa(i) == 0 ) { // new mosaic image file added
               stat_mosa(i) = 1;
               n_added++;
            }
            if( k < nlist ) k++;
         } else {
            if( stat_mosa(i) == 1 ) { // a previously detected mosaic file not found
               stat_mosa(i) = 0;
               n_removed++;
            }
         }
      }
   } else {

      n_removed = stat_mosa(sum);
      stat_mosa() = 0;

   }

   // update jcat_status.fits

   row = 1;
   write,"Updating jcat_status.fits with new mosaic file status ...";
   upd_status_file, row, mosacoln, stat_mosa;

   write,format="%6i added mosaic image files\n", n_added;
   write,format="%6i removed mosaic image files\n", n_removed;

   // return list of status==2 sky elements with no mosaic file

   w = where( status == 2 & stat_mosa == 0 );
   nw = numberof( w );
   if( nw > 0 ) {
      todo_list = indgen(nrows);
      return todo_list(w);
   } else {
      return [];
   }

}

/* Function do_mosaics */

func do_mosaics( jemxNum, skye, limit=, sel= )
/* DOCUMENT do_mosaics, jemxNum, skye, limit=, sel=

   Make the mosaic image for sky element(s) 'skye' (can be an array)
   with status==2 in jcat_status.fits.

   If the argument 'skye' is not given then
   mosaic images are made for all sky elements with status==2 in
   jcat_status.fits and not yet done.

   Keyword 'limit' can be given as the maximal number of mosaic
   images to produce.

   Keyword 'sel' is a (long) array with CPU numbers (1-11)
   or rather subdirectory numbers (/r9/njw/jemx/mosanaNN) to
   use. Useful to avoid a clash between processes.

   2008-10-27/NJW
*/
{

   nskye = numberof(skye);
   ms = nskye > 1;
   if( is_void(skye) || ms ) {  // Locate all 'not done' mosaics and
                          // launch the script to produce them

      if( ms ) {
         todo_list = skye;
      } else {
         todo_list = mosa_updates( jemxNum );
      }
      n_todo_list = numberof( todo_list );
      if( n_todo_list == 0 ) {
         write,"Nothing to do - terminate";
         return;
      }
      if( limit ) {
         if( limit < n_todo_list ) {
            todo_list = todo_list(1:limit);
            n_todo_list = limit;
         }
      }
      if( !is_void(sel) ) {
         n_cpus = numberof(sel);
      } else {
         n_cpus = 8;
         sel = indgen(8);
      }

      //  Distribute on n_cpus CPUs

      n = n_todo_list / n_cpus; // basic number of processes per CPU
      r = n_todo_list % n_cpus; // remainder: n_todo_list = n*n_cpus + r

      curwd = get_cwd();
      for( i = 1; i <= n_cpus; i++ ) {
         cpu = sel(i);
         np = n + (i <= r); // number of processes to this CPU
         write,format="#%4i with %4i processes\n", cpu, np;
         if( np > 0 ) {
            li = todo_list(1:np); // 'li' holds the sky elements to be
                             // processed by this CPU
            if( np < numberof(todo_list ) ) todo_list = todo_list(1+np:0);
            dirname = swrite(format="mosana%02i",cpu);
            cd,"/r9/njw/jemx/"+dirname;
            write_slist,"todo.list", swrite(format="%7i", li);
            system,"mrun_mos_skye "+itoa(jemxNum)+" &";
         }
      }
      cd, curwd;

   } else { // Produce a specific mosaic image

      status = get_status( jemxNum, skye );
      if( status != 2 ) {
         write,format="Status = %i, no action\n", status;
         return;
      }
      js = swrite(format="jmx%i", jemxNum );
      strskye = swrite(format="skye%04i", skye);
      mos_file_name = "/jemx/njw/skye_mosa/"+js+"_mosa_s003_"+strskye+".fits";
      if( file_test(mosa_file_name) ) {
         ans = "";
         read,prompt="Going to overwrite "+mos_file_name+", proceed ? ... ", ans;
         if( ans != "y" ) return;
         remove, mos_file_name;
      }

      cpu = is_void(sel) ? 1 : sel(1);
      curwd = get_cwd();
      dirname = swrite(format="mosana%02i",cpu);
      cd,"/r9/njw/jemx/"+dirname;
      // 'todo.list' will contain a single line
      write_slist,"todo.list", swrite(format="%7i", skye);
      system,"mrun_mos_skye "+itoa(jemxNum)+" &";
      cd, curwd;
   }

}

/* Function mk_srcl_res_cat */

func mk_srcl_res_cat( jemxNum, skye )
/* DOCUMENT mk_srcl_res_cat, jemxNum[, skye]

   Produces a catalog of sources in /r9/njw/yorick/jcat/<vername>
   The cat_pack.i function 'collect_src_info' must have been
   run beforehand.
   If 'skye' is not given then all sky elements will be included.

   2009-04-24/NJW
*/
{
   local dirlist;

   n_skye = numberof(skye);
   js = swrite(format="jmx%i", jemxNum);

   local Nswids_arr;
   if( jemxNum == 1 ) {
      eq_nocopy, Nswids_arr, Nswids_arr1;
   } else {
      eq_nocopy, Nswids_arr, Nswids_arr2;
   }

   if( n_skye == 0 ) {
      skye = where(Nswids_arr);
      n_skye = numberof(skye);
   }

   // find the list of directories that exist

   dum = lsdir( Basdir+"/srcl_res/skies", dirlist );
   w = where( strpart(dirlist, 1:4) == "skye" );
   dirlist = dirlist(w);
   dirlist = dirlist(sort(dirlist));

   coll_list = [];

   for( i = 1; i<= n_skye; i++ ) {
      nswids = Nswids_arr(skye(i));
      subdir = swrite(format="skye%04i", skye(i));
      w = where( subdir == dirlist );
      if( numberof(w) == 0 ) {
         write,format="The %s subdirectory does not exist\n", subdir;
         continue;
      }
      skyedir = Basdir+"/srcl_res/skies/"+subdir;
      fname = Basdir+"/srcl_res/skies/"+subdir+"/"+js+"_collect_srcl_res_s003.fits";
      if( file_test(fname) ) grow, coll_list, fname;
   }

   n = numberof(coll_list);
   fst = create("coll_srcl_res_dols.txt");
   for(i=1;i<=n;i++) {
      write,format="%s\n", coll_list(i);
      write,fst,format="%s+1\n", coll_list(i);
   }
   close, fst;

   // with the list of DOLs go ahead and get the information

   write,"Now you can execute the following command on a system";
   write,"where fmerge is available:";
   write,"fmerge @coll_srcl_res_dols.txt /r9/njw/yorick/jcat/"+vername+"/" \
           +js+"_srcl_res_cat.fits col=-"
}

/* Function collect_src_info */

func collect_src_info( jemxNum, skye )
/* DOCUMENT collect_src_info, jemxNum, skye

   Produces a collected SRCL-RES file with sources from
   all individual SRCL-RES files with the given 'skye'
   The file 'jmxi_collect_srcl_res.fits' is placed in the
   sky element directory: /jemx/njw/srcl_res/skies/skyeNNNN

   'skye' can be an array

   2008-10-29/NJW

*/
{
   local dirlist;

   n_skye = numberof(skye);
   js = swrite(format="jmx%i", jemxNum);

   local Nswids_arr;
   if( jemxNum == 1 ) {
      eq_nocopy, Nswids_arr, Nswids_arr1;
   } else {
      eq_nocopy, Nswids_arr, Nswids_arr2;
   }

   dum = lsdir( Basdir+"/srcl_res/skies", dirlist );
   w = where( strpart(dirlist, 1:4) == "skye" );
   dirlist = dirlist(w);
   dirlist = dirlist(sort(dirlist));

   for( i = 1; i<= n_skye; i++ ) {
      nswids = Nswids_arr(skye(i));
      subdir = swrite(format="skye%04i", skye(i));
      w = where( subdir == dirlist );
      if( numberof(w) == 0 ) {
         write,format="The %s subdirectory does not exist\n", subdir;
         continue;
      }
      skyedir = Basdir+"/srcl_res/skies/"+subdir;

      list = file_search( js+"_srcl_res_s003_*.fits", skyedir );
      if( is_void(list) ) {
         write,format="No %s_srcl_res_s003_*.fits files in %s\n", js, skyedir;
         if( nswids > 0 ) {
            write,format="  although %i were expected\n", nswids;
         } else write,"                    as expected";
      } else {
         j_get_srcl_res_sources_a, list, \
            resfile=skyedir+"/"+js+"_collect_srcl_res_s003.fits",silent=1;
         write,format="Has now produced %s\n", \
               skyedir+"/"+js+"_collect_srcl_res_s003.fits";
         if( nswids == 0 ) write,"  although no SWIDs were expected";
      }
   }

}

/* Function find_images */

func find_images( ra, dec, opt= )
/* DOCUMENT list = find_images( ra, dec, opt= )

   2008-11-18/NJW
*/
{
   r = arcdist( ra, dec, Ra_arr, Dec_arr );
   is = sort(r);

   i = 1;
   while (r(is(i)) < 15. ) {
      skyestr = swrite(format="skye%04i",is(i));
      mosa_name = "/jemx/njw/skye_mosa/jmx1_mosa_s003_"+skyestr+".fits";
      if( file_test(mosa_name) ) {
         write,format="%7.2f %s\n", r(is(i)), mosa_name;
      }
      mosa_name = "/jemx/njw/skye_mosa/jmx2_mosa_s003_"+skyestr+".fits";
      if( file_test(mosa_name) ) {
         write,format="%7.2f %s\n", r(is(i)), mosa_name;
      }
      i++;
   }

}

/* Function mosa_check */

func mosa_check( jemxNum, flog=, beginend= )
/* DOCUMENT mosa_check, jemxNum, flog=, beginend=

   Report on levels of the values in the images in the mosaic files
   i.e. median of values above zero and of those below zero for
   IMATYPE RECON, VARIA, SIGNI and for 3 energy levels, in total
   18 numbers in order to check for errors.

   Keyword flog: Name of logging file
           beginend: 2-element int array with skye for begin and end
*/
{

   local Nswids_arr;
   if( jemxNum == 1 ) {
      mosacol = "MOSA_J1";
      statcol = "DONE_J1";
      statcoln = 1;
      mosacoln = 3;
      js = "jmx1";
      eq_nocopy, Nswids_arr, Nswids_arr1;
   } else if( jemxNum == 2 ) {
      mosacol = "MOSA_J2";
      statcol = "DONE_J2";
      statcoln = 2;
      mosacoln = 4;
      js = "jmx2";
      eq_nocopy, Nswids_arr, Nswids_arr2;
   } else error,"UPDATES: Illegal jemxNum";

   mosa_status = rdfitscol( Status_dol, mosacol );
   nrows = numberof(mosa_status);
   w = where(mosa_status == 1);
   if( numberof(w) == 0 ) {
      write,"No mosaic image files exist";
      return;
   }

   if( !is_void(beginend) ) {
       // is scalar then expand to two-element array
      if( numberof(beginend) == 1 ) grow, beginend, beginend;
      if( numberof(beginend) != 2 ) error,"'beginend' is not a 2 element array";
      if( structof(beginend) != int && structof(beginend) != long ) error, \
                                     "'beginend' is not an integer array";
      incl = where(w >= beginend(1) & w <= beginend(2));
      if( numberof(incl) == 0 ) {
         write,"The selection excluded all sky elements - quit";
         return;
      }
      w = w(incl);
   }
   nw = numberof(w);

   if( structof(flog) == string ) {
      flog = open( flog, "w" );
      flag = 1;
      write,flog,format="%s Median values for pos and neg values. %s\n", \
              strupcase(js), ndate(3);
      write,flog,format="    %s%s%s\n",strpadd("Eband1",48,' '), \
              strpadd("Eband2",48,' '),strpadd("Eband3",48,' ');
      r = strpadd("RECON",16,' '); v = strpadd("VARIA",16,' ');
      s = strpadd("SIGNI",16,' ');
      write,flog,format="    %s%s%s%s%s%s%s%s%s\n",r,v,s,r,v,s,r,v,s;
      m = "   < 0  "; p = "   > 0  ";
      write,flog,format="SKYE%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s\n", \
           m,p,m,p,m,p,m,p,m,p,m,p,m,p,m,p,m,p;
   } else flag = 0;

   for( i = 1; i <= nw; i++ ) {
      fn = "/jemx/njw/skye_mosa/"+js+swrite(format="_mosa_s003_skye%04i.fits", w(i));
      if( !file_test(fn) ) error,"Problem with "+fn;
      write,format="%04i", w(i);
      if(flag) write,flog,format="%04i", w(i);
      for( extno = 2; extno <= 12; extno++ ) {
         if( (extno-1)%4 == 0 ) continue; // skip EXPOSURE
         z = nan2zero(readfits(fn+"+"+itoa(extno),skiptest=1));
         wp = where( z > 0 );
         wm = where( z < 0 );
         plevel = numberof(wp) ? median(z(wp)): 0.0;
         mlevel = numberof(wm) ? median(z(wm)): 0.0;
         write,format=" %7.3f %7.3f",mlevel,plevel;
         if( flag ) write,flog,format=" %7.3f %7.3f",mlevel,plevel;
      }
      write,"";
      if(flag)write,flog,"";
   }

   if(flag) close, flog;
}

/* Function fverify */

func fverify( jemxNum, skyea, sz= )
/* DOCUMENT fverify, jemxNum[, skye][, sz=]

   Runs through all sky elements or those given by
   'skye' (scalar or array).

   Keyword 'sz' causes file sizes to the checked

*/
{
   local Nswids_arr;
   if( jemxNum == 1 ) {
      colname = "done_j1";
      Dist_dol = Dist_dol1;
      statcoln = 1;
      eq_nocopy, Nswids_arr, Nswids_arr1;
      name_failed_swids = "jmx1_fail1.scm";
      js = "jmx1";
   } else {
      colname = "done_j2";
      Dist_dol = Dist_dol2;
      statcoln = 2;
      eq_nocopy, Nswids_arr, Nswids_arr2;
      name_failed_swids = "jmx2_fail1.scm";
      js = "jmx2";
   }

   status = rdfitscol( Status_dol, colname );

   if( is_void(skyea) ) {
      w = where( Nswids_arr );
   } else {
      w = skyea;
   }
   nw = numberof(w);

   failed_swids = read_slist( name_failed_swids );

   fstream = get_next_filename(js+"_fverify_????.txt");
   stream = create(fstream);

   local swid_srcl_res, swid_sky_ima;

   for( i = 1; i <= nw; i++ ) { // loop over requested sky elements
      ok = 1; // flag for being in order
      skye = w(i);
      subdir = swrite(format="skies/skye%04i", skye);
      write,subdir;
      // get list of all files in srcl_res subdirectory:
      ls_srcl_res = lsdir(Basdir+"/srcl_res/"+subdir);
      swid_srcl_res = [];
      if( typeof(ls_srcl_res) == "string" ) {
         // select the ones for chosen instrument:
         c = strpart(ls_srcl_res,1:18);
         u = where(c ==js+"_srcl_res_s003");
         nu = numberof(u);
         if( nu ) {
            ls_srcl_res = ls_srcl_res(u);
            pick_swid_str, ls_srcl_res, swid_srcl_res;
            if( sz ) {
               for(l=1;l<=nu;l++) {
                  flsz = filesize(Basdir+"/srcl_res/"+subdir+"/"+ls_srcl_res(l));
                  if( flsz <= 11520 ) {
                     ok = 0;
                     write,format="Skye%04i Sz = %i : %s\n", \
                                skye, flsz, ls_srcl_res(l);
                     write,stream,format="Skye%04i Sz = %i : %s\n", \
                                skye, flsz, ls_srcl_res(l);
                  }
               }
            }
         }
      }

      // get list of all files in sky_ima subdirectory:
      ls_sky_ima = lsdir(Basdir+"/sky_ima/"+subdir);
      swid_sky_ima = [];
      if( typeof(ls_sky_ima) == "string" ) {
         c = strpart(ls_sky_ima,1:17);
         u = where(c ==js+"_sky_ima_s003");
         nu = numberof(u);
         if( nu ) {
            ls_sky_ima = ls_sky_ima(u);
            pick_swid_str, ls_sky_ima, swid_sky_ima;
            if( sz ) {
               for(l=1;l<=nu;l++) {
                  flsz = filesize(Basdir+"/sky_ima/"+subdir+"/"+ls_sky_ima(l));
                  if( flsz <= 1000000 ) {
                     ok = 0;
                     write,format=\
                      "Skye%04i Sz = %i : %s\n", skye, flsz, ls_sky_ima(l);
                     write,stream,\
                      format="Skye%04i Sz = %i : %s\n", skye, flsz, ls_sky_ima(l);
                  }
               }
            }
         }
      }

      // Make list of SWIDs attached to the sky element
      dswids = fits_bintable_peek( Dist_dol, skye, 4 );
      n_swid_list = numberof(dswids);
      dswids = dswids(sort(dswids)); // sort
      // Convert from double representation to string representation:
      swid_list = swrite(format="%012.0f", dswids);

      // remove swids that have already been marked as bad
      swid_list = filter_done( failed_swids, swid_list );
      nswid_list = numberof(swid_list);

      if( !is_void(swid_srcl_res) ) {
         z = filter_done( swid_list, swid_srcl_res )
         nz = numberof(z);
         if( nz ) {
            ok = 0;
            for(k=1;k<=nz;k++) write,format= \
              "Skye%04i srcl unexpected SWID: %s\n", skye, z(k);
            for(k=1;k<=nz;k++) write,stream,format= \
              "Skye%04i srcl unexpected SWID: %s\n", skye, z(k);
         }
      }
      if( !is_void(swid_sky_ima) ) {
         y = filter_done( swid_list, swid_sky_ima )
         ny = numberof(y);
         if( ny ) {
            ok = 0;
            for(k=1;k<=ny;k++) write,format= \
              "Skye%04i ima  unexpected SWID: %s\n", skye, y(k);
            for(k=1;k<=ny;k++) write,stream,format= \
              "Skye%04i ima  unexpected SWID: %s\n", skye, y(k);
         }
      }
      if( nswid_list == 0 ) continue; // none are expected

      // filter out those swids that are expected but not found
      // to 'a' and 'b' (srcl_res and sky_ima resp.)
      a = filter_done( swid_srcl_res, swid_list );
      b = filter_done( swid_sky_ima, swid_list );

      na = numberof(a);
      nb = numberof(b);

      if( na || nb ) ok = 0; // files are missing

      if( na && nb ) {
         ab = filter_common( a, b );
         nab = numberof(ab);
         if( na == nb && nab == na ) { // standard situation
            for(k=1;k<=na;k++) {
               write,format="Skye%04i srcl+sky both missing for SWID %s\n", skye, a(k);
               write,stream,format= \
              "Skye%04i srcl+sky both missing for SWID %s\n", skye, a(k);
            }
         } else {
            for(k=1;k<=na;k++) write,format= \
              "Skye%04i srcl missing for SWID %s\n", skye, a(k);
            for(k=1;k<=na;k++) write,stream,format= \
              "Skye%04i srcl missing for SWID %s\n", skye, a(k);
            for(k=1;k<=nb;k++) write,format= \
              "Skye%04i sky  missing for SWID %s\n", skye, b(k);
            for(k=1;k<=nb;k++) write,stream,format= \
              "Skye%04i sky  missing for SWID %s\n", skye, b(k);
         }
      } else if( na ) {
         for(k=1;k<=na;k++) write,format= \
              "Skye%04i srcl missing for SWID %s\n", skye, a(k);
         for(k=1;k<=na;k++) write,stream,format= \
              "Skye%04i srcl missing for SWID %s\n", skye, a(k);
      } else if( nb ) {
         for(k=1;k<=nb;k++) write,format= \
              "Skye%04i sky  missing for SWID %s\n", skye, b(k);
         for(k=1;k<=nb;k++) write,stream,format= \
              "Skye%04i sky  missing for SWID %s\n", skye, b(k);
      }

      // Note if there is an inconsistency between status and the
      // findings here

      if( ok ) {
         if( status(skye) < 2 ) {
            write,format="Skye%04i OK but status = %i\n", skye, status(skye);
            write,stream,format="Skye%04i OK but status = %i\n", status(skye);
         }
      } else {
         if( status(skye) == 2 ) {
            write,format="Skye%04i Not OK but status = %i\n", skye, status(skye);
            write,stream,format="Skye%04i Not OK but status = %i\n", skye, status(skye);
         }
      }
   }

   close, stream;
   write,format="You'll find the output in %s\n", fstream;
}

/* Function mk_jcat_status */

func mk_jcat_status( void )
/* DOCUMENT mk_jcat_status

     Will delete the 'jcat_status.fits' and make it again
     from scratch using input from jmx1_dist_1476.fits and
     jmx2_dist_1476.fits

     2009-12-07/NJW
*/
{
   ans = "";
   read,prompt="Are you sure you want to delete jcat_status.fits ? ... ", ans;

   if( strlowcase(strpart(ans,1:1)) == "y" ) {
      remove, "jcat_status.fits";
   } else {
      write,"OK, action skipped ...";
      return;
   }

   e1 = file_test("jmx1_dist_1476.fits");
   e2 = file_test("jmx2_dist_1476.fits");
   if( !e1 ) write,"jmx1_dist_1476.fits was not found";
   if( !e2 ) write,"jmx2_dist_1476.fits was not found";
   if(e1+e2 != 2 ) return;

   d = array(0,1476);
   nsw1 = rdfitscol("jmx1_dist_1476.fits+1","nswids");
   nsw2 = rdfitscol("jmx2_dist_1476.fits+1","nswids");
   wrmfitscols,"jcat_status.fits", "DONE_J1", d, "DONE_J2", d, \
               "MOSA_J1", d, "MOSA_J2", d, \
               "NSWIDS_J1", nsw1, "NSWIDS_J2", nsw2;
}

/* Function setup_dist_1476 */

func setup_dist_1476
/* DOCUMENT setup_dist_1476

    Generate the original versions of jmx1_dist_1476.fits and
    jmx2_dist_1476.fits without the SWID allocations.
*/
{
   orig = "/r9/njw/yorick/jcat/distfiles/dist_01476_000.fits+1"
   ra = rdfitscol(orig,"ra");
   dec = rdfitscol(orig,"dec");
   n = numberof(ra);
   nswids = array(long,n);
   fh = headfits( orig );
   fits_copy_keys,fh,tokwds=1;
   remove,"jmx1_swid_skye.fits";
   remove,"jmx2_swid_skye.fits";
   remove,"jmx1_dist_1476.fits";
   remove,"jmx2_dist_1476.fits";
   wrmfitscols,"jmx1_dist_1476.fits","RA",ra,"DEC",dec,"NSWIDS",nswids,"SWIDLIST",1.,var=4;
   wrmfitscols,"jmx2_dist_1476.fits","RA",ra,"DEC",dec,"NSWIDS",nswids,"SWIDLIST",1.,var=4;
   write,"New files have been generated from /r9/njw/yorick/jcat/distfiles/dist_01476_000.fits+1";
}
%FILE% cat_selfconsistency.i
/* Function cat_selfconsistency */

func cat_selfconsistency( dol_cat, mindist= )
/* DOCUMENT cat_selfconsistency, dol_cat, mindist=

   2006-01-11/NJW   based on earlier version in /home/njw/work

*/
{

   read_catalog, dol_cat;

   write,"Checking names ...";

   namework = Source_cat.name;
   n_mult = 0;
   nm = 1;
   while( nm  >  0 ) {

      w = where( strtrim(namework)  ==  strtrim(namework(1)) );
      nw = numberof(w);
      if( nw  >=  2 ) {
         write,"Source "+namework(1)+" is found "+itoa(nw)+" times in "+dol_cat;
         n_mult++;
      }

      m = where( strtrim(namework)  !=  strtrim(namework(1)) );
      nm = numberof(m);
      if( nm  >  0 ) namework = namework(m);

   }

   if( n_mult  ==  0 ) write,"No repeated names found.";
   else write,itoa(n_mult)+" cases of repeated names.";

   write,"Checking source positions ...";

   n_coin = 0;
   nm = 1;
   ra_work = Source_cat.ra_obj;
   dec_work = Source_cat.dec_obj;
   erad_work = Source_cat.err_rad;
   namework = Source_cat.name;

   while( nm  >  0 ) {

      // find cases where dist < err_rad1 + err_rad2
      // or - equivalently : dist - err_rad2 < err_rad1

      dist = arcdist(ra_work(1), dec_work(1), ra_work, dec_work );
      if( numberof(mindist) ) {
         w = where( dist  <  mindist );
         m = where( dist  >= mindist );
      } else {
         w = where( dist  <  erad_work(1)+erad_work );
         m = where( dist  >= erad_work(1)+erad_work );
      }
      nw = numberof(w);
      nm = numberof(m);

      if( nw  >  1 ) {
         n_coin++;
         write,"";
         write,"Catalog source: "+namework(1)+" "+ \
            swrite(format="%8.3f%8.3f matches the position of",ra_work(1),dec_work(1));
         for( j = 2; j <= nw; j++ ) {
            write,"                  "+namework(w(j))+" "+ \
               swrite(format="%8.3f%8.3f",ra_work(w(j)),dec_work(w(j)));
         }
      }

      if( nm  >  0 ) {
         ra_work = ra_work(m);
         dec_work = dec_work(m);
         erad_work = erad_work(m);
         namework = namework(m);
      }

   }

   if( n_coin  ==  0 ) write,"No coincident positions found.";
   else write,itoa(n_coin)+" coincidences of positions."

}
%FILE% catplot.i
func catplot( radec, dia )
/* DOCUMENT catplot, radec, dia

   radec : two element array (RA, DEC) in degrees
   dia   : size of plot frame in degrees

   SEE ALSO: srcdetails
*/
{
   extern Ra, Dec, Ra0, Dec0;

   if( is_void(Ra) || is_void(Dec) ) {
      write,"Ra and Dec arrays must have defined outside 'catplot'";
      return;
   }
   Ra0 = radec(1);
   Dec0 = radec(2);
   xr = [-dia*0.5,dia*0.5]/cos(Dec0*pi/180.);
   yr = [-dia*0.5,dia*0.5];
   plot,Ra-Ra0,Dec-Dec0,xr=xr,yr=yr,ps=2, \
     ytitle=swrite(format="DEC %.3f", Dec0), \
     xtitle=swrite(format="RA %.3f", Ra0);
   v = span(0.,2*pi,100);
   cx = cos(v);
   cy = sin(v);
   oplot,0.05*cx, 0.05*cy;
   oplot,0.10*cx, 0.10*cy;
}

func srcdetails( void )
{
   extern Ra, Dec, Ra0, Dec0, Swid, Detsig;

   if( is_void(Swid) || is_void(Detsig) ) {
      write,"Swid and Detsig arrays must have been defined outside 'srcdetails'";
      return;
   }
   m = curmark1(nomark=1);
   ram = Ra0 + m(1);
   decm = Dec0 + m(2);
   r = arcdist(ram,decm,Ra,Dec);
   is = sort(r);
   k = is(1);
   write,format="Source#%i, (%.3f,%.3f) DETSIG=%.1f  %s\n", \
        k, Ra(k), Dec(k), Detsig(k), Swid(k);
}
%FILE% catprint.i
func catprint( dol_cat, s_id=, ds=, rasort=, namesort= )
/* DOCUMENT catprint, dol_cat, s_id=, ds=, rasort=, namesort=

     Nice print of source catalog with columns
     NAME, RA_OBJ, DEC_OBJ
     Additional columns by keywords:
     's_id'  SOURCE_ID
     'ds'    DETSIG

     Sorting by R.A. is achieved by setting keyword 'rasort'.
     Sorting by name is achieved by setting keyword 'namesort'.

    2010-09-02/NJW
*/
{
   local file, extno;

   get_exten_no, dol_cat, file, extno;
   ffile = fullpath(file);
   outfile = get_next_filename("catprint_????.txt");
   fl = open(outfile,"w");
   write,fl,format="Catalog print (catprint) %s\n", ndate(3);
   write,fl,format="\n    Catalog: %s\n\n", ffile+"+"+itoa(extno);

   fmt = "";
   hline = "";

   ra = rdfitscol(dol_cat,"ra_obj");
   dec = rdfitscol(dol_cat,"dec_obj");
   name = strtrim(rdfitscol(dol_cat,"name"));
   if( s_id ) {
      source_id = rdfitscol(dol_cat,"source_id");
      if( is_void(source_id) ) {
         s_id = 0;
      } else {
         source_id = strtrim(source_id);
         fmt = fmt + "%14s ";
         hline = hline + "   SOURCE_ID  ";
      }
   }

   fmt = fmt + "%20s %9.3f%9.3f";
   hline = hline + "           NAME           RA      Dec   ";
   if( ds ) {
      detsig = rdfitscol(dol_cat,"detsig");
      if( is_void(detsig) ) {
         ds = 0;
      } else {
         fmt = fmt + "%9.2f";
         hline = hline + "   DETSIG";
      }
   }
   fmt += "\n";

   write,fl,format="%s\n", hline;
   n = numberof(ra);
   if( rasort ) {
      is = sort(ra);
      ra = ra(is);
      dec = dec(is);
      name = name(is);
      if( ds ) detsig = detsig(is);
      if( s_id ) source_id = source_id(is);
   }
   if( namesort ) {
      is = sort(strupcase(name));
      ra = ra(is);
      dec = dec(is);
      name = name(is);
      if( ds ) detsig = detsig(is);
      if( s_id ) source_id = source_id(is);
   }

   for(i = 1; i <= n; i++ ) {
      if( s_id ) {
         if( ds ) {
            write,fl,format=fmt,source_id(i),name(i),ra(i),dec(i),detsig(i);
         } else {
            write,fl,format=fmt,source_id(i),name(i),ra(i),dec(i);
         }
      } else {
         if( ds ) {
            write,fl,format=fmt,name(i),ra(i),dec(i),detsig(i);
         } else {
            write,fl,format=fmt,name(i),ra(i),dec(i);
         }
      }
   }
   close, fl;

}
%FILE% clocka.i
window,0,style="nobox.gs";
limits,0,1,0,1;
for( i = 0; i <= 23; i++ ) {
   xyouts,0.1,0.95-i*0.95/24.,swrite(format="%02i",i);
}
parsedate,timestamp(),day,month,year,hour,minute,second;
xv = span(0.2,0.9,12);

for( i = 0; i <= hour; i++ ) {
   y0 = 0.95-i*0.95/24.+0.35/24.;
   wi = i <= 8 ? 12 : 1;
   // plmk,[y0],[0.2],marker=5,msize=0.5;
   if( i < hour ) {
      plmk,array(y0,12),xv,marker=1,msize=0.7,width=wi;
   } else {
      m = minute/5;
      if( m ) {
         plmk,array(y0,m),xv(1:m),marker=1,msize=0.7;
      }
   }
}

for(;;) {
   pause, 60000;
   parsedate,timestamp(),dayx,monthx,yearx,hourx,minutex,secondx;
   np = 0;
   if( hourx > hour ) {
      y0 = 0.95 - hourx*0.95/24.+0.35/24.;
      hour = hourx;
      np = 1;
   }
   mx = minutex/5;
   if( mx != m ) {
      m = mx;
      np = 1;
   }
   if( np ) {
      plmk,[y0],xv(m:m),marker=1,msize=0.7;
   }
}

%FILE% clocki.i
for(;;) {
   window,0,style="nobox.gs";
   xyouts, 0.4, 0.7, ndate(3), align=0.5, charsize=2, device=1;
   pause, 300;
}
%FILE% cmplxplot.i
// Plot routine for a scalar complex function of a complex variable
// Author: Georg Michel <georg@itpgyro1.fzk.de>
// Date: 11/08/97

require, "digit2.i"

func cmplxplot(z, u)
/* DOCUMENT cmplxplot, z, u
   plots a scalar complex function of a complex variable. Z and U are
   two dimensional complex arrays. U contains the sampling points as a
   quadrilateral mesh and Z contains the corresponding function
   values. In the plot, the color represents the argument of Z in a
   cyclic colormap. 2/3*pi is red, -2/3*pi is blue and 0 is green. So
   there are no color steps between +pi and -pi. The contour lines
   represent the absolute value of Z.
*/
{
   resx=100;
   resy=100;
   s=[[sqrt(2./3.),0,1/sqrt(3)],[-1/sqrt(2*3.0),1/sqrt(2.),1/sqrt(3)],
      [-1/sqrt(2*3.0),-1/sqrt(2.),1/sqrt(3)]];
   phi=span(-pi,pi,256);
   vec=array(double,3,256);
   vec(1,)=cos(phi);
   vec(2,)=sin(phi);
   vec(3,)=1/sqrt(2)(-);
   f=s(+,)*vec(+,);
   palette,bytscl(f(2,),top=255),bytscl(f(1,),top=255),bytscl(f(3,),top=255);
   xmin=min(u.re);
   xmax=max(u.re);
   ymin=min(u.im);
   ymax=max(u.im);
   zi=array(complex,resx,resy);
   zi.re=interp2(span(ymin,ymax,resy)(-:1:resx,),span(xmin,xmax,resx)(,-:1:resy),
         z.re,u.im,u.re);
   zi.im=interp2(span(ymin,ymax,resy)(-:1:resx,),span(xmin,xmax,resx)(,-:1:resy),
         z.im,u.im,u.re);
   // Caution: on some platforms atan(0,0) crashes !
   arr=bytscl(atan(zi.im,zi.re+1e-200),cmin=-pi,cmax=pi);
   pli,arr, xmin,ymin,xmax,ymax;
   plc,abs(z),u.im,u.re,marks=0;
}
%FILE% combine_spectra.i
func combine_spectra( list_of_spectra, outfile, bkgfile )
/* DOCUMENT combine_spectra, list_of_spectral_files, outfile, bkgfile

     Adds the spectra that appear as the first one in each file.
     Treat background spectra at the same time.
*/
{
   local ser_str, hdr, nrows, bckfile;

   n = numberof(list_of_spectra);

   if( is_void(outfile) ) {
      outfile = get_next_filename("spec_comb_????.fits", ser_str);
      bkgfile = "bkg_comb_"+ser_str+".fits";
   }
   if( is_void(bkgfile) ) {
      dummy = get_next_filename("spec_comb_????.fits", ser_str);
      bkgfile = "bkg_comb_"+ser_str+".fits";
   }

   for( i = 1; i <= n; i++ ) {
      if( !file_test(list_of_spectra(i)) ) error,"Did not find "+list_of_spectra(i);
      if(i==1)cp, list_of_spectra(i), outfile;
      if(i==1)cp, list_of_spectra(i), bkgfile;
      ptr = rdfitsbin( list_of_spectra(i)+"+1", hdr, nrows);
      rate = (*ptr(fits_colnum(hdr,"rate")))(1,);
      if( i == 1 ) {
         n_rate1 = numberof(rate);
      } else {
         if( numberof(rate) != n_rate1 ) error,"Spec#"+itoa(i)+" differs in number of channels";
      }
      stat_err = (*ptr(fits_colnum(hdr,"stat_err")))(1,);
      backfile = strtrim((*ptr(fits_colnum(hdr,"backfile")))(1,));
      ancrfile = strtrim((*ptr(fits_colnum(hdr,"ancrfile")))(1,));
      if(i==1) {
         exposure = fxpar(hdr,"exposure");
         if(is_void(exposure)) exposure = 1.0;
         respfile = fxpar(hdr,"respfile");
      }
      get_exten_no, backfile, bckfile, dum, tub=1;
      if( !file_test(bckfile) ) error,"Did not find "+bckfile;
      ptr = rdfitsbin( bckfile+"+1", hdr, nrows);
      brate = (*ptr(fits_colnum(hdr,"rate")))(1,);
      bstat_err = (*ptr(fits_colnum(hdr,"stat_err")))(1,);
      if( i == 1 ) {
         rate_all = rate(,-);
         stat_err_all = stat_err(,-);
         brate_all = brate(,-);
         bstat_err_all = bstat_err(,-);
      } else {
         grow, rate_all, rate;
         grow, stat_err_all, stat_err;
         grow, brate_all, brate;
         grow, bstat_err_all, bstat_err;
      }
   }
   local s_rate_all, s_stat_err_all;
   local s_brate_all, s_bstat_err_all;
   j_add_spectra, rate_all, stat_err_all, s_rate_all, s_stat_err_all;
   j_add_spectra, brate_all, bstat_err_all, s_brate_all, s_bstat_err_all;

   write,"##1##";
   fits_bintable_poke,outfile+"+1",1,"rate",float(s_rate_all);
   fits_bintable_poke,outfile+"+1",1,"stat_err",float(s_stat_err_all);

   write,"##2##";
   fits_bintable_poke,bkgfile+"+1",1,"rate",float(s_brate_all);
   fits_bintable_poke,bkgfile+"+1",1,"stat_err",float(s_bstat_err_all);

}
%FILE% comhdr.i
/* Function comhdr */

func comhdr( filename )
/* DOCUMENT hdr = comhdr( filename )

     Returns a string array with all lines not interpreted as genuine table lines
     i.e. those disregarded by 'rscol' and 'rsmat'.

     2012-02-29/NJW
*/

{


   file = open(filename,"r");

   kount = 1;
   linenumber = 0;
   res = [];

   while( s = rdline(file) ) {

     st = strtrim(s); // remove leading and trailing blanks
     if( strlen(st) > 0 ) {
        if( !strmatch("+-.0123456789",strpart(st,1:1))  ) {
            grow,res, s;
        }
      }
   }
   close, file;

   return( res );

}

%FILE% completion_meter.i
func completion_meter( mode, band, frac, text= )
/* DOCUMENT completion_meter, mode, band[, frac][, text= ]

     Displays a window with horizontal bars that are filled
     to the indicated fraction.

     mode
      0     Initialization, 'band' is the number of bars to use
            1 <= band <= 4. The keyword 'text' can contain a
            string array with titles to the bars.

      1     Update. 'band' is the band number to be updated with
            fraction 'frac' (supports only increasing values).
   2012-03-08/NJW
*/
{
   extern Completion_meter_band;

   width = 0.06;
   dista = 0.2;

   if( mode == 0 ) {
      // number of bands in 'band'
      if( band > 4 ) {
         write,"Only up to four bands are supported";
         band = 4;
      }
      ntext = 0;
      if( structof(text) == string ) ntext = numberof(text);
      Completion_meter_band = band;
      window,4,style="nobox.gs";
      y = 0.8;
      plot,[0.1,0.9,0.9,0.1,0.1],[y,y,y+width,y+width,y],xr=[0,1],yr=[0,1];
      if( ntext ) xyouts,0.1,y+width+0.02,esc_underscore(text(1)),font="times",charsize=0.7;
      for( b = 2; b <= band; b++ ) {
         y -= dista;
         oplot,[0.1,0.9,0.9,0.1,0.1],[y,y,y+width,y+width,y];
         if( ntext && b <= ntext ) \
            xyouts,0.1,y+width+0.02,esc_underscore(text(b)),font="times",charsize=0.7;
      }
   }
   if( mode == 1 ) {
      if( band < 1 || band > Completion_meter_band ) error;
      window,4;
      x1 = 0.1;
      x2 = 0.1 + frac*0.8;
      y = 1.0 - dista * band;
      poly_fill,[x1,x2,x2,x1,x1],[y,y,y+width,y+width,y],100;
   }
}
cm = completion_meter;
%FILE% compr_eff_area_files.i
func compr_eff_area_files( template, outfile )
/* DOCUMENT compr_eff_area_files, template, outfile

    where template is like: eff_area_blabla_???_what.fits
    (goes directly into 'file_search(template)') and
    nnn represents the layer number.

*/
{
   //  assume that template is like: eff_area_blabla_???_what.fits
   //  where ??? represents the layer number

   list = file_search( template );
   pos = strpos( template, "?" );
   w = where( is_digit( strpart( list, pos+2:pos+4 ) ) );
   nlist = numberof(w);
   if( nlist == 0 ) error,"No files found";
   list = list(w);
   prstrarr, list(1::10);
   write,"Showing one out of 10 files found:";
   write,"nlist = ", nlist;
   if( nlist > 133 ) error,"Too many files found";

   // remove initial './' if present

   for( i = 1; i<= nlist; i++ ) {
      if( strpart(list(i),1:2) == "./" ) list(i) = strpart(list(i),3:0);
   }

   list = list(sort(list));
   p = strpos( template, "?" );
   q = strpos( template, "?", rev=1);

   ener = float(rdfitscol( list(1)+"+1","ENERGY"));
   nrows = numberof(ener);
   write,"nrows = ", nrows;

   outarr = array( float, 133, nrows );

   kwds_init;
   for( i = 1; i <= nlist; i++ ) {
      effa = rdfitscol( list(i)+"+1","EFF_AREA" );
      // Assume that all files have identical units
      if( i == 1 ) {
         hdr = headfits( list(i)+"+1" );
         unit_ener = fxpar( hdr, "TUNIT1" );
         unit_effa = fxpar( hdr, "TUNIT2" );
         kwds_set,"TUNIT1", unit_ener, "Unit of energy";
         kwds_set,"TUNIT2", unit_effa, "Unit of effective area";
      }
      kwds_set,"TUNIT"+itoa(i+2), unit_effa,"Unit of effective area";
      slayer = strpart( list(i), p:q );
      layer = atoi(slayer);
      outarr( layer, ) = float(effa);
   }

   wrmfitscols,outfile,"ENERGY",ener, "EFF_AREA", outarr( sum, ), \
      "LAYER001", outarr(  1, ), "LAYER002", outarr(  2, ), "LAYER003", outarr(  3, ), "LAYER004", outarr(  4, ), \
      "LAYER005", outarr(  5, ), "LAYER006", outarr(  6, ), "LAYER007", outarr(  7, ), "LAYER008", outarr(  8, ), \
      "LAYER009", outarr(  9, ), "LAYER010", outarr( 10, ), "LAYER011", outarr( 11, ), "LAYER012", outarr( 12, ), \
      "LAYER013", outarr( 13, ), "LAYER014", outarr( 14, ), "LAYER015", outarr( 15, ), "LAYER016", outarr( 16, ), \
      "LAYER017", outarr( 17, ), "LAYER018", outarr( 18, ), "LAYER019", outarr( 19, ), "LAYER020", outarr( 20, ), \
      "LAYER021", outarr( 21, ), "LAYER022", outarr( 22, ), "LAYER023", outarr( 23, ), "LAYER024", outarr( 24, ), \
      "LAYER025", outarr( 25, ), "LAYER026", outarr( 26, ), "LAYER027", outarr( 27, ), "LAYER028", outarr( 28, ), \
      "LAYER029", outarr( 29, ), "LAYER030", outarr( 30, ), "LAYER031", outarr( 31, ), "LAYER032", outarr( 32, ), \
      "LAYER033", outarr( 33, ), "LAYER034", outarr( 34, ), "LAYER035", outarr( 35, ), "LAYER036", outarr( 36, ), \
      "LAYER037", outarr( 37, ), "LAYER038", outarr( 38, ), "LAYER039", outarr( 39, ), "LAYER040", outarr( 40, ), \
      "LAYER041", outarr( 41, ), "LAYER042", outarr( 42, ), "LAYER043", outarr( 43, ), "LAYER044", outarr( 44, ), \
      "LAYER045", outarr( 45, ), "LAYER046", outarr( 46, ), "LAYER047", outarr( 47, ), "LAYER048", outarr( 48, ), \
      "LAYER049", outarr( 49, ), "LAYER050", outarr( 50, ), "LAYER051", outarr( 51, ), "LAYER052", outarr( 52, ), \
      "LAYER053", outarr( 53, ), "LAYER054", outarr( 54, ), "LAYER055", outarr( 55, ), "LAYER056", outarr( 56, ), \
      "LAYER057", outarr( 57, ), "LAYER058", outarr( 58, ), "LAYER059", outarr( 59, ), "LAYER060", outarr( 60, ), \
      "LAYER061", outarr( 61, ), "LAYER062", outarr( 62, ), "LAYER063", outarr( 63, ), "LAYER064", outarr( 64, ), \
      "LAYER065", outarr( 65, ), "LAYER066", outarr( 66, ), "LAYER067", outarr( 67, ), "LAYER068", outarr( 68, ), \
      "LAYER069", outarr( 69, ), "LAYER070", outarr( 70, ), "LAYER071", outarr( 71, ), "LAYER072", outarr( 72, ), \
      "LAYER073", outarr( 73, ), "LAYER074", outarr( 74, ), "LAYER075", outarr( 75, ), "LAYER076", outarr( 76, ), \
      "LAYER077", outarr( 77, ), "LAYER078", outarr( 78, ), "LAYER079", outarr( 79, ), "LAYER080", outarr( 80, ), \
      "LAYER081", outarr( 81, ), "LAYER082", outarr( 82, ), "LAYER083", outarr( 83, ), "LAYER084", outarr( 84, ), \
      "LAYER085", outarr( 85, ), "LAYER086", outarr( 86, ), "LAYER087", outarr( 87, ), "LAYER088", outarr( 88, ), \
      "LAYER089", outarr( 89, ), "LAYER090", outarr( 90, ), "LAYER091", outarr( 91, ), "LAYER092", outarr( 92, ), \
      "LAYER093", outarr( 93, ), "LAYER094", outarr( 94, ), "LAYER095", outarr( 95, ), "LAYER096", outarr( 96, ), \
      "LAYER097", outarr( 97, ), "LAYER098", outarr( 98, ), "LAYER099", outarr( 99, ), "LAYER100", outarr(100, ), \
      "LAYER101", outarr(101, ), "LAYER102", outarr(102, ), "LAYER103", outarr(103, ), "LAYER104", outarr(104, ), \
      "LAYER105", outarr(105, ), "LAYER106", outarr(106, ), "LAYER107", outarr(107, ), "LAYER108", outarr(108, ), \
      "LAYER109", outarr(109, ), "LAYER110", outarr(110, ), "LAYER111", outarr(111, ), "LAYER112", outarr(112, ), \
      "LAYER113", outarr(113, ), "LAYER114", outarr(114, ), "LAYER115", outarr(115, ), "LAYER116", outarr(116, ), \
      "LAYER117", outarr(117, ), "LAYER118", outarr(118, ), "LAYER119", outarr(119, ), "LAYER120", outarr(120, ), \
      "LAYER121", outarr(121, ), "LAYER122", outarr(122, ), "LAYER123", outarr(123, ), "LAYER124", outarr(124, ), \
      "LAYER125", outarr(125, ), "LAYER126", outarr(126, ), "LAYER127", outarr(127, ), "LAYER128", outarr(128, ), \
      "LAYER129", outarr(129, ), "LAYER130", outarr(130, ), "LAYER131", outarr(131, ), "LAYER132", outarr(132, ), \
      "LAYER133", outarr(133, ), clobber=1;

}
%FILE% condense_psav.i
func condense_psav( psav_name, condensed_name )
/* DOCUMENT condense_psav, psav_name, condensed_name

    Make a condensed version of a photon save file
    (by mt_save,mode="p" in MT_RAYOR) for increased speed of
    effective area calculation.

    Only intended for on-axis sources.

    2011-10-20/NJW
*/
{
   dol = psav_name+"+1";
   ptr = rdfitsbin( dol, fh, nrows );
   fits_copy_keys, fh, tokwds=1;
   kwds_set,"CONDENSE",1,"Flag for condensed save file";
   kwds_set,"INFILE", fullpath(psav_name),"Input file";

   mirror = *ptr(fits_colnum(fh,"MIRROR"));
   angle_in1 = *ptr(fits_colnum(fh,"ANGLE_IN1"));
   angle_in2 = *ptr(fits_colnum(fh,"ANGLE_IN2"));
   status = *ptr(fits_colnum(fh,"STATUS"));
   bounce = *ptr(fits_colnum(fh,"BOUNCE"));

   // reduce to status==0 && bounce==3

   w = where( status == 0 & bounce == 3 );
   nrows = numberof(w);
   if( nrows == 0 ) error,"No succesful photons found - skip ...";

   mirror = mirror(w);
   angle_in1 = angle_in1(w);
   angle_in2 = angle_in2(w);

   // sort according to mirror number
   is = sort(mirror);
   mirror = mirror(is);
   angle_in1 = angle_in1(is);
   angle_in2 = angle_in2(is);

   u = uniq(mirror);
   nu = numberof(u);
   grow, u, nrows+1;

   mirror_res = array(int,nu);
   multiplicity = u(dif);
   angle_in1_res = angle_in2_res = array(double,nu);

   for( iu = 1; iu <= nu; iu++ ) {
      mirror_res(iu) = mirror(u(iu));
      angle_in1_res(iu) = avg(angle_in1(u(iu):u(iu+1)-1));
      angle_in2_res(iu) = avg(angle_in2(u(iu):u(iu+1)-1));
   }

   wrmfitscols, condensed_name, "MIRROR", mirror_res, "ANGLE_IN1", angle_in1_res, \
                "ANGLE_IN2", angle_in2_res, "MULTIPLICITY", multiplicity, clobber=1;
   write,condensed_name+" has been written ...";

}
%FILE% count_classif.i
func count_classif( catfile, logfile= )
{

   fout = structof(logfile) == string ? open(logfile,"w") : [];

   c = rdfitscol(catfile+"+1","class");
   ntot = numberof(c);

   kount = 0;
   write,fout,"Catalog "+catfile;


   // unspecified X-ray binaries      1000 - 1099
   lim = [1000,1100];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="unspecified X-ray binaries : %i\n", nw;


   // HMXB                            1100 - 1399
   lim = [1100,1400];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="HMXB X-ray binaries : %i\n", nw;


   // LMXB                            1400 - 1599
   lim = [1400,1600];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="LMXB X-ray binaries : %i\n", nw;


   // Cataclysmic Variable            1600 - 1699
   lim = [1600,1700];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Cataclysmic variables : %i\n", nw;


   // Gamma ray source or burster     1700 - 1799
   lim = [1700,1800];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Gamma ray sources : %i\n", nw;


   // Pulsar of some kind             1800 - 1849
   lim = [1800,1850];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Pulsars : %i\n", nw;


   // Stellar object                  1850 - 2999
   lim = [1850,3000];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Stellar objects : %i\n", nw;


   // Unspecified extended            3000 - 3099
   lim = [3000,3100];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Unspecified extended : %i\n", nw;


   // Supernova remnant               3100 - 3299
   lim = [3100,3300];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Supernova remnants : %i\n", nw;


   // Stellar clusters, nebulae       3300 - 3999
   lim = [3300,4000];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Stellar clusters, nebulae : %i\n", nw;


   // White dwarfs                    4000 - 4999
   lim = [4000,5000];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="White dwarfs : %i\n", nw;


   // Clusters of galaxies            5000 - 5999
   lim = [5000,6000];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Galaxy clusters : %i\n", nw;


   // Galaxies                        6000 - 6999
   lim = [6000,7000];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Galaxies : %i\n", nw;


   // Active galactic nuclei          7000 - 7999
   lim = [7000,8000];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="AGN : %i\n", nw;


   // Solar system object             8000 - 89999
   lim = [8000,9000];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Solar system objects : %i\n", nw;


   // Unknown systems                 9000 - 9999
   lim = [9000,10000];
   w = where( c >= lim(1) & c < lim(2) );
   nw = numberof(w); kount += nw;
   if( nw ) write,fout,format="Unknown systems : %i\n", nw;

   if( kount < ntot ) write,fout,"There are sources not accounted for";

   close, fout;
}
%FILE% cr_over.i
#include "jfits.i"
#include "mfits.i"
#include "idlx.i"
#include "jemx.i"

func cr_over(jemxnum, project)
/* DOCUMENT cr_over, jemxnum, project

   Auxiliary function for j_ima_cross results.

*/
{
   if( is_void(project) ) {
      write,"Syntax: cr_over, jemxnum, project_name";
      return [];
   }

   jstr = itoa(jemxnum);
   log = open( "/home/njw/jemx/issw/j_ima_cross/cr_over_"+jstr+"_"+project+".log","w");

   local ra_scx, dec_scx, roll;

   // Get all result directories

   all_swids = [];
   all_varg = [];
   all_gain = [];
   all_peak = [];
   all_ra = [];
   all_dec = [];
   all_offs = [];
   all_roll = [];
   all_expo = [];
   all_xpix = [];
   all_ypix = [];

   adir = "/r9/njw/jemx";
   bdir = file_search( project+"_*", adir);
   n_bdir = numberof(bdir);
   for( i = 1; i <= n_bdir; i++ ) {
      block = strpart( bdir(i), -1:0 );
      cdir = file_search("*",bdir(i)+"/obs/"+project+"_"+jstr+"_block_"+block+"/scw");
      n_cdir = numberof(cdir);
      for( j = 1; j <= n_cdir; j++ ) {
        // Check existence of jmxi_sloc_res file
         n = pick_swid_str( cdir(j), swid );
         if( n == 1 ) {
            swid = swid(1);
         } else error,"##3##";

        // Get pointing

         status = get_pointing_for_swid( swid, ra_scx, dec_scx, roll, silent=1 );
         if( status != 0 ) {
            write,format="Cannot get pointing for %s\n", swid;
            write,log,format="Cannot get pointing for %s\n", swid;
            continue;
         }

         sloc = "/home/njw/jemx/issw/j_ima_cross/srcl_res/jmx"+jstr+"_sloc_res_"+project+"_"+swid+".fits";
         if( !file_test( sloc ) ) {
            write,format="sloc_res %s is missing!\n", sloc;
            write,log,format="sloc_res %s is missing!\n", sloc;
            continue;
         }
         hdr = headfits( sloc+"+1");
         nsrcs = fxpar( hdr, "naxis2");
         if( is_void(nsrcs) ) nsrcs = -1;
         if( nsrcs != 5 ) {
            write,format="%i sources in %s\n", nsrcs, sloc;
            write,log,format="%i sources in %s\n", nsrcs, sloc;
            continue;
         }

       // Check the image file to get the exposure

         skyima = "/home/njw/jemx/issw/j_ima_cross/sky_ima/jmx"+jstr+"_sky_ima_"+project+"_"+swid+".fits";
         if( !file_test( skyima ) ) {
            write,format="sky_ima %s is missing!\n", skyima;
            write,log,format="sky_ima %s is missing!\n", skyima;
            continue;
         }
         hdr = headfits( skyima+"+2" );
         exposure = fxpar( hdr, "exposure" );
         if( is_void(exposure) ) {
            write,format="Did not find EXPOSURE in %s\n", skyima;
            write,log,format="Did not find EXPOSURE in %s\n", skyima;
            continue;
         }
         if( exposure <= 0.0 ) {
            write,format="EXPOSURE = %f in %s\n", exposure, skyima;
            write,log,format="EXPOSURE = %f in %s\n", exposure, skyima;
            continue;
         }

         gainscp = cdir(j)+"/jmx"+jstr+"_gain_scp.fits";
         if( ! file_test(gainscp) ) {
            write,format="gain_scp %s is missing!\n", gainscp;
            write,log,format="gain_scp %s is missing!\n", gainscp;
            continue;
         }
         hdr = headfits( gainscp+"+1" );
         nrows = fxpar( hdr, "naxis2" );
         if( is_void(nrows) ) nrows = 0;
         if( nrows == 0 ) {
            write,format="No rows in %s\n", gainscp;
            write,log,format="No rows in %s\n", gainscp;
            continue;
         }
         gain = rdfitscol( gainscp+"+1","gain");
         if( is_void(gain) ) error,"Unexpected error";
         varg = wrms(gain)^2;

         grow, all_swids, swid;
         grow, all_gain, avg(gain);
         grow, all_varg, varg;

         ra_cross = rdfitscol( sloc+"+1", "ra_obj" )(5);
         dec_cross = rdfitscol( sloc+"+1", "dec_obj" )(5);
         peaksize = rdfitscol( sloc+"+1", "peaksize" )(1:4);
         xpix = avg(rdfitscol( sloc+"+1", "xpix")(1:4));
         ypix = avg(rdfitscol( sloc+"+1", "ypix")(1:4));
 
         grow, all_ra, ra_cross;
         grow, all_dec, dec_cross;
         grow, all_peak, peaksize/exposure; // must be re-formatted at the end
         grow, all_xpix, xpix;
         grow, all_ypix, ypix;

         offaxis = arcdist( ra_scx, dec_scx, ra_cross, dec_cross );
         grow, all_offs, offaxis;
         grow, all_roll, roll;
         grow, all_expo, exposure;

      }

   }

   close, log;

   n = numberof(all_ra);
   all_peak = reform( all_peak, 4, n );
   wrmfitscols, "/home/njw/jemx/issw/j_ima_cross/jmx"+jstr+"_"+project+".fits", "SWID", all_swids, \
                "GAIN", all_gain, "VARGAIN", all_varg, "PEAKSIZE", all_peak, \
                "OFFAXIS", all_offs, "RA_CROSS", all_ra, "DEC_CROSS", all_dec, \
                "EXPOSURE", all_expo, "XPIX", all_xpix, "YPIX", all_ypix, clobber=1;

}
%FILE% curreg.i
/* Function curreg */

func curreg( im, shape, &xcen, &ycen, &params, color=, thick= )
/* DOCUMENT s = curreg( im, shape, >xcen, >ycen, >params, color=, thick= )

     A function to make a cursor marked region in an image.

     Returns an array with image indices.

     The shape can be "c" for circular (default), "a" for annulus, or "b" for box.
     When "d" is given an annulus with center (xcen,ycen) is defined.

     Returned in 'params':
           circular : [xcen, ycen, radius]
           annulus  : [xcen, ycen, radius1, radius2]
           box      : [x1, y1, x2, y2]
*/
{
   dms = dimsof(im);
   if( is_void(shape) ) shape = "c";
   if( typeof(shape) != "string" ) error,"Second argument must be a string";
   sh = strpart(shape,1:1);
   if( sh == "c" ) { // circular region
      cent = curmark1(prompt="Mark the center ...");
      xcen = cent(1);
      ycen = cent(2);
      rad  = curmark1(prompt="Mark the periphery ...");
      v = span(0,2*pi,50);
      r = sqrt((xcen-rad(1))^2 + (ycen-rad(2))^2);
      params = [xcen, ycen, r];
      d = distances(dms(2),dms(3),xcen,ycen);
      w = where(d < r);
      oplot,xcen+r*cos(v),ycen+r*sin(v),color=color,thick=thick;
   } else if( sh == "a" || sh == "d" ) { // annular region
      if( sh == "a" ) {
         cent = curmark1(prompt="Mark the center ...");
         xcen = cent(1);
         ycen = cent(2);
      }
      v = span(0,2*pi,50);
      d = distances(dms(2),dms(3),xcen,ycen);

      rad  = curmark1(prompt="Mark the inner periphery ...");
      r1 = sqrt((xcen-rad(1))^2 + (ycen-rad(2))^2);
      oplot,xcen+r1*cos(v),ycen+r1*sin(v),color=color,thick=thick;
      rad  = curmark1(prompt="Mark the outer periphery ...");
      r2 = sqrt((xcen-rad(1))^2 + (ycen-rad(2))^2);
      params = [xcen, ycen, r1, r2];
      oplot,xcen+r2*cos(v),ycen+r2*sin(v),color=color,thick=thick;
      w = where( d > r1 & d < r2 );
   } else {          // box region
      corners = curmark1(prompt="Mark the box corners ...",style=2);
      x1 = min(corners(1:3:2));
      x2 = max(corners(1:3:2));
      xcen = 0.5*(x1+x2);
      y1 = min(corners(2:4:2));
      y2 = max(corners(2:4:2));
      params = [x1, y1, x2, y2 ];
      ycen = 0.5*(y1+y2);
      xnet = indgen(dms(2))(,-:1:dms(3));
      ynet = indgen(dms(3))(-:1:dms(2),);
      w = where(xnet > x1 & xnet < x2 & ynet > y1 & ynet < y2 );
      oplot,[x1,x2,x2,x1,x1],[y1,y1,y2,y2,y1],color=color,thick=thick;
   }
   return w;
}
%FILE% curvefit.i
/*---------------------------------------------------------------------------
 * @(#) curvefit.i: non-linaear fitting in Yorick by Eric THIEBAUT.
 *---------------------------------------------------------------------------
 * 	$Id: curvefit.i,v 1.1 1995/12/18 11:45:07 eric Exp $
 *---------------------------------------------------------------------------
 * History:
 *	November 2, 1995 by Eric THIEBAUT: 1st version from IDL CURVEFIT.PRO
 *---------------------------------------------------------------------------
 */
require, "string.i";

func curvefit(function, x, y, w, &a,&sigma, &chisqr,
	      lambda=, itmax=, factor=, quiet=)
{
//+
// NAME:
//	CURVEFIT
// PURPOSE:
//	Non-linear least squares fit to a function of an
//	arbitrary number of parameters.
//	Function may be any non-linear function where
//	the partial derivatives are known or can be approximated.
// CATEGORY:
//	E2 - Curve and Surface Fitting
// CALLING SEQUENCE:
//	YFIT = CURVEFIT(X,Y,W,A,SIGMA)
// INPUTS:
//	X = Row vector of independent variables.
//	Y = Row vector of dependent variable, same length as x.
//	W = Row vector of weights, same length as x and y.
//		For no weighting: w(i) = 1.,
//		instrumental weighting w(i) = 1./y(i),
//		statistical weighting w(i) = 1./Var(y(i)),
//		etc.
//	A = Vector of nterms length containing the initial estimate
//		for each parameter.
//
// OUTPUTS:
//	A = Vector of parameters containing fit.
//	Function result = YFIT = Vector of calculated
//		values.
// OPTIONAL OUTPUT PARAMETERS:
//	Sigma = Vector of standard deviations for parameters
//		A.
//	
// COMMON BLOCKS:
//	NONE.
// SIDE EFFECTS:
//	The function to be fit must be defined and called FUNCT.
//	For an example see FUNCT in the IDL User's Libaray.
//	Call to FUNCT is:
//	FUNCT,X,A,F,PDER
// where:
//	X = Vector of NPOINT independent variables, input.
//	A = Vector of NTERMS function parameters, input.
//	F = Vector of NPOINT values of function, y(i) = funct(x(i)), output.
//	PDER = Array, (NPOINT, NTERMS), of partial derivatives of funct.
//		PDER(I,J) = DErivative of function at ith point with
//		respect to jth parameter.  Optional output parameter.
//		PDER should not be calculated if parameter is not
//		supplied in call (Unless you want to waste some time).
// RESTRICTIONS:
//	NONE.
// PROCEDURE:
//	Copied from "CURFIT", least squares fit to a non-linear
//	function, pages 237-239, Bevington, Data Reduction and Error
//	Analysis for the Physical Sciences.
//
//	"This method is the Gradient-expansion algorithm which
//	compines the best features of the gradient search with
//	the method of linearizing the fitting function."
//
//	Iterations are perform until the chi square changes by
//	only 0.1% or until 15 attempts at minimisation (with maximum of
//	20 iterations) have been performed.
//
//	The initial guess of the parameter values should be
//	as close to the actual values as possible or the solution
//	may not converge.
//
// MODIFICATION HISTORY:
//	Written, DMS, RSI, September, 1982.
//	       Amended to output CHISQR, and to set A=0 if no convergence
//	T.J.Harris, Dept. of Physics, University of Adeliade,  August 1990.
//-
    itmax  = scalar(itmax,  20,   type=long,   gt=1,  arg="ITMAX");
    factor = scalar(factor, 10.,  type=double, gt=1., arg="FACTOR");
    lambda = scalar(lambda, 1e-3, type=double, gt=0., arg="LAMBDA");
    verbose = !anyof(quiet);

    a = double(a);	// make params floating-point
    nterms = numberof(a);

    // Degrees of freedom:
    nfree = min(numberof(y), numberof(x)) - nterms;
    //nfree = numberof(where(w * (y + !y) != 0.) ) - nterms;
    if (nfree <= 0)
	error, "curvefit - not enough data points.";
    
    //Subscripts of diagonal elements:
    diag = indgen(1:nterms^2:nterms+1);

    iter=0;
    do {

	if (++iter > itmax)
	    error, "exceeded maximum number of iterations";
	
	//
	// Compute Alpha and Beta matrices:	
	//
        yfit = function(x, a, pder, deriv=1);
        beta = (w * (y - yfit))(+) * pder(+,);
        alpha = w(+) * (pder(,,-) * pder(,-,))(+,..);
	c = alpha(diag);
	c = sqrt(c(,-) * c(-,));
	
	// Present chi squared:
        chisq1 = sum(w*(y-yfit)^2)/nfree;
	if (chisq1 == 0.0) {
	    write, "CURVEFIT: WARNING Chi2 maybe too small to be true!";
	    break;
	}
	if (verbose)
	    write, format=" %3d: Chi2 =%g", iter, chisq1;

	//
	// Invert modified curvature matrix to find new parameters.
	//
	count = 0;
        do {
	    if (++count > 20)
		error, "cannot improve Chi2";
	    
            d = alpha / c;
            d(diag) = 1.+lambda;
            d = LUsolve(d);
            b = a + (d / c)(,+) * beta(+);	// new parameters
	    yfit = function(x, b);
	    chisqr = sum(w * (y - yfit)^2) / nfree;	//new chisqr
	    lambda *= factor;				//assume fit got worse
	    if (verbose)
		write, format=" %g", chisqr;
	    
        } while (chisqr >= chisq1);
	
	if (verbose)
	    write, "\n";
	
        lambda /= factor^2;	//decrease lambda by factor
        a = b;			//save new parameter estimate

    } while ((chisq1-chisqr)/chisq1 > .001);

    sigma = sqrt(d(diag)/alpha(diag));	//return sigma's
    return yfit;
}
%FILE% curvefit_funcs.i
#include "curvefit.i"
#include "random.i"

func fexpo3( x, a, &pder, deriv= )
/* DOCUMENT yfit = fexpo3( x, a, >pder, deriv= )

   Returns y = a(1)*(1. + a(2)*x^a(3)),
   and, if deriv==1, the first partial derivatives in 'pder'.

   Use as: yfit = curvefit( fexpo3, x, y, w, a, sigma, chisqr);

   2007-09-14/NJW
*/
{
   nx = numberof(x);
   na = numberof(a);

   y = a(1)*(1. + a(2)*x^a(3));

   if( deriv ) {
      pder = array(double,nx,na);
      pder(,1) = 1. + a(2)*x^a(3);
      pder(,2) = a(1)*x^a(3);
      pder(,3) = a(1)*a(2)*log(x)*x^a(3);
   }
   return y;
}
func fexpo2( x, a, &pder, deriv= )
/* DOCUMENT yfit = fexpo2( x, a, >pder, deriv= )

   Returns y = a(1)*(1. - a(2)*x^5),
   and, if deriv==1, the first partial derivatives in 'pder'.

   Use as: yfit = curvefit( fexpo2, x, y, w, a, sigma, chisqr);

   2007-09-14/NJW
*/
{
   nx = numberof(x);
   na = numberof(a);

   y = a(1)*(1. + a(2)*x^5));

   if( deriv ) {
      pder = array(double,nx,na);
      pder(,1) = 1. - a(2)*x^5;
      pder(,2) = -a(1)*x^5;
   }
   return y;
}

func fline( x, a, &pder, deriv= )
/* DOCUMENT yfit = fline( x, a, >pder, deriv= )

   Returns y = a(1)*x + a(2);
   and, if deriv==1, the first partial derivatives in 'pder'.

   Use as: yfit = curvefit( fline, x, y, w, a, sigma, chisqr);

   2007-09-14/NJW
*/
{
   nx = numberof(x);
   na = numberof(a);

   // y = a(1)*x + a(2)
   // dy/da1 = x, dy/da2 = 1.

   y = a(1)*x + a(2);

   if( deriv ) {
      pder = array(double,nx,na);
      pder(,1) = x;
      pder(,2) = 1.0;
   }
   return y;
}

func gmap( q )
/* DOCUMENT par = gmap( q )

   Externals: _limits(2, numa), _index, _pmode(numa)
   _pmode(i) = 0   : unlimited
   _pmode(i) = 1   : only lower limit at _limits(1,i)
   _pmode(i) = 2   : only upper limit at _limits(2,i)
   _pmode(i) = 3   : both lower and upper limits: _limits(1,i), _limits(2,i)

   2007-09-14/NJW
*/
{

   if( _pmode(_index) == 0 ) return q;
   a = _limits(1,_index);
   b = _limits(2,_index);

   if( _pmode(_index) == 1 ) {
      return a + exp( q );
   } else if( _pmode(_index) == 2 ) {
      return b - exp( q );
   } else {
      return (a+b)/2.0 + (b-a)*atan( q ) / pi;
   }

}

func gmapinv( par )
/* DOCUMENT q = gmap( par )

   Externals: _limits(2, numa), _index, _pmode(numa)
               1 <= _index <= numa

   2007-09-14/NJW
*/
{

   if( _pmode(_index) == 0 ) return par;
   a = _limits(1,_index);
   b = _limits(2,_index);

   if( _pmode(_index) == 1 ) {
      return log(par - a);
   } else if( _pmode(_index) == 2 ) {
      return log(b - par);
   } else {
      return tan( pi * ( par - (a+b)/2.0 ) / (b-a) );
   }

}

   
func fexpol( x, a, &pder, deriv= )
/* DOCUMENT yfit = fexpol( x, a, >pder, deriv= )

   Returns y = g1(a(1))*(1. + g2(a(2))*x^g3(a(3))),
   and, if deriv==1, the first partial derivatives in 'pder'.

   Extern variable _limits(2,numberof(a))

       _limits(1,i) is lower limit for a(i)
       _limits(2,i) is upper limit for a(i)
       if _limits(1,i) == _limits(2,i) then a(i) is unlimited

   Use as: yfit = curvefit( fexpol, x, y, w, a, sigma, chisqr);

   2007-09-14/NJW
*/
{

   extern _index;

   nx = numberof(x);
   na = numberof(a);

   // dy/da1 = x, dy/da2 = 1.

   _index = 1;
   ga1 = gmap(a(1));
   _index = 2;
   ga2 = gmap(a(2));
   _index = 3;
   ga3 = gmap(a(3));
   y = ga1*(1. - ga2*x^ga3);

   if( deriv ) {
      pder = array(double,nx,na);
      pder(,1) = 1. - ga2*x^ga3;
      pder(,2) = -ga1*x^ga3*(_limits(2,2) - _limits(1,2))/((1.+a(2)^2)*pi);
      pder(,3) = -ga1*ga2*log(x)*x^ga3*(_limits(2,3) - _limits(1,3))/((1.+a(3)^2)*pi);
   }
   return y;
}
%FILE% custom.i
/*
 * $Id: custom.i,v 1.1.1.1 2005/09/18 22:05:54 dhmunro Exp $
 * Default version of user customization file --
 * read after std.i and all package initalization files.
 */
/* Copyright (c) 2005, The Regents of the University of California.
 * All rights reserved.
 * This file is part of yorick (http://yorick.sourceforge.net).
 * Read the accompanying LICENSE file for details.
 */

/* With yorick-1.6, you should usually put customizations in
 * ~/yorick/i-start/ (or ~/Yorick/i-start/).  All files whose names
 * end in ".i" in that directory will be included at startup, in
 * alphabetical order.  Consider using autoload in any i-start files.
 * (see help,autoload and look in Y_SITE/i-start for examples.)
 * Do not have a ~/yorick/custom.i unless you need to change the
 * default command line processing.
 */

/* Place your own customizations here.

   Be careful!  You can break Yorick in a personalized way, so that only
   you will be affected -- this makes it difficult to get anyone else to
   believe there is a problem!

   Examples:

   // Read in my_special_functions.i (in ~/Yorick), which I always need.
   #include "my_special_functions.i"

   // Use ugly boxed graphics and waste screen real estate by default.
   pldefault, style="boxed.gs", dpi=100;

 */

/*  START of customizations */

write,"Reading custom.i in /home/njw/yorick ...";
pldefault, style="boxed.gs", dpi=100;
#include "/home/njw/yorick/kfits.i"
#include "/home/njw/yorick/mfits.i"
#include "/home/njw/yorick/basic.i"
#include "/home/njw/yorick/plot.i"
#include "/home/njw/yorick/scom.i"
#include "/home/njw/yorick/image.i"
#include "/home/njw/yorick/yorick-2.1/i/random.i"
#include "/home/njw/yorick/jemx.i"
#include "/home/njw/yorick/yorick-2.1/i/string.i"
#include "/home/njw/yorick/idlx.i"
#include "/home/njw/yorick/fconvol.i"
#include "/home/njw/yorick/xray.i"
#include "/home/njw/yorick/datafit.i"
#include "/home/njw/yorick/euler.i"
#include "/home/njw/yorick/organize.i"
#include "/home/njw/yorick/tempus.i"
#include "/home/njw/yorick/ebm.i"
#include "/home/njw/yorick/specfit.i"
#include "/home/njw/yorick/mem_storage.i"
#include "/home/njw/yorick/util_fr.i"
#include "/home/njw/yorick/mroots.i"
#include "/home/njw/yorick/mcomplex.i"
#include "/home/njw/yorick/rmf_funcs.i"
#include "/home/njw/yorick/xfit_package.i"

/*
 *  Define some useful external variables
 */
GISTDIR = "/r9/njw/yorick/yorick-2.1/g/";
write,format="GISTDIR: %s\n", GISTDIR;

/*  END of customizations */

/* This should be the final line in your custom.i file-- it implements
   the default command line processing (see help for process_argv).  */
command_line= process_argv();
%FILE% custom_r9.i
/*
 * $Id: custom.i,v 1.1.1.1 2005/09/18 22:05:54 dhmunro Exp $
 * Default version of user customization file --
 * read after std.i and all package initalization files.
 */
/* Copyright (c) 2005, The Regents of the University of California.
 * All rights reserved.
 * This file is part of yorick (http://yorick.sourceforge.net).
 * Read the accompanying LICENSE file for details.
 */

/* With yorick-1.6, you should usually put customizations in
 * ~/yorick/i-start/ (or ~/Yorick/i-start/).  All files whose names
 * end in ".i" in that directory will be included at startup, in
 * alphabetical order.  Consider using autoload in any i-start files.
 * (see help,autoload and look in Y_SITE/i-start for examples.)
 * Do not have a ~/yorick/custom.i unless you need to change the
 * default command line processing.
 */

/* Place your own customizations here.

   Be careful!  You can break Yorick in a personalized way, so that only
   you will be affected -- this makes it difficult to get anyone else to
   believe there is a problem!

   Examples:

   // Read in my_special_functions.i (in ~/Yorick), which I always need.
   #include "my_special_functions.i"

   // Use ugly boxed graphics and waste screen real estate by default.
   pldefault, style="boxed.gs", dpi=100;

 */


write,"Reading custom.i in /r9/njw/yorick/yorick-2.1.06/yorick-2.1/i ...";
pldefault, style="boxed.gs", dpi=100;
#include "/home/njw/yorick/kfits.i"
#include "/home/njw/yorick/mfits.i"
#include "/home/njw/yorick/basic.i"
#include "/home/njw/yorick/plot.i"
#include "/home/njw/yorick/scom.i"
#include "/home/njw/yorick/image.i"
#include "/home/njw/yorick/random.i"
#include "/home/njw/yorick/jemx.i"
#include "/home/njw/yorick/string_2106.i"
#include "/home/njw/yorick/idlx.i"
#include "/home/njw/yorick/fconvol.i"
#include "/home/njw/yorick/xray.i"
#include "/home/njw/yorick/datafit.i"
#include "/home/njw/yorick/euler.i"
#include "/home/njw/yorick/organize.i"
#include "/home/njw/yorick/tempus.i"
#include "/home/njw/yorick/ebm.i"
#include "/home/njw/yorick/specfit.i"
#include "/home/njw/yorick/mem_storage.i"
#include "/home/njw/yorick/util_fr_2106.i"
#include "/home/njw/yorick/mroots.i"
#include "/home/njw/yorick/mcomplex.i"
#include "/home/njw/yorick/curreg.i"
#include "/home/njw/yorick/island.i"
#include "/home/njw/yorick/xfit_package.i"
#include "/home/njw/yorick/rmf_funcs.i"
#include "/home/njw/yorick/varfuncs.i"
#include "/home/njw/yorick/mexican_hat.i"

/*
 *  Define some useful external variables
 */
Y_CODE = "/home/njw/yorick/";
GISTDIR = Y_SITE+"g/";
write,format="GISTDIR: %s\n", GISTDIR;
host = get_env("HOST");

/* This should be the final line in your custom.i file-- it implements
   the default command line processing (see help for process_argv).  */
command_line= process_argv();
%FILE% cyclicpeak.i
func cyclicpeak( m, amp, sigma, i, j )
/* DOCUMENT res = cyclicpeak( im, amp, sigma, i, j )
*/
{
   dms = dimsof( m );
   nx = dms(2);
   ny = dms(3);
   newm = m;

   del = long(3.*sigma);

   for( ii = -del; ii <= del; ii++ ) {
   for( jj = -del; jj <= del; jj++ ) {
      d = (ii^2 + jj^2)/sigma^2;
      pow = amp*exp(-0.5*d);
      k = (i+ii+nx-1)%nx + 1;
      l = (j+jj+ny-1)%ny + 1;
      newm(k,l) += pow;
   }}

   return newm;
}
%FILE% datafit.i
extern datafitdoc;
/* DOCUMENT datafit *********************************
 *    Collection of data fitting and function
 *    minimization functions

      SiGn                  gaussfit2d_uam        
      _reduce_p             gaussfit2ds_uam       
      _reduce_y             gaussfit_2d           
      amoeba                gaussfit_am           
      amoeba_freeze         gaussfitx             
      brent                 golden                
      edf_modelf            lin_regress           
      expodecayfit          linmin                
      f1dim                 lmfit                 
      fte1                  mnbrak                
      fte2d                 model_amoeba          
      ftex                  modela                
      funk_amoeba           modelb                
      funka                 powell                
      funkb                 prepare_gf2d          
      gaussfit              autoesti

      2008-11-03/NJW, added autoesti 2010-11-22
****************************************************/

/* Function lin_regress */

func lin_regress( x, y, dy )
/* DOCUMENT coefs = lin_regress( x, y, dy )

   Linear regression for a single independent variable 'x'
   Measurements are 'y' with errors 'dy'

   yfit = coefs(1) + coefs(2) * x

   2007-01-05/NJW

*/
{
   require, "matrix.i";

   mat = array(double, 2,2 );
   rhs = array(double, 2);
   n = numberof(x);
   for( i = 1; i <= n; i++ ) {
      weight = 1./(dy(i)*dy(i));
      mat(2,2) += x(i)*x(i)*weight;
      mat(1,2) += x(i)*weight;
      mat(1,1) += weight;
      rhs(2) += x(i)*y(i)*weight;
      rhs(1) += y(i)*weight;
   }
   mat(2,1) = mat(1,2);
   return LUsolve(mat,rhs);
}


/* Function gaussfit2d_uam */

func gaussfit2d_uam(x, y, z, ftol=, nterm=, esti=, delta=, chat= )
/* DOCUMENT coefs = gaussfit2d_uam( x, y, ftol=, nterm=, esti=, delta=, chat= )

     Perform a 2D gauss fit for array 'z' with coordinates in 'x' and 'y'
     It returns a double array:
          [amplitude, mean_x, mean_y, sigma_x, sigma_y, bkg].

     This is the 'unconstrained sampling' version where the coordinate
     pairs (x,y) can be chosen freely in contrast to the mesh version
     - gaussfit2d_mam - where (x,y) belong to an MxN mesh of values.
     Here x, y, and z must be 1D arrays of same number of elements.

     If nterm == 5 or not given:
     yfit = coefs(1)*exp(-0.5*(((x-coefs(2))/coefs(4))^2 \
                            + ((y-coefs(3))/coefs(5))^2))
     If nterm == 6:
     yfit = <previous expression> + coefs(6)

     KEYWORD   ftol: fitting tolerance default value: 1.e-4
              nterm: number of terms (5 or 6)
               esti: estimated start values of coefficients
              delta: fractional parameter adjustment [default: 0.1]
               chat: chattiness level 1: some, 5: a LOT

     SEE ALSO:  autoesti

     2006-02-23/NJW  Cloned from gaussfit_am.i

*/
{

   require, "varfuncs.i";

   extern xval, yval, zval, n_points;

   if( is_void(nterm) ) nterm = 5;
   if( nterm != 5 && nterm != 6 ) {
      print,"Keyword nterm must be 5 or 6";
      return -1;
   }
   if( is_void(delta) ) delta = 0.1;
   if( is_void(ftol) ) ftol = 1.e-4;
   if( is_void(chat) ) chat = 0;

   p = array(double,nterm+1,nterm);
   parm = array(double,nterm);
   delta_parm = array(double,nterm);
   chi2_arr = array(double,nterm+1);

   xval = x;
   yval = y;
   zval = z;

   n_points = numberof(x);
   if( chat > 2 ) print,"n_points = ", n_points;


   /* parm(1) is amplitude,
      parm(2) is mean_x,
      parm(3) is mean_y,
      parm(4) is sigma_x,
      parm(5) is sigma_y,
      parm(6) is background if nterm==6 */

   /* prediction of values */

   if( is_void(esti) ) {
      // First estimation - broad peak
      parm_b = parm;
      sumn = sum(z);
      mean_x = sum(x*z) / sumn;
      stdev_x = (sum(x*x*z) - sumn*mean_x*mean_x)/sumn;
      mean_y = sum(y*z) / sumn;
      stdev_y = (sum(y*y*z) - sumn*mean_y*mean_y)/sumn;
      parm_b(1) = max(z);
      parm_b(2) = mean_x;
      parm_b(3) = mean_y;
      parm_b(4) = sqrt(stdev_x);
      parm_b(5) = sqrt(stdev_y);
      if( nterm == 6 ) {
         r = sqrt(((x-mean_x)/stdev_x)^2 + ((y-mean_y)/stdev_y)^2);
         w = where( r > 2. );
         parm_b(6) = numberof(w) > 0 ? avg(z(w)) : 0.0;
         parm_b(1) -= parm_b(6);
      }
      if( chat > 2 ) {
         print,"start parm_b: ", parm_b;
         print,"chi2_b: ", funk(parm_b);
      }
      // Next estimation - narrow peak
      parm_n = parm;
      w = where( z > avg(z) );
      sumn = sum(z(w));
      mean_x = sum(x(w)*z(w)) / sumn;
      stdev_x = (sum(x(w)*x(w)*z(w)) - sumn*mean_x*mean_x)/sumn;
      mean_y = sum(y(w)*z(w)) / sumn;
      stdev_y = (sum(y(w)*y(w)*z(w)) - sumn*mean_y*mean_y)/sumn;
      parm_n(1) = max(z(w));
      parm_n(2) = mean_x;
      parm_n(3) = mean_y;
      parm_n(4) = sqrt(stdev_x);
      parm_n(5) = sqrt(stdev_y);
      if( nterm == 6 ) {
         r = sqrt(((x-mean_x)/stdev_x)^2 + ((y-mean_y)/stdev_y)^2);
         w = where( r > 2. );
         parm_n(6) = numberof(w) > 0 ? avg(z(w)) : 0.0;
         parm_n(1) -= parm_n(6);
      }
      if( chat > 2 ) {
         print,"start parm_n: ", parm_n;
         print,"chi2_n: ", funk(parm_n);
      }
      //parm = funk(parm_n) < funk(parm_b) ? parm_n : parm_b;
      chi2_b = funk(parm_b);
      chi2_n = funk(parm_n);
      if( chi2_n < chi2_b ) {
         print,"Choosing parm_n";
         parm = parm_n;
      } else {
         print,"Choosing parm_b";
         parm = parm_b;
      }
      print,"typeof parm: ", typeof(parm);
      print,"dimsof parm: ", dimsof(parm);

   } else {

      if( nterm != numberof(esti) ) {
         write,"Mismatch between nterm and numberof(esti)";
         return -1;
      }
      parm() = esti();
      if( chat > 2 ) print,"esti input: ", parm;
   }
   if( chat > 5 ) return parm;

   ndim = nterm;
   delta_parm = delta * parm;

   for(i=1; i<=ndim+1; i++ ) {
      for(j=1; j<=ndim; j++) {
         p(i,j) = parm(j);
         if( j+1 == i ) p(i,j) += delta_parm(j);
      }
   }
   for( i=1; i<=ndim+1; i++ ) {
      //for( j=1; j<=ndim; j++ ) parm(j) = p(i,j);
      parm() = p(i,);
      chi2_arr(i) = funk(parm);
      if( chat > 1 ) {
         if( nterm == 6 ) {
            print,"p c2 (init)= ", parm(1),parm(2),parm(3),parm(4),parm(5),parm(6),chi2_arr(i);
         } else {
            print,"p c2 (init)= ", parm(1),parm(2),parm(3),parm(4),parm(5),chi2_arr(i);
         }
      }
   }
   p_res = amoeba( funk, p, chi2_arr, ftol, iter);
   print,"iter = ",iter;
   if( chat > 1 ) {
      for( i=1; i<=ndim+1; i++ ) {
         if( nterm == 6 ) {
            print, p(i,1),p(i,2),p(i,3),p(i,4),p(i,5),p(i,6),chi2_arr(i);
         } else {
            print, p(i,1),p(i,2),p(i,3),p(i,4),p(i,5),chi2_arr(i);
         }
      }
      if( nterm == 6 ) {
         print,"Amplitude   Meanx  Meany     Sigmax  Sigmay   Bckg    Chi2";
      } else {
         print,"Amplitude   Meanx  Meany     Sigmax  Sigmay    Chi2";
      }
   }
   parm() = p(1,);

   return parm;

}

/* Function funk_amoeba */

func funk_amoeba(parm)
/* The Chi-square function */
{

   extern xval, yval, zval, n_points;

   arg = zval - model_amoeba(xval, yval, parm);
   return sum(arg^2);
}

/* Function model_amoeba */

func model_amoeba(x, y, parm)
{

   arg = ((x-parm(2))/parm(4))^2 + ((y-parm(3))/parm(5))^2;
   term1 = parm(1) * exp(-0.5*arg);

   return numberof(parm) == 6 ? term1+parm(6) : term1;
}

/* Function funkb */

func funkb(parm)
/* The Chi-square function */
{

   extern xval, yval, zval, n_points;

   arg = zval - modelb(xval, yval, parm);
   return sum(arg^2);
}

/* Function modelb */

func modelb(x, y, parm)
{

   arg = ((x-parm(2))/parm(4))^2 + ((y-parm(3))/parm(5))^2;
   term1 = parm(1) * exp(-0.5*arg);

   return numberof(parm) == 6 ? term1+parm(6) : term1;
}


/* Function gaussfit2ds_uam */

func gaussfit2ds_uam(x, y, z, ftol=, nterm=, esti=, delta=, chat= )
/* DOCUMENT coefs = gaussfit2ds_uam( x, y, ftol=, nterm=, esti=, delta=, chat= )

     Perform a 2D gauss fit for array 'z' with coordinates in 'x' and 'y'
     It returns a double array:
          [amplitude, mean_x, mean_y, sigma, bkg].

     This is the 'unconstrained sampling' version where the coordinate
     pairs (x,y) can be chosen freely in contrast to the mesh version
     - gaussfit2d_mam - where (x,y) belong to an MxN mesh of values.
     Here x, y, and z must be 1D arrays of same number of elements.

     If nterm == 4 or not given:
     yfit = coefs(1)*exp(-0.5*(((x-coefs(2))/coefs(4))^2 \
                            + ((y-coefs(3))/coefs(4))^2))
     If nterm == 5:
     yfit = <previous expression> + coefs(5)

     KEYWORD   ftol: fitting tolerance default value: 1.e-4
              nterm: number of terms (4 or 5)
               esti: estimated start values of coefficients
              delta: fractional parameter adjustment [default: 0.1]
               chat: chattiness level 1: some, 5: a LOT

     See also: gaussfit2d_uam where sigma_x and sigma_y are derived
     SEE ALSO:  autoesti

     2006-02-23/NJW  Cloned from gaussfit_am.i

*/
{
   require,"varfuncs.i";

   extern xval, yval, zval, n_points;

   if( is_void(nterm) ) nterm = 4;
   if( nterm != 4 && nterm != 5 ) {
      print,"Keyword nterm must be 4 or 5";
      return -1;
   }
   if( is_void(delta) ) delta = 0.1;
   if( is_void(ftol) ) ftol = 1.e-4;
   if( is_void(chat) ) chat = 0;

   p = array(double,nterm+1,nterm);
   parm = array(double,nterm);
   delta_parm = array(double,nterm);
   chi2_arr = array(double,nterm+1);

   xval = x;
   yval = y;
   zval = z;

   n_points = numberof(x);
   if( chat > 2 ) print,"n_points = ", n_points;


   /* parm(1) is amplitude,
      parm(2) is mean_x,
      parm(3) is mean_y,
      parm(4) is sigma_x,
      parm(5) is background if nterm==5 */

   /* prediction of values */

   if( is_void(esti) ) {
      // First estimation - broad peak
      parm_b = parm;
      sumn = sum(z);
      mean_x = sum(x*z) / sumn;
      stdev_x = (sum(x*x*z) - sumn*mean_x*mean_x)/sumn;
      mean_y = sum(y*z) / sumn;
      stdev_y = (sum(y*y*z) - sumn*mean_y*mean_y)/sumn;
      stdev = 0.5*(stdev_x + stdev_y);
      parm_b(1) = max(z);
      parm_b(2) = mean_x;
      parm_b(3) = mean_y;
      parm_b(4) = sqrt(stdev);
      if( nterm == 5 ) {
         r = sqrt(((x-mean_x)/stdev)^2 + ((y-mean_y)/stdev)^2);
         w = where( r > 2. );
         parm_b(5) = numberof(w) > 0 ? avg(z(w)) : 0.0;
         parm_b(1) -= parm_b(5);
      }
      if( chat > 2 ) {
         print,"start parm_b: ", parm_b;
         print,"chi2_b: ", funk(parm_b);
      }
      // Next estimation - narrow peak
      parm_n = parm;
      w = where( z > avg(z) );
      sumn = sum(z(w));
      mean_x = sum(x(w)*z(w)) / sumn;
      stdev_x = (sum(x(w)*x(w)*z(w)) - sumn*mean_x*mean_x)/sumn;
      mean_y = sum(y(w)*z(w)) / sumn;
      stdev_y = (sum(y(w)*y(w)*z(w)) - sumn*mean_y*mean_y)/sumn;
      stdev = sqrt(stdev_x*stdev_y);
      parm_n(1) = max(z(w));
      parm_n(2) = mean_x;
      parm_n(3) = mean_y;
      parm_n(4) = sqrt(stdev);
      if( nterm == 5 ) {
         r = sqrt(((x-mean_x)/stdev)^2 + ((y-mean_y)/stdev)^2);
         w = where( r > 2. );
         parm_n(5) = numberof(w) > 0 ? avg(z(w)) : 0.0;
         parm_n(1) -= parm_n(5);
      }
      if( chat > 2 ) {
         print,"start parm_n: ", parm_n;
         print,"chi2_n: ", funk(parm_n);
      }
      //parm = funk(parm_n) < funk(parm_b) ? parm_n : parm_b;
      chi2_b = funk(parm_b);
      chi2_n = funk(parm_n);
      if( chi2_n < chi2_b ) {
         print,"Choosing parm_n";
         parm = parm_n;
      } else {
         print,"Choosing parm_b";
         parm = parm_b;
      }
      print,"typeof parm: ", typeof(parm);
      print,"dimsof parm: ", dimsof(parm);

   } else {

      if( nterm != numberof(esti) ) {
         write,"Mismatch between nterm and numberof(esti)";
         return -1;
      }
      parm() = esti();
      if( chat > 2 ) print,"esti input: ", parm;
   }
   if( chat > 5 ) return parm;

   ndim = nterm;
   delta_parm = delta * parm;

   for(i=1; i<=ndim+1; i++ ) {
      for(j=1; j<=ndim; j++) {
         p(i,j) = parm(j);
         if( j+1 == i ) p(i,j) += delta_parm(j);
      }
   }
   for( i=1; i<=ndim+1; i++ ) {
      //for( j=1; j<=ndim; j++ ) parm(j) = p(i,j);
      parm() = p(i,);
      chi2_arr(i) = funk(parm);
      if( chat > 1 ) {
         if( nterm == 5 ) {
            print,"p c2 (init)= ", parm(1),parm(2),parm(3),parm(4),parm(5),chi2_arr(i);
         } else {
            print,"p c2 (init)= ", parm(1),parm(2),parm(3),parm(4),chi2_arr(i);
         }
      }
   }
   p_res = amoeba( funk, p, chi2_arr, ftol, iter);
   print,"iter = ",iter;
   if( chat > 1 ) {
      for( i=1; i<=ndim+1; i++ ) {
         if( nterm == 5 ) {
            print, p(i,1),p(i,2),p(i,3),p(i,4),p(i,5),chi2_arr(i);
         } else {
            print, p(i,1),p(i,2),p(i,3),p(i,4),chi2_arr(i);
         }
      }
      if( nterm == 5 ) {
         print,"Amplitude   Meanx  Meany     Sigma  Bckg    Chi2";
      } else {
         print,"Amplitude   Meanx  Meany     Sigma  Chi2";
      }
   }
   parm() = p(1,);

   return parm;

}





/* Function gaussfit_am */

func gaussfit_am(x, y, ftol=, nterm=, esti=, delta= )
/* DOCUMENT res = gaussfit_am( x, y, ftol=, nterm=, esti=, delta= )

     Perform a gauss fit for array 'y' with abscissae in 'x'
     It returns a double array with amplitude, mean, sigma, bkg.

     If nterm == 3 or not given:
     yfit = res(1)*exp(-0.5*((x-res(2))/res(3))^2)
     If nterm == 4:
     yfit = res(1)*exp(-0.5*((x-res(2))/res(3))^2) + res(4)

     KEYWORD   ftol: fitting tolerance default value: 1.e-4
              nterm: number of terms (3 or 4)
               esti: estimated start values of coefficients
              delta: fractional parameter adjustment [default: 0.1]


     SEE ALSO:  autoesti

     2005-04-12/NJW  Translated from C-program

*/
{
   require,"varfuncs.i";

   extern bds, yval;

   if( is_void(nterm) ) nterm = 3;
   if( nterm != 3 && nterm != 4 ) {
      print,"Keyword nterm must be 3 or 4";
      return -1;
   }
   if( is_void(delta) ) delta = 0.1;
   if( is_void(ftol) ) ftol = 1.e-4;

   p = array(double,nterm+1,nterm);
   parm = array(double,nterm);
   delta_parm = array(double,nterm);
   chi2_arr = array(double,nterm+1);

  /*
   *   define boundaries
   */
   b = 0.5*(x + shift(x,1));
   bds = 2*x(1) - b(1);
   grow,bds,b;
   bds(0) = 2*x(0) - b(-1);
   yval = y;

   n_points = numberof(y);


  /*
   *  parm(1) is constant,
   *  parm(2) is mean,
   *  parm(3) is sigma,
   *  parm(4) is background if nterm==4
   */

  /*
   *    prediction of values
   */

   if( is_void(esti) ) {
      sumn = sum(y);
      sumx = sum(x*y);
      sumx2 = sum(x*x*y);
      mean = sumx / sumn;
      stdev = (sumx2 - sumn*mean*mean)/sumn;
      parm(3) = sqrt(stdev);
      /* parm(1) = sumn * 0.398942280 / parm(3); */
      parm(1) = max(y);
      parm(2) = mean;
   } else {
      if( nterm != numberof(esti) ) {
         write,"Mismatch between nterm and numberof(esti)";
         return -1;
      }
      parm() = esti();
   }

   ndim = nterm;
   delta_parm(1) = delta * parm(1);
   delta_parm(2) = delta * parm(2);
   delta_parm(3) = delta * parm(3);
   if( nterm == 4 ) {
      parm(4) = 0.5*(y(1)+y(0));
      delta_parm(4) = delta * parm(1);
   }

   for(i=1; i<=ndim+1; i++ ) {
      for(j=1; j<=ndim; j++) {
         p(i,j) = parm(j);
         if( j+1 == i ) p(i,j) += delta_parm(j);
      }
   }
   for( i=1; i<=ndim+1; i++ ) {
      for( j=1; j<=ndim; j++ ) parm(j) = p(i,j);
      chi2_arr(i) = funka(parm);
      if( nterm == 4 ) {
         print,"p c2 = ", parm(1),parm(2),parm(3),parm(4),chi2_arr(i);
      } else {
         print,"p c2 = ", parm(1),parm(2),parm(3),chi2_arr(i);
      }
   }
   p_res = amoeba(funka, p, chi2_arr, ftol, iter);
   print,"iter = ",iter;
   for( i=1; i<=ndim+1; i++ ) {
      if( nterm == 4 ) {
         print, p(i,1),p(i,2),p(i,3),p(i,4),chi2_arr(i);
      } else {
         print, p(i,1),p(i,2),p(i,3),chi2_arr(i);
      }
   }
   if( nterm == 4 ) {
      print,"Amplitude   Mean     Sigma   Bckg    Chi2";
      parm(4) = p(1,4);
   } else {
      print,"Amplitude   Mean     Sigma    Chi2";
   }
   parm(1) = p(1,1);
   parm(2) = p(1,2);
   parm(3) = p(1,3);

   return parm;

}

/* Function funka */

func funka(parm)
/* The Chi-square function */
{

   extern bds, yval;

   sm = 0.0;
   for( i = 1; i <= n_points; i++ ) {
      sigma = 1.0;
      arg = yval(i) - modela(bds(i), bds(i+1), parm);
      if( sigma != 0.0 ) arg /= sigma;
      sm += arg*arg;
   }
   return sm;
}

/* Function modela */

func modela(x1, x2, parm)
{
   term1 = 2.506628275*parm(1)*parm(3)*(e0((x2-parm(2))/parm(3)) \
        -e0((x1-parm(2))/parm(3)))/(x2 - x1);

   if( numberof(parm) == 4 ) {
      return term1 + parm(4);
   } else {
      return term1;
   }
}


/* Function amoeba */

func amoeba(fitfun, p, y, ftol, &iter)
/* DOCUMENT p_res = amoeba( fitfun, p, y, ftol, >iter )

      Multidimensional minimization of the function 'fitfun(x)' where
      'x' is an ndim-dimensional vector, by the downhill Simplex method
      of Nelder and Mead. Input is a matrix 'p' whose ndim+1 rows are
      ndim-dimensional vectors which are vertices of the starting simplex.
      (Logical dimensions of 'p' are p(ndim+1,ndim); physical dimensions
      are input as p(mp,np)). Also input is the vector 'y' of length
      ndim+1, whose components must be preinitialized to the values of
      funk_amoeba evaluated at the ndim+1 vertices (rows) of 'p'; and ftol the
      fractional convergence tolerance to be achieved in the function value
      (NB!). On output, 'p' and 'y' will have been reset to ndim+1 new points
      all within ftol of a minimum function value, and iter gives the
      number of iterations taken.

      Translated from "Numerical Recipes"

      2008-03-14/NJW Updated 1) 'fitfun' is now an argument
                             2) returns best fit
*/

{

   sz = dimsof(p);
   ndim = sz(3);
   szy = dimsof(y);
   if( sz(2) != sz(3) + 1 || szy(2) != sz(2) ) {
      print,"Bad dimensions!";
      return [];
   }

   alpha = 1.0;
   beta  = 0.5;
   gamma = 2.0;
   itmax = 500;

   mpts = ndim + 1;
   pbar = array(double, ndim);
   pr = array(double, ndim);
   prr = array(double, ndim);
   iter = 0;

 while( 1 ) { /* replacement of FORTRAN goto statement */
   ilo = 1;
   if( y(1) > y(2) ) {
        ihi = 1;
        inhi = 2;
   }
   else {
        ihi = 2;
        inhi = 1;
   }
   for( i=1; i<= mpts; i++ ) {
        if( y(i) < y(ilo) ) ilo = i;
        if( y(i) > y(ihi) ) {
           inhi = ihi;
           ihi = i;
        }
        else if( y(i) > y(inhi) ) {
           if( i != ihi ) inhi = i;
        }
   }

 /* following 3 lines are updated with respect to original
          'Numerical Recipes' code    */

   div = abs( y(ihi)) + abs( y(ilo));
   if( div < ftol ) rtol = 2.*abs((y(ihi) - y(ilo)));
   else rtol = 2.0*abs((y(ihi) - y(ilo)))/div;

 /*  ------------------------------------  */

   if( rtol < ftol ) {
      write,format="%s","\n";
      return p(1,);
   }
   if( iter == itmax ) {
        write,format="\namoeba exceeding maximum number of iterations (%i).\n", itmax;
        return p(1,);
   }
   iter++;
   write,format="%s","*";
   if( iter%50 == 0 ) write,format="%s","\n";

   for( j=1; j<=ndim; j++) pbar(j) = 0.0; /* loop 12 */

   for( i=1; i<=mpts; i++) { /* loop 14 */
        if( i != ihi ) {
           for( j=1; j<=ndim; j++) pbar(j) += p(i,j);
        }
   }

   for( j=1; j<=ndim; j++) { /* loop 15 */
        pbar(j) /= ndim;
        pr(j) = (1. + alpha)*pbar(j) - alpha*p(ihi,j);
   }

   ypr = fitfun(pr);
   if( ypr <= y(ilo) ) {
        for( j=1; j<=ndim; j++) prr(j) = gamma*pr(j) + (1.-gamma)*pbar(j);
        yprr = fitfun(prr);
        if( yprr < y(ilo) ) {
           for( j=1; j<=ndim; j++) p(ihi,j) = prr(j);
           y(ihi) = yprr;
        }
        else {
           for( j=1; j<=ndim; j++ ) p(ihi,j) = pr(j);
           y(ihi) = ypr;
        }
   } else if( ypr >= y(inhi) ) {
        if( ypr < y(ihi) ) {
           for( j=1; j<=ndim; j++) p(ihi,j) = pr(j);
           y(ihi) = ypr;
        }
        for( j=1; j<=ndim; j++) prr(j) = beta*p(ihi,j) + (1.-beta)*pbar(j);
        yprr = fitfun(prr);
        if( yprr < y(ihi) ) {
           for( j=1; j<=ndim; j++) p(ihi,j) = prr(j);
           y(ihi) = yprr;
        }
        else {
           for( i=1; i<= mpts; i++) {
              if( i != ilo ) {
          for( j=1; j<=ndim; j++) {
             pr(j) = 0.5*(p(i,j) + p(ilo,j));
             p(i,j) = pr(j);
          }
          y(i) = fitfun(pr);
              }
           }
        }
   } else {
      for( j=1; j<=ndim; j++) p(ihi,j) = pr(j);
      y(ihi) = ypr;
   }
 } /* end of large dummy while loop */
}

/* Function ftex */

func ftex( x, p )
/* DOCUMENT res = ftex( x, p )

   Auxiliary function to 'gaussfitx' to return the model values.

   Expects 'x' to be bin boundaries and returns integrals
   of the gauss function over the individual bins divided
   with binsize i.e. an array with one less elements.

*/
{
   x1 = x(1:-1);
   x2 = x(2:0);
   sigma2 = p(3)*sqrt(2);
   xp = p(2);
   tb = erf((x2-xp)/sigma2);
   ta = erf((x1-xp)/sigma2);
   res = sqrt(pi/2)*p(3)*p(1)*(tb - ta)/(x2-x1);
   n = numberof(p);
   if( n > 3 ) res += p(4);
   if( n > 4 ) res += x(zcen)*p(5);
   if( n > 5 ) res += x(zcen)*x(zcen)*p(6);
   return res;
}

/* Function gaussfitx */

func gaussfitx( x, y, estimate, &yfit )
/* DOCUMENT coefs = gaussfitx( x, y, estimate, >yfit )

   The 'x' array are bin boundaries and must have one element
   more than 'y'.

   The number of elements in 'estimate' gives the number
   of terms in the fit.
   1: Amplitude
   2: Mean
   3: sigma
  [4: Constant]
  [5: Slope]
  [6: Curvature]

   If 'estimate' is not given then 'autoesti' is called.

     SEE ALSO:  autoesti

   2010-04-06/NJW Uses integrals over bins
*/
{

   if( is_void(estimate) ) {
      esti = autoesti( x, y );
   } else {
      esti = estimate;
   }
   r = lmfit( ftex, x, esti, y, 1. );

   yfit = ftex( x, esti );

   return esti;
}

/* Function fte1 */

func fte1( x, p )
/* DOCUMENT res = fte1( x, p )

   Auxiliary function to 'gaussfit' to return the model values.
*/
{
   res = p(1)*exp(-0.5*((x-p(2))/p(3))^2);
   n = numberof(p);
   if( n > 3 ) res += p(4);
   if( n > 4 ) res += x*p(5);
   if( n > 5 ) res += x*x*p(6);

   return res;
}

/* Function gaussfit */

func gaussfit( x, y, estimate, &yfit )
/* DOCUMENT coefs = gaussfit( x, y, estimate, >yfit )

   Uses 'lmfit' to perform a search for the best fit to the
   data (x,y) with a Gauss function on a 2. order background.

   The number of elements in 'estimate' gives the number
   of terms in the fit.
   1: Amplitude
   2: Mean
   3: sigma
  [4: Constant]
  [5: Slope]
  [6: Curvature]

   If 'estimate' is not given then 'autoesti' is called.

     SEE ALSO:  autoesti

   2007-05-03/NJW
*/
{

   if( is_void(estimate) ) {
      esti = autoesti( x, y );
   } else {
      esti = estimate;
   }
   r = lmfit( fte1, x, esti, y, 1. );

   yfit = array_gauss( x, esti );

   return esti;
}

/* Function _reduce_p */

func _reduce_p( p, freeze )
/* DOCUMENT newp = _reduce_p( p, freeze )

   Auxiliary function to amoeba_freeze
*/
{
   dms = dimsof( p );
   if( dms(1) != 2 ) error, "##1##";
   if( dms(2) != 1+dms(3) ) error, "##2##";

   dms -= [0,1,1];
   pm = array(double,dms);

   l = 1;
   for( k = 1; k <= dms(2)+1; k++ ) {
      if( k != freeze+1 ) {
         j = 1;
         for(i = 1; i<=dms(3)+1; i++ ) { // copy rows except frozen
            if( i != freeze ) pm(l,j++) = p(k,i);
         }
         l++;
      }
   }

   return pm;

}

/* Function fte2d */

func fte2d( im_tofit, p )
/* DOCUMENT model = fte2d( im_tofit, p )

   Auxiliary function for 'gaussfit_2d' to return the model image.

   'im_tofit' is only an argument for the dimensionality
   for the model.

   p = [amplitude, x-pos, y-pos, sigmax, sigmay] (5 elements)

*/
{
   tmpl = im_tofit*0.;
   return add_peak( tmpl, p(2), p(3), p(4), p(5), peak=p(1) );
}

/* Function gaussfit_2d */

func gaussfit_2d( im_tofit, estimate, &bestfit )
/* DOCUMENT coefs = gaussfit_2d( im_tofit, estimate, >bestfit )

   Fitting a 2D gaussian to an image ('im_tofit').
   'estimate' must hold 5 values for starting values:
      estimate = [amplitude, x-pos, y-pos, sigmax, sigmay]
   The fitted values are returned in 'coefs' and the best fit image
   in 'bestfit'.

*/
{
   esti = estimate;
   r = lmfit( fte2d, im_tofit, esti, im_tofit, 1. );

   bestfit = fte2d( im_tofit, esti );

   return esti;

}

/* Function prepare_gf2d */

func prepare_gf2d( im_tofit )
/* DOCUMENT estimate = prepare_gf2d( im_tofit )

   Return best guess for 2D gauss fitting around highest pixel value.

*/
{
   local maxval, xc, yc;

   dms = dimsof( im_tofit );
   maxim, im_tofit, maxval, xc, yc;
   res = array(double, 5);
   res(1) = maxval;

   // peak in x-direction

   y = im_tofit(,yc);
   x = 1.*indgen(dms(2));
   estimate = [maxval, xc, 1., 0., 0.];
   coefs = gaussfit( x, y, estimate, yfit );
   window,1;
   plot,x,y,ps=10,title="Fit in X";
   oplot, x, yfit, color="red";
   res(2) = coefs(2);
   res(4) = coefs(3);

   // peak in y-direction

   y = im_tofit(xc,);
   x = 1.*indgen(dms(3));
   estimate = [maxval, yc, 1., 0., 0.];
   coefs = gaussfit( x, y, estimate, yfit );
   window,2;
   plot,x,y,ps=10,title="Fit in Y";
   oplot, x, yfit, color="red";
   res(3) = coefs(2);
   res(5) = coefs(3);

   return res;

}


/* Function _reduce_y */

func _reduce_y( y, freeze )
/* DOCUMENT newy = _reduce_y( y, freeze )

   Auxiliary function to amoeba_freeze
*/
{
   dms = dimsof( y );
   if( dms(1) != 1 ) error, "##3##";

   dms -= [0,1];
   ym = array(double,dms);

   j = 1;
   for(i = 1; i<=dms(2)+1; i++ ) { // copy except frozen
      if( i != freeze+1 ) ym(j++) = y(i);
   }

   return ym;

}

/* Function amoeba_freeze */

func amoeba_freeze(fitfun, p, y, ftol, &iter, freeze= )
/* DOCUMENT p_res = amoeba_freeze( fitfun, p, y, ftol, >iter, freeze=  )

      Multidimensional minimization of the function 'fitfun(x)' where
      'x' is an ndim-dimensional vector, by the downhill Simplex method
      of Nelder and Mead. Input is a matrix 'p' whose ndim+1 rows are
      ndim-dimensional vectors which are vertices of the starting simplex.
      (Logical dimensions of 'p' are p(ndim+1,ndim); physical dimensions
      are input as p(mp,np)). Also input is the vector 'y' of length
      ndim+1, whose components must be preinitialized to the values of
      funk_amoeba evaluated at the ndim+1 vertices (rows) of 'p'; and ftol the
      fractional convergence tolerance to be achieved in the function value
      (NB!). On output, 'p' and 'y' will have been reset to ndim+1 new points
      all within ftol of a minimum function value, and iter gives the
      number of iterations taken.

      Translated from "Numerical Recipes"

      2008-03-14/NJW Updated 1) 'fitfun' is now an argument
                             2) returns best fit
*/

{

   if( freeze ) {
      frozen = p(1,freeze);
      p = _reduce_p( p, freeze);
      y = _reduce_y( y, freeze);
   }

   sz = dimsof(p);
   ndim = sz(3);
   szy = dimsof(y);
   if( sz(1) != 2 || sz(2) != sz(3) + 1 || szy(2) != sz(2) ) {
      print,"AMOEBA_F: sz = ", sz, " szy = ", szy;
      error,"AMOEBA_F: Bad dimensions!";
   }

   alpha = 1.0;
   beta  = 0.5;
   gamma = 2.0;
   itmax = 500;

   mpts = ndim + 1;
   pbar = array(double, ndim);
   pr = array(double, ndim);
   prr = array(double, ndim);
   iter = 0;

 while( 1 ) { /* replacement of FORTRAN goto statement */
   ilo = 1;
   if( y(1) > y(2) ) {
        ihi = 1;
        inhi = 2;
   }
   else {
        ihi = 2;
        inhi = 1;
   }
   for( i=1; i<= mpts; i++ ) {
        if( y(i) < y(ilo) ) ilo = i;
        if( y(i) > y(ihi) ) {
           inhi = ihi;
           ihi = i;
        }
        else if( y(i) > y(inhi) ) {
           if( i != ihi ) inhi = i;
        }
   }

 /* following 3 lines are updated with respect to original
          'Numerical Recipes' code    */

   div = abs( y(ihi)) + abs( y(ilo));
   if( div < ftol ) rtol = 2.*abs((y(ihi) - y(ilo)));
   else rtol = 2.0*abs((y(ihi) - y(ilo)))/div;

 /*  ------------------------------------  */

   if( rtol < ftol ) {
      write,format="%s","\n";
      res = p(1,);
      if( freeze ) res = insert( frozen, res, freeze );
      return res;
   }
   if( iter == itmax ) {
      write,format="\namoeba exceeding maximum number of iterations (%i).\n", itmax;
      res = p(1,);
      if( freeze ) res = insert( frozen, res, freeze );
      return res;
   }
   iter++;
   write,format="%s","*";
   if( iter%50 == 0 ) write,format="%s","\n";

   for( j=1; j<=ndim; j++) pbar(j) = 0.0; /* loop 12 */

   for( i=1; i<=mpts; i++) { /* loop 14 */
        if( i != ihi ) {
           for( j=1; j<=ndim; j++) pbar(j) += p(i,j);
        }
   }

   for( j=1; j<=ndim; j++) { /* loop 15 */
        pbar(j) /= ndim;
        pr(j) = (1. + alpha)*pbar(j) - alpha*p(ihi,j);
   }

   ypr = freeze ? fitfun(insert(frozen,pr,freeze)) : fitfun(pr);
   if( ypr <= y(ilo) ) {
        for( j=1; j<=ndim; j++) prr(j) = gamma*pr(j) + (1.-gamma)*pbar(j);
        yprr = freeze ? fitfun(insert(frozen,prr,freeze)) : fitfun(prr);
        if( yprr < y(ilo) ) {
           for( j=1; j<=ndim; j++) p(ihi,j) = prr(j);
           y(ihi) = yprr;
        }
        else {
           for( j=1; j<=ndim; j++ ) p(ihi,j) = pr(j);
           y(ihi) = ypr;
        }
   } else if( ypr >= y(inhi) ) {
        if( ypr < y(ihi) ) {
           for( j=1; j<=ndim; j++) p(ihi,j) = pr(j);
           y(ihi) = ypr;
        }
        for( j=1; j<=ndim; j++) prr(j) = beta*p(ihi,j) + (1.-beta)*pbar(j);
        yprr = freeze ? fitfun(insert(frozen,prr,freeze)) : fitfun(prr);
        if( yprr < y(ihi) ) {
           for( j=1; j<=ndim; j++) p(ihi,j) = prr(j);
           y(ihi) = yprr;
        }
        else {
           for( i=1; i<= mpts; i++) {
              if( i != ilo ) {
                 for( j=1; j<=ndim; j++) {
                    pr(j) = 0.5*(p(i,j) + p(ilo,j));
                    p(i,j) = pr(j);
                 }
                 y(i) = freeze ? fitfun(insert(frozen,pr,freeze)) : fitfun(pr);
              }
           }
        }
   } else {
      for( j=1; j<=ndim; j++) p(ihi,j) = pr(j);
      y(ihi) = ypr;
   }

 } /* end of large dummy while loop */

}

/* Function golden */

func golden( ax, bx, cx, f, tol, &xmin )
/* DOCUMENT f_val = golden( ax, bx, cx, function, tol, >xmin )

   Find the minimum of a function of a single variable 'f'.
   Returns the function value in the minimum and the
   x-value in the argument: 'ximin'.

   Input ax, bx, cx are bracketing x values (as from 'mnbrak')

   From Numerical Recipes, 2009-11-05/NJW
*/
{
    //c float f0,f1,f2,f3,x0,x1,x2,x3;

    R = 0.61803399;
    C = 1.0 - R;

    x0 = ax;
    x3 = cx;
    if( abs(cx-bx) > abs(bx-ax)) {
       x1 = bx;
       x2 = bx+C*(cx-bx);
    } else {
       x2 = bx;
       x1 = bx-C*(bx-ax);
    }
    f1 = f(x1);
    f2 = f(x2);

    // The stop criterion has been changed to
    //   max(1.,abs(x1)+abs(x2)) rather than
    //   abs(x1)+abs(x2), since a minimum near x=0
    //   leads to too many iterations, 2009-11-06/NJW

    while( abs(x3-x0) > tol*max(1.,abs(x1)+abs(x2))) {

       if( f2 < f1) {
          x0 = x1;
          x1 = x2;
          x2 = R*x1+C*x3;
          f1 = f2;
          f2 = f(x2);
       } else {
          x3 = x2;
          x2 = x1;
          x1 = R*x2+C*x0;
          f2 = f1;
          f1 = f(x1);
       }
    }
    if( f1 < f2) {
       xmin = x1;
       final = f1;
    } else {
       xmin = x2;
       final = f2;
    }
    return final;
}

/* Function mnbrak */

func mnbrak( &ax, &bx, &cx, &fa, &fb, &fc, f, glimit= )
/* DOCUMENT mnbrak, (>)ax, (>)bx, (>)cx, >fa, >fb, >fc, f, glimit=

   Seek three points ax, bx, cx, such that
      fb=f(bx) < fa=f(ax) && fb < fc=f(cx)
      and ax < bx < cx  or   cx < bx < ax

   Numerical Recipes p. 281, 2009-08-16/NJW
*/
{
   gold = 1.618034;
   if( is_void(glimit) ) glimit = 100.;
   tiny = 1.e-20;

   fa = f(ax);
   fb = f(bx);

   if( fb > fa ) { // switch roles of ax and bx
      dum = ax; ax = bx; bx = dum;
      dum = fb; fb = fa; fa = dum;
   }

   cx = bx + gold*(bx - ax); // first guess for cx
   fc = f(cx);

   // mark1:

   while( fb >= fc ) {
      r = (bx-ax)*(fb-fc);
      q = (bx-cx)*(fb-fa);
      divisor = q-r >= 0 ? 2.*max(abs(q-r),tiny) : -2.*max(abs(q-r),tiny);
      u = bx-((bx-cx)*q-(bx-ax)*r)/divisor;
      ulim = bx + glimit*(cx-bx);
      if( (bx-u)*(u-cx) > 0. ) { // parabolic u is between b and c
         fu = f(u);
         if( fu < fc ) {
            ax = bx;
            fa = fb;
            bx = u;
            fb = fu;
            continue; // goto mark1;
         } else if( fu > fb ) {
            cx = u;
            fc = fu;
            continue; // goto mark1;
         }
         u = cx + gold*(cx-bx);
         fu = f(u);
      } else if( (cx-u)*(u-ulim) > 0. ) {
         fu = f(u);
         if( fu < fc ) {
            bx = cx;
            cx = u;
            u = cx + gold*(cx-bx);
            fb = fc;
            fc = fu;
            fu = f(u);
         }
      } else if( (u-ulim)*(ulim-cx) >= 0. ) {
         u = ulim;
         fu = f(u);
      } else {
         u = cx + gold*(cx-bx);
         fu = f(u);
      }
      ax = bx;
      bx = cx;
      cx = u;
      fa = fb;
      fb = fc;
      fc = fu;
   }
}

/* Function mnbrak_lg */

func mnbrak_lg( &ax, &bx, &cx, &fa, &fb, &fc, f, glimit= )
/* DOCUMENT mnbrak_lg, (>)ax, (>)bx, (>)cx, >fa, >fb, >fc, f, glimit=

   Seek three points ax, bx, cx, such that
      fb=f(bx) < fa=f(ax) && fb < fc=f(cx)
      and ax < bx < cx  or   cx < bx < ax

   Numerical Recipes p. 281, 2009-08-16/NJW
   Adapted to use only positive values for x,  2012-05-09/NJW
*/
{
   gold = 1.618034;
   if( is_void(glimit) ) glimit = 100.;
   tiny = 1.e-20;

   fa = f(ax);
   fb = f(bx);

   if( fb > fa ) { // switch roles of ax and bx
      dum = ax; ax = bx; bx = dum;
      dum = fb; fb = fa; fa = dum;
   }

   cx = bx + gold*(bx - ax); // first guess for cx
   fc = f(cx);

   // mark1:

   while( fb >= fc ) {
      r = (bx-ax)*(fb-fc);
      q = (bx-cx)*(fb-fa);
      divisor = q-r >= 0 ? 2.*max(abs(q-r),tiny) : -2.*max(abs(q-r),tiny);
      u = bx-((bx-cx)*q-(bx-ax)*r)/divisor;
      ulim = bx + glimit*(cx-bx);
      if( (bx-u)*(u-cx) > 0. ) { // parabolic u is between b and c
         fu = f(u);
         if( fu < fc ) {
            ax = bx;
            fa = fb;
            bx = u;
            fb = fu;
            continue; // goto mark1;
         } else if( fu > fb ) {
            cx = u;
            fc = fu;
            continue; // goto mark1;
         }
         u = cx + gold*(cx-bx);
         fu = f(u);
      } else if( (cx-u)*(u-ulim) > 0. ) {
         fu = f(u);
         if( fu < fc ) {
            bx = cx;
            cx = u;
            u = cx + gold*(cx-bx);
            fb = fc;
            fc = fu;
            fu = f(u);
         }
      } else if( (u-ulim)*(ulim-cx) >= 0. ) {
         u = ulim;
         fu = f(u);
      } else {
         u = cx + gold*(cx-bx);
         fu = f(u);
      }
      ax = bx;
      bx = cx;
      cx = u;
      fa = fb;
      fb = fc;
      fc = fu;
   }
}

/* Function mnbrak_lg_simple */

func mnbrak_lg_simple( &ax, &bx, &cx, &fa, &fb, &fc, f )
/* DOCUMENT mnbrak_lg_simple, (>)ax, (>)bx, (>)cx, >fa, >fb, >fc, f

   Seek three points ax, bx, cx, such that
      fb=f(bx) < fa=f(ax) && fb < fc=f(cx)
      and ax < bx < cx  or   cx < bx < ax

   Adapted to use only positive values for x,  2012-05-09/NJW
*/
{

   exponen = 1.3;
   fa = f(ax);
   fb = f(bx);

   if( fb > fa ) { // switch roles of ax and bx
      dum = ax; ax = bx; bx = dum;
      dum = fb; fb = fa; fa = dum;
   }

   cx = bx * (bx/ax)^exponen; // first guess for cx
   fc = f(cx);

   while( fc < fb ) { // keep going in this direction
      u = cx * (cx/bx)^exponen;
      fu = f(u);
      zax = ax; // if a change of step size is necessary
      ax = bx;
      bx = cx;
      cx = u;
      zfa = fa;
      fa = fb;
      fb = fc;
      fc = fu;
   }
   if( fc > fb ) return;
   // fc == fb, go back and try with smaller step size
   cx = bx;
   bx = ax;
   ax = zax;
   fc = fb;
   fb = fa;
   fa = zfa;
   exponen = 1.;
   while( fc < fb ) {
      u = cx * (cx/bx)^exponen;
      fu = f(u);
      zax = ax; // if a change of step size is necessary
      ax = bx;
      bx = cx;
      cx = u;
      zfa = fa;
      fa = fb;
      fb = fc;
      fc = fu;
   }
   if( fc > fb ) return;

}

/* Function SiGn */

func SiGn( a, b )
/* DOCUMENT res = SiGn( a, b)

     Result of:
       return b > 0.0 ? abs(a) : -abs(a);
*/
{
   return b > 0.0 ? abs(a) : -abs(a);
}

/* Function brent */

func brent( ax, bx, cx, f, tol, &xmin)
/* DOCUMENT fval = brent( ax, bx, cx, f, tol, >xmin)

   Finds the minimum of function 'f' (of one variable)
   given the bracketing values ax, bx, cx (as from 'mnbrak')
   'tol' is the tolerance where a value of 1.e-4 is often
   sensible. The best x-value is returned in 'xmin' and the
   'brent' returns the value of the function in that point.

   From Numerical Recipes, 2009-11-06/NJW
*/
{
   ITMAX = 200;
   CGOLD = 0.3819660;
   ZEPS = 1.0e-10;
   e = 0.0;

   a = ((ax < cx) ? ax : cx);
   b = ((ax > cx) ? ax : cx);
   x = w = v = bx;
   fw = fv = fx = f(x);
   for( iter = 1; iter <= ITMAX; iter++ ) {
      xm = 0.5*(a+b);
      //+ tol2 = 2.0*(tol1 = tol*abs(x)+ZEPS);
      //    abs(x) changed to max(1.,abs(x)) to avoid absurdly
      //    low tolerance when minimum is at x=0, 2009-11-06/NJW
      tol2 = 2.0*(tol1 = tol*max(1.,abs(x))+ZEPS);
      if( abs(x-xm) <=  (tol2-0.5*(b-a))) {
         xmin = x;
         return fx;
      }
      if( abs(e) > tol1) {
         r = (x-w)*(fx-fv);
         q = (x-v)*(fx-fw);
         p = (x-v)*q-(x-w)*r;
         q = 2.0*(q-r);
         if( q > 0.0) p = -p;
         q = abs(q);
         etemp = e;
         e = d;
         if( abs(p) >= abs(0.5*q*etemp) || p <= q*(a-x) || p >= q*(b-x))
            d = CGOLD*(e = (x >= xm ? a-x : b-x));
         else {
            d = p/q;
            u = x+d;
            if (u-a < tol2 || b-u < tol2)
               d = SiGn(tol1,xm-x);
         }
      } else {
         d = CGOLD*(e = (x >=  xm ? a-x : b-x));
      }
      u = (abs(d) >=  tol1 ? x+d : x+SiGn(tol1,d));
      fu = f(u);
      if( fu <=  fx) {
         if( u >=  x) a = x; else b = x;
         //+ ShFt(v,w,x,u)
         //+ ShFt(fv,fw,fx,fu)
         v = w;
         w = x;
         x = u;
         fv = fw;
         fw = fx;
         fx = fu;
      } else {
         if (u < x) a = u; else b = u;
         if (fu <= fw || w == x) {
            v = w;
            w = u;
            fv = fw;
            fw = fu;
         } else if (fu <= fv || v == x || v == w) {
            v = u;
            fv = fu;
         }
      }
   }
   error,"Too many iterations in BRENT";
   xmin = x;
   return fx;
}

/* Function powell */

func powell( &p, &xi, n, ftol, &iter, &fret, fnuc )
/* DOCUMENT powell( (>)p, (>)xi, n, ftol, >iter, >fret, fnuc )

   Minimization of a function 'fnuc' of 'n' variables.
   Input consists of an initial starting point 'p' that is
   a vector of length 'n'; an initial matrix 'xi' of dimensions 'n' by 'n',
   and whose columns contain the initial set of directions (usually
   the 'n' unit vectors); and 'ftol' the fractional tolerance in the
   function value such that failure to decrease by more than this amount
   on one iteration signals doneness. On output, 'p' is set to the
   best point found, 'xi' is the then-current direction set, 'fret' is
   the returned function value at 'p', and 'iter' is the number of
   iterations taken.
   Used: linmin

   From Numerical Recipes  2009-11-06/NJW
*/
{
   extern _powell_ftol;
   ITMAX = 300;

   _powell_ftol = ftol;

   //+ pt = array(double, n);
   //+ ptt = array(double, n);
   //+ xit = array(double, n);
   fret = fnuc(p);

   pt = p;
   for( iter = 1;; iter++) {
      fp = fret;
      ibig = 0;
      del = 0.0;
      for( i = 1; i <= n; i++ ) {
         //+ for( j = 1; j <= n; j++ ) xit(j) = xi(j,i);
         xit = xi(,i);
         fptt = fret;
         linmin, p, xit, n, fret, fnuc;
         if( abs(fptt-fret) > del ) {
            del = abs(fptt-fret);
            ibig = i;
         }
      }
      //+ if( 2.0*abs(fp-fret) <=  ftol*(abs(fp)+abs(fret)))
      //  avoid absurdly low tolerance for near zero values
      //       2009-11-06/NJW
      if( 2.0*abs(fp-fret) <=  ftol*max(1.,abs(fp)+abs(fret))) {
         return;
      }
      if( iter == ITMAX ) error,"Too many iterations in routine POWELL";
      //+ for( j = 1; j <= n; j++ ) {
      //+    ptt(j) = 2.0*p(j)-pt(j);
      //+    xit(j) = p(j)-pt(j);
      //+    pt(j) = p(j);
      //+ }
      ptt = 2.0*p - pt;
      xit = p - pt;
      pt = p;
      fptt = fnuc(ptt);
      if( fptt < fp) {
         t = 2.0*(fp-2.0*fret+fptt)*(fp-fret-del)^2-del*(fp-fptt)^2;
         if( t < 0.0) {
            linmin, p, xit, n, fret, fnuc;
            //+ for( j = 1; j <= n; j++ ) xi(j,ibig) = xit(j);
            xi(,ibig) = xit;
         }
      }
   }
}

/* Function powell_lg */

func powell_lg( &p, &xi, n, ftol, &iter, &fret, fnuc, chat= )
/* DOCUMENT powell_lg( (>)p, (>)xi, n, ftol, >iter, >fret, fnuc, chat= )

   Minimization of a function 'fnuc' of 'n' variables.
   Input consists of an initial starting point 'p' that is
   a vector of length 'n'; an initial matrix 'xi' of dimensions 'n' by 'n',
   and whose columns contain the initial set of directions (usually
   the 'n' unit vectors); and 'ftol' the fractional tolerance in the
   function value such that failure to decrease by more than this amount
   on one iteration signals doneness. On output, 'p' is set to the
   best point found, 'xi' is the then-current direction set, 'fret' is
   the returned function value at 'p', and 'iter' is the number of
   iterations taken.
   Used: linmin_lg

   From Numerical Recipes  2009-11-06/NJW
*/
{
   extern _powell_ftol;
   ITMAX = 300;

   _powell_ftol = ftol;

   //+ pt = array(double, n);
   //+ ptt = array(double, n);
   //+ xit = array(double, n);
   fret = fnuc(p);
   if(chat)write,format="Plg 1 p = (%.5f, %.5f) fret = %.6f\n", p(1), p(2), fret;

   pt = p;
   for( iter = 1;; iter++) {
      fp = fret;
      ibig = 0;
      del = 0.0;
      for( i = 1; i <= n; i++ ) {
         //+ for( j = 1; j <= n; j++ ) xit(j) = xi(j,i);
         xit = xi(,i);
         fptt = fret;
         linmin_lg, p, xit, n, fret, fnuc;
         if( abs(fptt-fret) > del ) {
            del = abs(fptt-fret);
            ibig = i;
         }
      }
      //+ if( 2.0*abs(fp-fret) <=  ftol*(abs(fp)+abs(fret)))
      //  avoid absurdly low tolerance for near zero values
      //       2009-11-06/NJW
      if( 2.0*abs(fp-fret) <=  ftol*max(1.,abs(fp)+abs(fret))) {
         return;
      }
      if( iter == ITMAX ) error,"Too many iterations in routine POWELL";
      //+ for( j = 1; j <= n; j++ ) {
      //+    ptt(j) = 2.0*p(j)-pt(j);
      //+    xit(j) = p(j)-pt(j);
      //+    pt(j) = p(j);
      //+ }
      ptt = 2.0*p - pt;
      xit = p - pt;
      pt = p;
      fptt = fnuc(ptt);
      if( fptt < fp) {
         t = 2.0*(fp-2.0*fret+fptt)*(fp-fret-del)^2-del*(fp-fptt)^2;
         if( t < 0.0) {
            linmin_lg, p, xit, n, fret, fnuc;
            //+ for( j = 1; j <= n; j++ ) xi(j,ibig) = xit(j);
            xi(,ibig) = xit;
         }
      }
   }
}

/* Function f1dim */

func f1dim( x ) // Auxiliary function for 'linmin'
{
   extern _linmin_n, _linmin_p, _linmin_xi;
     // _linmin_n is the number of variables
     // _linmin_p is an array of _linmin_n values
     // _linmin_xi is an array of _linmin_n values
   extern _powell_func; // for the function to minimize

   //+ xt = array(double, _linmin_n); // will be input to function
   //+ for( j = 1; j <= _linmin_n; j++ ) {
   //+    xt(j) = _linmin_p(j) + x*_linmin_xi(j);
   //+ }
   xt = _linmin_p + x * _linmin_xi;
   return _powell_func(xt);
}

/* Function linmin */
   
func linmin( &p, &xi, n, &fret, fnuc)
/* DOCUMENT linmin, (>)p, (>)xi, n, >fret, fnuc

    Auxiliary function for 'powell'

    Numerical Recipes,   2009-11-06/NJW
*/
{
   extern _linmin_n, _linmin_p, _linmin_xi;
   extern _powell_func, _powell_ftol;

   local ax, xx, bx, fa, fx, fb, xmin;

   _linmin_n = n;
   //+ _linmin_p  =  array(double, n);
   //+ _linmin_xi  =  array(double, n);

   _powell_func = fnuc; // called by 'f1dim'
   //+ for( j = 1; j <= n; j++ ) {
   //+    _linmin_p(j) = p(j);
   //+    _linmin_xi(j) = xi(j);
   //+ }
   _linmin_p = p;
   _linmin_xi = xi;
   ax = 0.0;
   xx = 1.0;
   bx = 2.0;
   mnbrak, ax, xx, bx, fa, fx, fb, f1dim;
   fret = brent( ax, xx, bx, f1dim, _powell_ftol, xmin);
   //+ for( j = 1; j <= n; j++ ) {
   //+    xi(j) *= xmin;
   //+    p(j) += xi(j);
   //+ }
   xi *= xmin;
   p += xi;
}

/* Function linmin_lg */
   
func linmin_lg( &p, &xi, n, &fret, fnuc)
/* DOCUMENT linmin_lg, (>)p, (>)xi, n, >fret, fnuc

    Auxiliary function for 'powell_lg'

    Numerical Recipes,   2009-11-06/NJW
*/
{
   extern _linmin_n, _linmin_p, _linmin_xi;
   extern _powell_func, _powell_ftol;

   local ax, xx, bx, fa, fx, fb, xmin;

   _linmin_n = n;
   //+ _linmin_p  =  array(double, n);
   //+ _linmin_xi  =  array(double, n);

   _powell_func = fnuc; // called by 'f1dim'
   //+ for( j = 1; j <= n; j++ ) {
   //+    _linmin_p(j) = p(j);
   //+    _linmin_xi(j) = xi(j);
   //+ }
   _linmin_p = p;
   _linmin_xi = xi;
   ax = 0.0;
   xx = 1.0;
   bx = 2.0;
   mnbrak_lg_simple, ax, xx, bx, fa, fx, fb, f1dim;
   fret = brent( ax, xx, bx, f1dim, _powell_ftol, xmin);
   //+ for( j = 1; j <= n; j++ ) {
   //+    xi(j) *= xmin;
   //+    p(j) += xi(j);
   //+ }
   xi *= xmin;
   p += xi;
}

/* Function expodecayfit */

func expodecayfit( t, y, dy, pl=, ini= )
/* DOCUMENT p = expodecayfit( t, y, dy, pl=, ini= )

    Fits  p(1) * exp( -p(2) * t ) to y
    using weight 1/dy^2
    (defined in function edf_modelf)

    Keyword 'pl' for plotting
            'ini' for initial parameters 'p'
*/
{

   // initial guess
   if( is_void(ini) ) {
      p = [10., 1.];
   } else {
      p = ini;
   }

   res = lmfit( edf_modelf, t, p, y, 1./dy^2 );
   write,format="Chi2 red = %12.6f\n", res.chi2_last/res.nfree;
   write,format="Constant: %10.4f\n", p(1);
   write,format="   Decay: %10.4f\n", p(2);
   if( pl ) {
      dataplot, t, y, dy, xbar=1;
      oplot,t,edf_modelf( t, p ),color="red";
   }
   return p;

}
func edf_modelf( t, p )
{
   return p(1) * exp( -p(2) * t );
}

/* Function lmfit */

/* 
 * lmfit.i --
 *
 *      Non-linear least-squares fit by Levenberg-Marquardt method.
 *
 * Copyright (c) 1997, Eric THIEBAUT (thiebaut@obs.univ-lyon1.fr, Centre de
 * Recherche Astrophysique de Lyon, 9 avenue Charles  Andre,  F-69561 Saint
 * Genis Laval Cedex).
 *
 * This program is free software; you can redistribute it and/or  modify it
 * under the terms of the GNU General Public License  as  published  by the
 * Free Software Foundation; either version 2 of the License,  or  (at your
 * option) any later version.
 *
 * 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.   See  the GNU
 * General Public License for more details (to receive a  copy  of  the GNU
 * General Public License, write to the Free Software Foundation, Inc., 675
 * Mass Ave, Cambridge, MA 02139, USA).
 *
 * History:
 *      $Id: lmfit.i,v 1.2 1997/07/28 08:26:25 eric Exp $
 *      $Log: lmfit.i,v $
 *      Revision 1.2  1997/07/28 08:26:25  eric
 *       - Fix the doc.
 *
 *      Revision 1.1  1997/04/21 08:34:04  eric
 *      Initial revision
 *-----------------------------------------------------------------------------
 */

require, "random.i";

struct lmfit_result {
/* DOCUMENT lmfit_result -- structure returned by lmfit
 */
    long        neval;
    long        niter;
    long        nfit;
    long        nfree;
    long        monte_carlo;
    double      chi2_first;
    double      chi2_last;
    double      conv;
    double      sigma;
    double      lambda;
    pointer     stdev;
    pointer     stdev_monte_carlo;
    pointer     correl;
}

func lmfit(f, x, &a, y, w, fit=, correl=, stdev=, gain=, tol=, deriv=, itmax=,
        lambda=, eps=, monte_carlo=)
/* DOCUMENT lmfit -- Non-linear least-squares fit by Levenberg-Marquardt
                     method.

   DESCRIPTION:
     Implement Levenberg-Marquardt method  to  perform  a  non-linear least
     squares fit to a function of an arbitrary number of  parameters.   The
     function  may  be  any  non-linear  function.   If  available, partial
     derivatives can be calculated by the user function, else  this routine
     will  estimate  partial   derivatives   with   a   forward  difference
     approximation.

   CATEGORY:
     E2 - Curve and Surface Fitting.

   SYNTAX:
     result= lmfit(f, x, a, y, w, ...);

   INPUTS:
     F:  The model function  to  fit.   The  function  must  be  written as
         described under RESTRICTIONS, below.
     X:  Anything useful for the model function, for  instance: independent
         variables, a complex structure of  data  or  even  nothing!.   The
         LMFIT routine does not manipulate or use values  in  X,  it simply
         passes X to the user-written function F.
     A:  A vector that contains the initial estimate for each parameter.
     Y:  Array of dependent variables (i.e., the  data).   Y  can  have any
         geometry, but it must be the same as the result returned by F.
     W:  Optional weight,  must be conformable  with Y and all  values of W
         must be positive  or null (default = 1.0).   Data points with zero
         weight are not fitted.  Here are some examples:
           - For no weighting (lest square fit): W = 1.0
           - For instrumental weighting: W(i) = 1.0/Y(i)
           - Gaussian noise: W(i) = 1.0/Var(Y(i))

   OUTPUTS:
     A:  The vector of fitted parameters.
     Returns a structure lmfit_result with fields:
       NEVAL:  (long) number of model function evaluations.
       NITER:  (long) number of iteration, i.e. successful CHI2 reductions.
       NFIT:   (long) number of fitted parameters.
       NFREE:  (long) number of degrees of freedom  (i.e.,  number of valid
               data points minus number of fitted parameters).
       MONTE_CARLO: (long) number of Monte Carlo simulations.
       CHI2_FIRST: (double) starting error value: CHI2=sum(W*(F(X,A)-Y)^2).
       CHI2_LAST: (double) last best error value: CHI2=sum(W*(F(X,A)-Y)^2).
       CONV:   (double) relative variation of CHI2.
       SIGMA:  (double) estimated uniform standard deviation of data.  If a
               weight is provided, a  value  of  SIGMA  different  from one
               indicates  that,  if  the  model  is  correct,  W  should be
               multiplied    by     1/SIGMA^2.      Computed     so    that
               sum(W*(F(X,A)-Y)^2)/SIGMA^2=NFREE.
       LAMBDA: (double) last value of LAMBDA.
       STDEV:  (pointer) standard deviation vector of the parameters.
       STDEV_MONTE_CARLO: (pointer)  standard   deviation  vector  of  the
               parameters estimated by Monte Carlo simulations.
       CORREL: (pointer) correlation matrice of the parameters.

   KEYWORDS:
     FIT: List  of  indices  of  parameters  to  fit,  the  others  remaing
          constant.  The default is to tune all parameters.
     CORREL: If  set  to a  non  zero and  non-nil  value, the  correlation
          matrice of the parameters is stored into LMFIT result.
     STDEV: If set to a non zero and non-nil value, the standard deviation
          vector of the parameters is stored into LMFIT result.
     DERIV: When set to a non zero and non-nil  value,  indicates  that the
          model function F is able to compute its derivatives  with respect
          to  the  parameters   (see   RESTRICTIONS).    By   default,  the
          derivatives will be estimated by LMFIT using  forward difference.
          If analytical derivatives are  available  they  should  always be
          used.
     EPS: Small positive value  used  to  estimate  derivatives  by forward
          difference.  Must be such that 1.0+EPS  and  1.0  are numerically
          different  and   should   be   about  sqrt(machine_precision)/100
          (default = 1e-6).
     TOL: Stop criteria for the convergence (default =  1e-7).   Should not
          be smaller  than  sqrt(machine_precision).   The  routine returns
          when  the  relative  decrease of  CHI2 is  less  than  TOL  in an
          interation.
     ITMAX: Maximum number of iterations. Default = 100.
     GAIN: Gain factor for tuning LAMBDA (default = 10.0).
     LAMBDA: Starting value for parameter LAMBDA (default = 1.0e-3).
     MONTE_CARLO: Number of Monte Carlo  simulations to perform to estimate
          standard  deviation  of  parameters  (by default  no Monte  Carlo
          simulations are undergone).  May spend a lot of time if you use a
          large number; but should not be too small!

   GLOBAL VARIABLES:
     None.

   SIDE EFFECTS:
     The values of the vector of parameters A are modified.

   PROCEDURE:
     The function to be fitted must be defined as follow:

       func F(x, a) {....}

     and returns a model with same shape as data Y.  If you want to provide
     analytic derivatives, F should be defined as:

       func F(x, a, &grad, deriv=)
       {
           y= ...;
           if (deriv) {
               grad= ...;
           }
           return y;
       }

     Where X are the independent variables (anything the function  needs to
     compute synthetic data except the model parameters), A  are  the model
     parameters, DERIV is  a  flag  set  to  non-nil  and  non-zero  if the
     gradient is needed and the output gradient GRAD  is  a  numberof(Y) by
     numberof(A) array: GRAD(i,j) = derivative of ith data point model with
     respect to jth parameter.

     LMFIT tune  parameters A so as to minimize:  CHI2=sum(W*(F(X,A)-Y)^2).
     The  Levenberg-Marquardt  method   consists  in  varying  between  the
     inverse-Hessian  method  and the  steepest  descent  method  where the
     quadratic  expansion of  CHI2  does  not  yield  a better  model.  The
     initial  guess of  the parameter  values  should  be as  close to  the
     actual values as possible or the solution may not converge or may give
     a wrong answer.

   RESTRICTIONS:
     Beware that  the result  does depend on your  initial guess A.  In the
     case of  numerous  local  minima,  the only  way to  get  the  correct
     solution is to start with A close enough to this solution.
     
     The estimates of  standard  deviation of the  parameters are  rescaled
     assuming that, for a correct model  and weights, the expected value of
     CHI2 should  be of the  order of NFREE=numberof(Y)-numberof(A)  (LMFIT
     actually compute NFREE from the number of valid data points and number
     of fitted parameters).   If you don't like this you'll have to rescale
     the returned  standard  deviation  to meet  your needs  (all necessary
     information are in the structure returned by LMFIT).

   EXAMPLE:
     This example is from ODRPACK (version 2.01).  The function to fit is
     of the form:
       f(x) = a1+a2*(exp(a3*x)-1.0)^2
     Starting guess:
       a= [1500.0,  -50.0,   -0.1];
     Independent variables:
       x= [   0.0,    0.0,    5.0,    7.0,    7.5,   10.0,
             16.0,   26.0,   30.0,   34.0,   34.5,  100.0];
     Data:
       y= [1265.0, 1263.6, 1258.0, 1254.0, 1253.0, 1249.8,
           1237.0, 1218.0, 1220.6, 1213.8, 1215.5, 1212.0];
     Function definition (without any optimization):
       func foo(x, a, &grad, deriv=)
       {
           if (deriv)
               grad= [array(1.0, dimsof(y)),
                      (exp(a(3)*x)-1.0)^2,
                      2.0*a(2)*x*exp(a(3)*x)*(exp(a(3)*x)-1.0)];
           return a(1)+a(2)*(exp(a(3)*x)-1.0)^2;
       }
       
     Fitting this model by:
       r= lmfit(foo, x, a, y, 1., deriv=1, stdev=1, monte_carlo=500, correl=1)
     produces typically the following result:
        a                   = [1264.84, -54.9987, -0.0829835]
        r.neval             = 12
        r.niter             = 6
        r.nfit              = 3
        r.nfree             = 9
        r.monte_carlo       = 500
        r.chi2_first        = 40.4383
        r.chi2_last         = 40.4383
        r.conv              = 3.84967e-09
        r.sigma             = 0.471764
        r.lambda            = 1e-09
       *r.stdev             = [1.23727, 1.78309, 0.00575123]
       *r.stdev_monte_carlo = [1.20222, 1.76120, 0.00494790]
       *r.correl            = [[ 1.000, -0.418, -0.574],
                               [-0.418,  1.000, -0.340],
                               [-0.574, -0.340,  1.000]]

   HISTORY:
     - Basic ideas borrowed from "Numerical Recipes in C", CURVEFIT.PRO (an
       IDL version by DMS, RSI, of the routine "CURFIT: least squares fit to
       a non-linear function", Bevington, Data Reduction and Error Analysis
       for the Physical Sciences) and ODRPACK ("Software for Weigthed
       Orthogonal Distance Regression" freely available at: www.netlib.org).
     - Added: fitting of a subset of the parameters, Monte-Carlo
       simulations...
 */
{
    local grad;

    /* Maybe subset of parameters to fit. */
    na= numberof(a);
    if (is_void(fit))
        fit= indgen(na);
    else if (dimsof(fit)(1) == 0)
        fit= [fit];
    nfit= numberof(fit);
    if (!nfit)
        error, "no parameters to fit.";
    
    /* Check weights. */
    if (is_void(w)) w= 1.0;
    else if (anyof(w < 0.0))
        error, "bad weights.";
    if (numberof(w) != numberof(y))
        w += array(0.0, dimsof(y));
    nfree= sum(w != 0.0) - nfit;        // Degrees of freedom
    if (nfree <= 0)
        error, "not enough data points.";

    /* Other settings. */
    diag= indgen(1:nfit^2:nfit+1);      // Subscripts of diagonal elements
    if (is_void(lambda)) lambda= 1e-3;
    if (is_void(gain)) gain= 10.0;
    if (is_void(itmax)) itmax= 100;
    if (is_void(eps)) eps= 1e-6;        // sqrt(machine_precision)/100
    if (1.0+eps <= 1.0)
        error, "bad value for EPS.";
    if (is_void(tol)) tol= 1e-7;
    monte_carlo= is_void(monte_carlo) ? 0 : long(monte_carlo);
    warn_zero= 0;
    warn= "*** Warning: LMFIT ";
    neval= 0;
    conv= 0.0;
    niter= 0;
    
    while (1) {
        if (deriv) {
            m= f(x, a, grad, deriv=1);
            neval++;
            grad= nfit == na ? grad(*,) : grad(*,fit);
        } else {
            if (!niter) {
                m= f(x, a);
                neval++;
            }
            inc= eps * abs(a(fit));
            if (numberof((i= where(inc <= 0.0)))) inc(i)= eps;
            grad= array(double, numberof(y), nfit);
            for (i=1; i<=nfit; i++) {
                anew= a;        // Copy current parameters
                anew(fit(i)) += inc(i);
                grad(,i)= (f(x,anew)-m)(*)/inc(i);
            }
            neval += nfit;
        }
        beta= w * (chi2= y-m);
        if (niter) chi2= chi2new;
        else       chi2= chi2_first= sum(beta * chi2);
        beta= grad(+,) * beta(*)(+);
        alpha= ((w(*)(,-) * grad)(+,) * grad(+,));
        gamma= sqrt(alpha(diag));
        if (anyof(gamma <= 0.0)) {
            /* Some derivatives are null (certainly because of rounding
             * errors). */
            if (!warn_zero) {
                write, warn+"founds zero derivatives.";
                warn_zero= 1;
            }
            gamma(where(gamma <= 0.0))= eps * max(gamma);
            /* lines insertd by NJW 2007-02-22 to avoid floating point
               interrupt */
            if( allof(gamma <= 0.0 ) ) {
                write,warn+"all gamma values <= 0";
                goto done;
             }
        }
        gamma= 1.0 / gamma;
        beta *= gamma;
        alpha *= gamma(,-) * gamma(-,);
        
        while (1) {
            alpha(diag)= 1.0 + lambda;
            anew= a;
            anew(fit) += gamma * LUsolve(alpha, beta);
            m= f(x, anew);
            neval++;
            d= y-m;
            chi2new= sum(w*d*d);
            if (chi2new < chi2)
                break;
            lambda *= gain;
            if (allof(anew == a)) {
                /* No change in parameters. */
                write, warn+"makes no progress.";
                goto done;
            }
        }
        a= anew;
        lambda /= gain;
        niter++;
        conv= 2.0*(chi2-chi2new)/(chi2+chi2new);
        if (conv <= tol)
            break;
        if (niter >= itmax) {
            write, format=warn+"reached maximum number of iterations (%d).\n",
                itmax;
            break;
        }
    }
    
done:
    sigma= sqrt(nfree/chi2);
    result= lmfit_result(neval=neval, niter=niter, nfree=nfree, nfit=nfit,
            lambda=lambda, chi2_first=chi2_first, chi2_last=chi2, conv=conv,
            sigma=sigma);
    if (correl || stdev) {
        /* Compute correlation matrice and/or standard deviation vector. */
        alpha(diag)= 1.0;
        alpha= LUsolve(alpha);
        if (anyof((tmp1= alpha(diag)) < 0.0))
            write, format=warn+"%s\n", "found negative variance(s)";
        tmp1= sqrt(abs(tmp1));
        if (stdev) {
            /* Standard deviation is rescaled assuming that statistically
             * chi2 = nfree +/- sqrt(2*nfree). */
            (tmp2= array(double,na))(fit)= gamma * tmp1 / sigma;
            result.stdev= &tmp2;
        }
        if (correl) {
            gamma= 1.0 / tmp1;
            alpha *= gamma(-,) * gamma(,-);
            if (nfit == na) {
                result.correl= &alpha;
            } else {
                (tmp2= array(double, na, na))(fit,fit)= alpha;
                result.correl= &tmp2;
            }
        }
    }
    alpha= beta= gamma= [];     // Free some memory.
    if (monte_carlo >= 1) {
        saa= 0.0*a;
        sig= (w > 0.0) /(sqrt(max(nfree/chi2*w, 0.0)) + (w == 0.0));
        for (i=1; i<=monte_carlo; i++) {
            anew= a;
            ynew= y + sig * random_n(dimsof(y));
            lmfit, f, x, anew, ynew, w, fit=fit, gain=gain, tol=tol,
                deriv=deriv, itmax=itmax, lambda=lambda, eps=eps;
            anew -= a;
            saa += anew * anew;
        }
        result.monte_carlo= monte_carlo;
        result.stdev_monte_carlo= &sqrt(saa / monte_carlo);
    }
    return result;
}

/* Function autoesti */

func autoesti( x, y )
/* DOCUMENT esti = autoesti( x, y )

    Returns estimation of [amplitude, mean, sigma] when the (x,y) values
    represent a peak on a roughly zero background.

    SEE ALSO: gaussfit
*/
{
   // assumes peaked distribution with background approx. zero

   sumy = sum(y);
   if( sumy <= 0.0 ) error,"AUTOESTI: problem with sum(y) being zero or negative";
   meaan = sum(x*y)/sumy;
   return [max(y), meaan, sqrt(sum((x-meaan)^2*y)/sumy)]
}
%FILE% derivs_arr.i
func derivs_arr( x, f, &fd, &fdd )
{
   fd = (f(dif)/x(dif))(pcen);
   fdd = (fd(dif)/x(dif))(pcen);
}
%FILE% determinant.i
/* Function determinant */

func determinant( arr )
/* DOCUMENT res = determinant( arr )

    Returns the determinant of the square matrix 'arr'

    2011-03-02/NJW
*/
{
   dms = dimsof(arr);
   if( dms(1) != 2 ) {
      write,"Must be a 2D array";
      return [];
   }
   if( dms(2) != dms(3) ) {
      write,"Must be a square array";
      return [];
   }
   n = dms(2);
   if( n == 1 ) return arr(1);
   if( n == 2 ) return arr(1,1)*arr(2,2) - arr(1,2)*arr(2,1);
   //+ if( n == 3 ) return arr(1,1)*arr(2,2)*arr(3,3) + arr(1,2)*arr(2,3)*arr(3,1) + arr(1,3)*arr(2,1)*arr(3,2) \
   //+                   - arr(1,1)*arr(2,3)*arr(3,2) - arr(1,2)*arr(2,1)*arr(3,3) - arr(1,3)*arr(2,2)*arr(3,1);
   if( n > 2 ) {
      // resolve according to first row:
      dsum = 0.;
      ssign = 1;
      for( j = 1; j <= n; j++ ) {
         jarr = rem_elem(indgen(n),j);
         darr = arr(2:n,jarr);
         dsum += ssign*arr(1,j)*determinant(darr);
         ssign = -ssign;
      }
      return dsum;
   }
}

%FILE% detmo_package.i
/******************************************
   JEM-X detector modelling to understand
   the electronic efficiency

   The gain value should be an integer value from 10 and upwards
   A value of zero will disable all selections

   2007-04-24/NJW

*******************************************/

#include "idlx.i"
#include "random.i"
#include "plot.i"
#include "jfits.i"
#include "mfits.i"
#include "image.i"
#include "detmo_plot.i"
#include "detmo_specplot.i"

/*
 *  External variables
 */

gap = 0.2;      // keV
fano = 0.6;
e_reduc = 0.99;
n_in = 3000;
n_ephot = 200;
e_min = rdfitscol("detmo_eminmax.fits+1","e_min");
e_max = rdfitscol("detmo_eminmax.fits+1","e_max");
ebds = e_min;
grow, ebds, e_max(0);
n_ebds = numberof(ebds);
ephot_bds = spanl(1.,40.,n_ephot+1);
energ_lo = ephot_bds(1:-1);
energ_hi = ephot_bds(2:0);
ephot_arr = sqrt(energ_lo*energ_hi);

/* Function detmo_main */

func detmo_main( gain, norej= )
/* DOCUMENT detmo_main, gain, norej=

*/
{

   if( is_void(norej) ) norej = 0;

   gain = double(gain);

   strgain = swrite(format="%2.0f",gain);

   filename = norej ? "detmo_eeff_"+strgain+"n.scm" : "detmo_eeff_"+strgain+"r.scm";
   eeffstream = open(filename,"w");
   specname = norej ? "detmo_spec_"+strgain+"n.fits" : "detmo_spec_"+strgain+"r.fits";
   rmfname = norej ? "detmo_rmf_"+strgain+"n.fits" : "detmo_rmf_"+strgain+"r.fits";


   write,eeffstream,format="// date = %s\n", ndate(3);
   write,eeffstream,format="// gain = %5.2f\n", gain;
   write,eeffstream,format="// fano = %5.3f\n// e_reduc = %5.3f\n", \
          fano, e_reduc;

   spec_arr = array(double,n_ebds-1,n_ephot);

   for( ip=1; ip <= n_ephot; ip++ ) {
      ephoton = ephot_arr(ip);
      n_electrons_avg = ephoton / gap;

     /*
      *  The distributions of number of electrons in the drifting cloud
      *  is normal except narrower by the Fano factor than the simple
      *  statistics prescribe
      */
      n_electrons = random_n(n_in)*sqrt(n_electrons_avg)*fano + n_electrons_avg;
      pha = n_electrons * ephoton * gain / n_electrons_avg;
      ltzero = where( pha < 0.0 );
      if( numberof(ltzero) > 0 ) pha(ltzero) = 0.0;

     /*
      *  The electronic signals have a size with a distribution around the
      *  number of electrons that hit the anode
      */
      slow_signal = random_n(n_in)*sqrt(pha)*e_reduc + pha;
      ener_out = slow_signal / gain;
      //+ fast_signal = random_n(n_in)*sqrt(pha)*e_reduc + pha;
      ctot_signal = random_n(n_in)*sqrt(pha)*e_reduc + pha;
      ltzero = where( ctot_signal < 1.e-4 );
      if( numberof(ltzero) > 0 ) ctot_signal(ltzero) = 1.e-4;

     /*
      *  The rejection consists of two terms:
      *      1) The slow signal must be larger that the threshold
      *      2) If the slow signal is above a certain level, then the
      *         ratio between the slow and cathod signal (ctot) must be
      *         found within some limits
      */
      q_slow_ctot = slow_signal / ctot_signal;

      if( norej ) {
         n_out = n_in;
         accept = array(1,n_in);
      } else {
         acc_slow = slow_signal > 40.0;
         wn115 = slow_signal <= 115.0;
         wrat = q_slow_ctot > 0.90 & q_slow_ctot < 1.10;
         //+ ss = wn155 | wrat;
         ss = wn115 + wrat;
         w = where(ss);
         ss(w) = 1;
         accept = acc_slow & ss;

         n_out = sum(accept);
      }

      histo, ener_out(where(accept)), e_spec, escale, bds=ebds;
      spec_arr(,ip) = e_spec;

      write,eeffstream,format="%7.3f  %8.3f %8.5f\n", ephoton, ephoton*gain, \
                double(n_out)/double(n_in);

   }

   close, eeffstream;

   kwds_init;
   kwds_set,"EXTNAME","DETSPEC","Standard spectral file";
   kwds_set,"DATE", ndate(3),"Time of creation";
   kwds_set,"CREATOR","detmo_main.i","Name of program";
   kwds_set,"GAIN",gain,"[PHA/keV] Applied gain value";
   kwds_set,"FANO",fano,"Applied Fano factor";
   kwds_set,"E_REDUC",e_reduc,"Applied e_reduc factor";

   wrmfitscols,specname,"E_MIN",e_min,"E_MAX",e_max,"RATE", \
           spec_arr(,sum), "RATE_ERR", sqrt(spec_arr(,sum)),clobber=1;


   kwds_set,"EXTNAME","SPEC_ARR","Spectral array unchanged";
   kwds_set,"DATE", ndate(3),"Time of creation";

   fh = wrmfitscols(rmfname,"ENERG_LO",energ_lo,"ENERG_HI",energ_hi, \
           "MATRIX", spec_arr, clobber=1,cont=1);

  /*
   *  Renormalize to create proper redistribution matrix
   */

   for( i = 1;i <= n_ephot; i++ ) {
      s = spec_arr(sum,i);
      if( s > 0.0 ) spec_arr(,i) /= s;
   }

   kwds_set,"EXTNAME","SPECRESP","Redistribution matrix";

   wrmfitscols,fh,"ENERG_LO",energ_lo,"ENERG_HI",energ_hi, \
           "MATRIX", spec_arr;



}

/* Function detmo_get_nominal_eeff */

func detmo_get_nominal_eeff(a)
/* DOCUMENT detmo_get_nominal_eeff
 *
 *  An attempt to derive the nominal electronic efficiency
 *  based on rejection criteria bein completely open
 *  for PHA < 115 and confined to +- 10% for PHA > 115
 *  In addition there is a 'hard' threshold for PHA = 40
 *  below which the event is rejected.
 *
 *   Approx. 2007-04-15/NJW
*/
{
   p = spanl(10.,800.,300); // linear PHA values
   z = array(double,300);   // the electronic efficiency to be
   
   for(i=1;i<=300;i++) {
      if( p(i) < 115. ) {
         // All are accepted except when
         // applying the hard cutoff:
         z(i) = p(i) < 40. ? 0.0 : 1.0;
      } else {
         // 'd' is mimicking the slow signal and 'c' the total (ctot) signal
         d = random_n(10000)*sqrt(p(i)) + p(i);
         c = random_n(10000)*sqrt(p(i)) + p(i);
         w = where( c > 1.e-5 ); // avoid dividing by zero
         q = d(w)/c(w);
         z(i) = 1.e-4*numberof(where(q > 0.9 & q < 1.1));
          // 1.e-4 is 1/10000 but shouldn't it rather be 1./numberof(w) ??
          //        Remark inserted 2008-05-19/NJW
      }
   }
   
   hdr = array(string,6);
   hdr(1) = "// date = "+ndate(3);
   hdr(2) = "// Made by detmo_get_nominal_eff.i";
   hdr(3) = "// Nominal EEFF based on threshold at 40";
   hdr(4) = "//   rejection sets in at 115, limits 0.9 < slow/ctot < 1.10";
   hdr(5) = "// colname = pha";
   hdr(6) = "// colname = eeff";
   wstab,"detmo_nominal_eeff.scm",hdr=hdr,p,z;

}

/* Function detmo_derive_eeff */

func detmo_derive_eeff( gain_lo, gain_hi )
/*
   detmo_derive_eeff: Derive the EEFF

   2007-04-25/NJW
*/

{

   strgainlo = swrite(format="%2.0f", double(gain_lo) );
   strgainhi = swrite(format="%2.0f", double(gain_hi) );

   filelo = "detmo_spec_"+strgainlo+".scm";
   elo = rscol(filelo,1,silent=1);
   speclo = rscol(filelo,2,silent=1);
   
   filehi = "detmo_spec_"+strgainhi+".scm";
   ehi = rscol(filehi,1,silent=1);
   spechi = rscol(filehi,2,silent=1);
   
   ener = 25.; // keV
   qarr = [1.0,1.0]; // The array of electronic efficiencies
   pharr = ener*gain_hi*[1.,5.]; // ensures that the upper limit is
      // not a problem. The array is sorted everytime a new EEFF
      // value has been determined.
   
   while( ener > 1.5 ) {
      speclo_e = interp(speclo,elo,ener);
      spechi_e = interp(spechi,ehi,ener);
      phahi = ener * gain_hi;
      phalo = ener * gain_lo;
      q2 = interp( qarr, pharr, phahi );
      q1 = q2 * speclo_e / spechi_e;
      //+ write,format="%8.3f  %8.4f\n", pha1, q1;
      grow, pharr, phalo;
      grow, qarr, q1;
      is = sort(pharr);
      qarr = qarr(is);
      pharr = pharr(is);
      ener *= 0.95;
   }
   window,0;
   plot,pharr,qarr,xr=[0,800],yr=[0,2];
   hdr = array(string,5);
   hdr(1) = "// "+ndate(3);
   hdr(2) = "// origin = detmo_derive_eeff.i";
   hdr(3) = "// gainlo = "+strgainlo;
   hdr(4) = "// gainhi = "+strgainhi;
   hdr(5) = "// startenergy = 25 ; keV";
   wstab,"/r9/njw/yorick/jic_work/detmo_eeff_"+strgainlo+"_"+strgainhi+".scm", \
                pharr,qarr,hdr=hdr;
   write,"/r9/njw/yorick/jic_work/detmo_eeff_"+strgainlo+"_"+strgainhi+".scm has been written";

}

/* Function detmo_plot */

func detmo_plot( gain_value, add= )
{
   require,"scom.i";
   require,"plot.i";

   strgain = swrite(format="%2i", gain_value);
   filename = "detmo_eeff_"+strgain+".scm";
   e = rscol(filename,1,silent=1);
   eff = rscol(filename,3,silent=1);

   window,0;
   if( add ) {
      oplot,e,eff,li=2;
   } else {
      plot,e,eff,xtitle="Energy [keV]",ytitle="Efficiency";
   }
}

/* Function detmo_specplot */

func detmo_specplot( gain_value, add=)
{
   strgain = gain_value == 0 ? "00" : swrite(format="%2i", gain_value);
   filename = "detmo_spec_"+strgain+".scm";
   e_min = rscol(filename,1,silent=1);
   e_max = rscol(filename,2,silent=1);
   spec = rscol(filename,3,silent=1);
   width = e_max - e_min;
   e = sqrt(e_min*e_max);
   specperkev = spec / width;

   window,2;
   if( add ) {
      oplot,e,specperkev,ps=10,li=2;
   } else {
      w = where(specperkev < 100.0);
      if( numberof(w) ) specperkev(w) = 100.0;
      plot,e,specperkev,itype=3,ps=10;
   }
}

/* Function detmo_std_spec_fit */

func detmo_std_spec_fit( filename, gain=, efit1=, efit2= ,syserr= )
/* DOCUMENT detmo_std_spec_fit, filename, gain=, efit1=, efit2= ,syserr= 

   The FITS file: filename must contain an extension
   'DETSPEC' and a keyword GAIN (else the gain must
   be given as a keyword to this function).

   Keywords 'efit1' and 'efit2' [keV] define the energy interval for
   fitting. Default values are 3.0 and 25.0 keV.
   Keyword 'syserr': systematic error. syserr*rate is added
        quadratically to rate_err to give the applied error.
        Default value is zero.

   2007-03-08/NJW
   2007-04-23/NJW, updated with energy interval and syserr

*/
{

   if( !file_test(filename) ) {
      write,format="%s was not found\n", filename;
      return;
   }

   if( is_void(efit1) ) efit1 = 3.0; // keV
   if( is_void(efit2) ) efit2 = 20.0; // keV
   if( is_void(syserr) ) syserr = 0.0;

   rate = rdfitscol( filename+"[DETSPEC]","rate");
   rate_err = rdfitscol( filename+"[DETSPEC]","rate_err");
   rate_err = sqrt(rate_err^2 + (rate*syserr)^2);
   elo = rdfitscol( filename+"[DETSPEC]","e_min" );
   ehi = rdfitscol( filename+"[DETSPEC]","e_max" );
   width = ehi - elo;
   e = 0.5*(elo + ehi);
   i1 = where(abs(elo-efit1) == min(abs(elo-efit1)))(1);
   i2 = where(abs(ehi-efit2) == min(abs(ehi-efit2)))(1);
   nrange = i2-i1+1;
   irange = i1 + indgen(i2-i1+1) - 1;
   hrange = indgen(45);

   // The gain value given as keyword to this function overrides
   // the value in the spetrum file

   if( is_void(gain) ) {
      hdr = headfits(filename+"[DETSPEC]");
      gain = fxpar(hdr,"gain");
      if( is_void(gain) ) {
         write,"No GAIN keyword found, give gain as keyword to function";
         return;
      }
   }

   rmfdol = "detmo_rmf_14n.fits[SPECRESP]";
   energ_lo = rdfitscol(rmfdol,"ENERG_LO");
   energ_hi = rdfitscol(rmfdol,"ENERG_HI");
   rm = rdfitscol(rmfdol,"MATRIX");
   eline = sqrt(energ_lo*energ_hi);

   pha_eeff = rscol("detmo_nominal_eeff.scm",1,silent=1);
   eeff_nom = rscol("detmo_nominal_eeff.scm",2,silent=1);
   //+ eeff = interp( eeff_nom, pha_eeff, e*gain );
   eeff = interp( eeff_nom, pha_eeff, eline*gain );

   first = 1;
   nplus = 0;
   for( alpha = -0.5; alpha <= 1.5; alpha += 0.10 ) {
      src_flux = eline^(-alpha);
      deline = energ_hi - energ_lo;

      //+ s = eeff * (rm(,+)*(src_flux*deline)(+));
      s = (rm(,+)*(src_flux*deline*eeff)(+));

      fac = sum(s(irange)*rate(irange)/rate_err(irange)^2) \
          / sum(s(irange)^2 / rate_err(irange)^2);
      s *= fac;
      red_chi2 = sum(((rate(irange)-s(irange))/rate_err(irange))^2)/(nrange-2);
      write,format="%6.3f  %10.2f\n", alpha, red_chi2;
      if( first ) {
         first = 0;
         red_chi2_min = red_chi2;
         alpha_min = alpha;
         s_min = s;
      } else {
         if( red_chi2 > red_chi2_min ) nplus++;
         if( red_chi2 < red_chi2_min ) {
            red_chi2_min = red_chi2;
            alpha_min = alpha;
            s_min = s;
         }
      }
      if( nplus > 3 ) break;

   }

   write,format="\n%6.3f  %10.2f\n", alpha_min, red_chi2_min;
   ymax = max((rate+rate_err)/width);
   dataplot,e,rate/width, \
           rate_err/width,itype=3,xbar=1, \
           yr=ymax*[1.e-3,1.5], \
           xtitle="Energy [keV]", \
           ytitle="Rate/keV";
   oplot,e,s_min/width, color="red";
   xyouts,0.2,0.82,swrite(format="E range %4.1f - %3.0f keV",elo(i1),ehi(i2)),device=1;
   xyouts,0.2,0.79,swrite(format="Photon index %4.2f",alpha_min),device=1;
   xyouts,0.2,0.76,swrite(format="Chi2(red) %6.2f", red_chi2_min),device=1;
   xyouts,0.2,0.73,swrite(format="Gain %6.2f", gain),device=1;
   xyouts,0.2,0.47,swrite(format="Syst. error %4.1f%%", syserr*100),device=1;
   plotname,"detmo_std_spec_fit";
   plotsign;
}
%FILE% dgxe_package.i

/* Function dgxe_setup */

/*********************************************
     Part of DGXE project
     This initializes for dgxe_ana_swid, dgxe_... etc.

     2008-02-28/NJW

  The Diffuse Galactice X-ray Emission study, DGXE, will take all
  available observations and make the background spectrum by
  subtracting all detected sources.
  The sky is divided into zones of 1 deg interval in galactic latitude
  and no limitation in longitude in order to organize the basic data.

  > dgxe_mk_zone, jemxNum, zone_number

  which calls 'dgxe_prepare_zone' that checks the proposed SWIDs against
  /r6/jemx/pointings/pointings_RRRR.fits and sets up the jmxi_[pm]zz.fits
  zone file. When that is done the OSA running for the chosen SWIDs is
  initiated by 'do_project_a' on the condition that the machine in
  operation is 'gauss'. (The suffix '_a' is required since e.g. the
  parameter 'radiusLimit' should be set to 105).
  When 'dgxe_ana_swid' is called then it is assumed that either
  do_project_a 1 q131  or do_project_a 2 q132 has been run and the
  results are still present under where the environment variable
  J_OSA_RES points.


**********************************************/
#include "common.i"

NEBINS = 9;

// Setup struct for spectral results

struct s_Spec {
   string swid;
   string major_src;
   double ra_scx;
   double dec_scx;
   double glon_scx;
   double glat_scx;
   double exposure;
   double gain;
   double bkg_var;
   double detspec(NEBINS);
   double detspec_err(NEBINS);
   double imaspec(NEBINS);
   double imaspec_err(NEBINS);
   double spespec(NEBINS);
   double spespec_err(NEBINS);
}

struct s_Maps {
   string mode;
   long chans(2);
   long jemxNum;
   double map(360,180);
   long  nmap(360,180);
   double wmap(360,180);
}

write,"Defining external variables Eb1 and Eb2 (PI energy boundaries)";

j_get_pi_ebds, Eb1, Eb2;

write,"Defining rebinning array in external variable Rebin";

Rebin = [30,1,1,1,1,1]; // 35 bins
grow,Rebin,array(2,20); // 75 bins
grow,Rebin,array(3,70); // 285 bins (of which the last ones are not used)

write,format="Defining the %i standard energy bands in keV and PI\n", NEBINS;
write," in arrays Pibnd1, Pibnd2  and Ebnd1, Ebnd2";

Pibnd1 = [45,58, 83,108,129,147,164,179,197];
Pibnd2 = [57,82,107,128,146,163,178,196,223];

Ebnd1  = [3.0, 4.0, 6.0,  8.0, 10.0, 13.0, 16.0, 20.0, 25.0];
Ebnd2  = [4.0, 6.0, 8.0, 10.0, 13.0, 16.0, 20.0, 25.0, 35.0];

// Establish the FOV arrays

file = openb("IJWarr.ysav");
restore, file;
close,file;
write,"FOV arrays IIARR, JJARR, WARR, and IDXARR have been restored.";

/* Function dgxe_ana_swid */

func dgxe_ana_swid( jemxNum, swid, lg=, shw= )
/* DOCUMENT res = dgxe_ana_swid( jemxNum, swid, lg=, shw= )

   Collect the information from the run of 'do_project_a 1 q131' or
   'do_project_a 2 q132' and present
    - lightcurves in the chosen energy bands
    - HK countrates
    - DET, SPE, and IROS spectra

   Returns a struct with elements: bkg_var,
   detspec(NEBINS), detspec_err(NEBINS),   / from level BIN_S
   imaspec(NEBINS), imaspec_err(NEBINS),   / from level IMA
   spespec(NEBINS), spespec_err(NEBINS).   / from level SPE

    Keyword   lg :  If set to 1, output logging file
                    If no set (i.e. value 'void') output to screen
                    If set to 0 (zero) suppress output entirely
             shw :  Causes screen plotting

   2008-02-26/NJW
   2008-02-28/NJW, updated to return a struct s_Spec with results
*/
{

   if( is_void(jemxNum) ) {
      write,"Syntax: res = dgxe_ana_swid( jemxNum, swid, lg=, shw= )";
      return [];
   }
   if( typeof(jemxNum) == "string" ) jemxNum = atoi(jemxNum);

   extern NEBINS, Eb1, Eb2, Ebnd1, Ebnd2;

   if( is_void(Eb1) ) {
      write,"You must first include 'setup.i'";
      return [];
   }

   local ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp;
   local ob1_spe, ob2_spe, orate_spe, orate_err_spe;

   if( is_void(lg) ) lg = 2;
   if( lg==1 ) {
      logname = get_next_filename("ana_swid_log_????.txt");
      flog = open(logname,"w");
      write,flog,format="ANA_SWID log for JMX%i and SWID %s /%s\n", \
                    jemxNum, swid, ndate(3);
   }

   res = s_Spec();

   dEbnd = Ebnd2 - Ebnd1;
   YRANGE1 = 0.02;

   //    2008-02-01/NJW
   // Assume that project q131 has been run for JMX1 and q132 for JEMX2
   // and resulting files distributed into /r9/njw/jemx/analysis7/sky_ima
   // ../srcl_res, and ../evts_shd

   sjmx = swrite(format="jmx%i",jemxNum);
   sJMX = swrite(format="JMX%i",jemxNum);
   proj = jemxNum == 1 ? "q131": "q132";
   if(lg==1)write,flog,format="Project %s\n", proj;

   analysis7_dir = get_env("J_OSA_RES");
   imdir = analysis7_dir+"/sky_ima/";
   shdir = analysis7_dir+"/evts_shd/";
   scdir = analysis7_dir+"/srcl_res/";
   revol = strpart( swid, 1:4 );

   // *******  Check for existence of required files ******

   dspfile = scdir+sjmx+"_full_dsp_"+proj+"_"+swid+".fits";
   imafile = imdir+sjmx+"_sky_ima_"+proj+"_"+swid+".fits";
   sclfile = scdir+sjmx+"_srcl_res_"+proj+"_"+swid+".fits";
   shdfile = shdir+sjmx+"_evts_shd_"+proj+"_"+swid+".fits";
   lcrfile = scdir+sjmx+"_dete_lcr_"+proj+"_"+swid+".fits";
   spefile = scdir+sjmx+"_srcl_spe_"+proj+"_"+swid+".fits";

   flag = 0;
   if( !file_test(dspfile) ) { write,"Error: "+dspfile+" is missing!"; flag += 1; }
   if( !file_test(imafile) ) { write,"Error: "+imafile+" is missing!"; flag += 2; }
   if( !file_test(sclfile) ) { write,"Error: "+sclfile+" is missing!"; flag += 4; }
   if( !file_test(shdfile) ) { write,"Error: "+shdfile+" is missing!"; flag += 8; }
   if( !file_test(lcrfile) ) { write,"Error: "+lcrfile+" is missing!"; flag += 16; }
   if( !file_test(spefile) ) { write,"Warn : "+spefile+" is missing!"; flag += 32; }

   if( flag > 0 && flag != 32 ) {
      if(lg==1) close,flog;
      return [];
   }

// *******************************************************************************

   // *******  Get the detector light curves *********
   //   from the output of level LCR with NEBINS energy intervals


   nextens = nfits_extens( lcrfile );
   if( nextens != NEBINS+1 ) {
      write,format="##3## Wrong number of lightcurves found (%i)\n", nextens-1;
      if(lg==1)close, flog;
      return [];
   }
   varindex = array(double,NEBINS);
   lc_cntr  = array(double,NEBINS);

   if( shw ) window,0,style="boxed.gs";
   cvec = ["green","blue","cyan","magenta","red"];
   ncvec = numberof(cvec);

   if(lg==1)write,flog,format="Light curves are normalized to %i cm2\n", 100;
   if(lg==2)write,format="Light curves are normalized to %i cm2\n", 100;
   for( i = 1; i <= NEBINS; i++ ) {
      time = rdfitscol( lcrfile+"+"+itoa(i+1),"time")(2:0);
      rate = rdfitscol( lcrfile+"+"+itoa(i+1),"rate")(2:0);
      rate_err = rdfitscol( lcrfile+"+"+itoa(i+1),"error" )(2:0);
      avg_rate = avg(rate);
      if(shw) {
         if( i == 1 ) {
            dataplot,(time-time(1))*24.*60.*60.,(rate-avg_rate)/avg_rate + i-1, \
                    rate_err/avg_rate, xtitle="Seconds", \
                    color=cvec((i-1)%ncvec+1),yr=[-1,1+NEBINS],title=sJMX+" "+swid;
            plotcomments,str="From bottom to top:",init=1;
         } else {
            odataplot,(time-time(1))*24.*60.*60.,(rate-avg_rate)/avg_rate + i-1, \
                    rate_err/avg_rate, \
                    color=cvec((i-1)%ncvec+1);
         }
         oplot,(time-time(1))*24.*60.*60.,(rate-avg_rate)/avg_rate+i-1,ps=10,color=cvec((i-1)%ncvec+1);
      }

      // calculate the variability index (reduced chi-square for constant rate)

      w = where( rate_err > 0 );
      if( numberof(w) == 0 ) {
         write,format="Problem with LC #%i - no positive errors\n", i;
         continue;
      }
      lc_cntr(i) = avg(rate(w));
      varindex(i) = sum(((rate(w) - lc_cntr(i))/rate_err(w))^2)/numberof(w);

      if(lg==1)write,flog,format="E#%i LC ctr: %8.3f,  Var. index: %8.2f\n",i, lc_cntr(i), varindex(i);
      if(lg==2)write,format="E#%i LC ctr: %8.3f,  Var. index: %8.2f\n",i, lc_cntr(i), varindex(i);

      pstr = swrite(format="%4.1f - %4.1f keV, Var. index: %8.2f", Ebnd1(i), \
                Ebnd2(i), varindex(i));
      if(shw) plotcomments,str=pstr;
   }
   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";

   res.bkg_var = varindex(max); // NB!!    NB!!  temporary solution
          //    Must be updated with analysis of source light curves



//*******************************************************************************

   // *******  Get the detector spectrum *********
   //      from the output of level BIN_S in 'dspfile'
   //  Values have been normalized to 100 cm2; change back to counts/s


   usedarea = fxpar(headfits(dspfile+"+1",nocheck=1),"usedarea");
   if( !numberof(usedarea)) error,"##11## trouble with usedarea";
   rate = (rdfitscol(dspfile+"+1", "rate" )*usedarea/100.)(,1);
   rate_err = (rdfitscol(dspfile+"+1", "stat_err" )*usedarea/100.)(,1);
   spe_expo = rdfitscol(dspfile+"+1", "exposure" );

   // Rebin from very fine bins to fine bins

   specrebinning, Eb1, Eb2, rate, rate_err, Rebin, \
          ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp;

   for( i = 1; i <= NEBINS; i++ ) {
      res.detspec(i) = sum(rate(Pibnd1(i):Pibnd2(i)));
      res.detspec_err(i) = sqrt(sum(rate_err(Pibnd1(i):Pibnd2(i))^2));
      if(lg==1)write,flog,format="  E#%i DSP ctr: %8.3f +-%7.3f\n", \
                             i, res.detspec(i), res.detspec_err(i);
      if(lg==2)write,format="  E#%i DSP ctr: %8.3f +-%7.3f\n", \
                             i, res.detspec(i), res.detspec_err(i);
   }
   if(lg==1)write,flog,format="Total DSP ctr: %8.3f\n", res.detspec(sum);
   if(lg==2)write,format="Total DSP ctr: %8.3f\n", res.detspec(sum);
   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";


//*******************************************************************************

   // *******  Get the j_ima_iros source fluxes *********
   //   from JMXi-SRCL-RES created by j_ima_iros in level IMA
   //   in 'sclfile'

   hdr = headfits( sclfile+"+1",nocheck=1);
   nsrcs_srcl = fxpar( hdr, "naxis2" );
   jiir_flux = array(double,NEBINS);
   jiir_flux_err = array(double,NEBINS);
   if( nsrcs_srcl ) {
      flux = rdfitscol( sclfile+"+1", "flux" );
      flux_err = rdfitscol( sclfile+"+1", "flux_err" );
      src_names = rdfitscol( sclfile+"+1", "name" );
      // The area information is 'illegally' hidden in the flux
      // array. Use it to undo the normalization
      area = flux(129:0,);
      flux = flux(1:128,)*area/100.;         // counts/s
      flux_err = flux_err(1:128,)*area/100.; // counts/s
      //  Find the source with highest flux in 4 - 6 keV
      w = where( flux(4,max) == flux(4,) );
      res.major_src = src_names(w(1));
      res.imaspec = flux(4:3+NEBINS,sum);
      for( i = 1; i <= NEBINS; i++ ) {
         //  NB calculating cts/keV
         //  The first 3 values come from the standard source search
         //  energy bands and are disregarded here
         jiir_flux(i) = sum(flux(i+3,))/dEbnd(i); // counts/s/keV
         jiir_flux_err(i) = sqrt(sum(flux_err(i+3,)^2))/dEbnd(i);
         res.imaspec_err(i) = sqrt(sum(flux_err(i+3,)^2));
         if(lg==1)write,flog,format="  E#%i jiir ctr: %8.3f", i, res.imaspec(i);
         if(lg==2)write,format="  E#%i jiir ctr: %8.3f", i, res.imaspec(i);
         for( j = 1; j <= nsrcs_srcl; j++ ) {
            if(lg==1)write,flog,format="  %8.3f", flux(i+3,j);
            if(lg==2)write,format="  %8.3f", flux(i+3,j);
         }
         if(lg==1)write,flog,format="%s","\n";
         if(lg==2)write,format="%s","\n";
      }
      if(lg==1)write,flog,format="Total jiir ctr: %8.3f\n", res.imaspec(sum);
      if(lg==2)write,format="Total jiir ctr: %8.3f\n", res.imaspec(sum);
   } else {
      if(lg==1)write,flog,"No sources detected";
      if(lg==2)write,"No sources detected";
   }
   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";


//*******************************************************************************


   // *******  Report IMA estimated background *************

   bkgspecima = res.detspec - res.imaspec;
   bkgspecima_err = sqrt(res.detspec_err^2 + res.imaspec_err^2);

   for( i = 1; i <= NEBINS; i++ ) {
      if(lg==1)write,flog,format="  E#%i IMA bkg: %8.3f +-%7.3f cts/s\n", \
                       i, bkgspecima(i), bkgspecima_err(i);
      if(lg==2)write,format="  E#%i IMA bkg: %8.3f +-%7.3f cts/s\n", \
                       i, bkgspecima(i), bkgspecima_err(i);
   }
   if(lg==1)write,flog,format="Total IMA bkg: %8.3f cts/s\n", \
                      bkgspecima(sum);
   if(lg==2)write,format="Total IMA bkg: %8.3f cts/s\n", \
                      bkgspecima(sum);

   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";


//*******************************************************************************


   // *******  Get the j_src_spectra source fluxes *********
   //       from output of level SPE in 'spefile'

   if( !bit_extract( flag, pwr2=32 ) ) {

      hdr = headfits( spefile+"+1",nocheck=1);
      nsrcs_spe = fxpar( hdr, "naxis2" );
      if( nsrcs_srcl != nsrcs_spe ) error,"##33## ANA_SWID nsrcs mismatch";
      adhoc_factor = 0.24;
      if( nsrcs_spe ) {
         rate = rdfitscol( spefile+"+1", "rate" )*adhoc_factor;
         rate_err = rdfitscol( spefile+"+1", "stat_err" )*adhoc_factor;
         srate = rate(,sum);
         srate_err = array(double,256);
         for(i=1;i<=256;i++) srate_err(i) = sqrt(sum(rate_err(i,)^2));
         for( i = 1; i <= NEBINS; i++ ) {
            res.spespec(i) = sum(rate(Pibnd1(i):Pibnd2(i),));
            res.spespec_err(i) = sqrt(sum(rate_err(Pibnd1(i):Pibnd2(i),)^2));
            if(lg==1)write,flog,format="E#%i SPE ctr: %8.3f", i, res.spespec(i);
            if(lg==2)write,format="E#%i SPE ctr: %8.3f", i, res.spespec(i);
            for( j = 1; j <= nsrcs_spe; j++ ) {
               if(lg==1)write,flog,format="  %8.3f",  sum(rate(Pibnd1(i):Pibnd2(i),j));
               if(lg==2)write,format="  %8.3f",  sum(rate(Pibnd1(i):Pibnd2(i),j));
            }
            if(lg==1)write,flog,format="%s","\n";
            if(lg==2)write,format="%s","\n";
         }

         // Rebin from very fine bins to fine energy bins

         specrebinning, Eb1, Eb2, srate, srate_err, Rebin, \
                ob1_spe, ob2_spe, orate_spe, orate_err_spe;
      }

   }

   // *******  Report SPE estimated background *************

   bkgspecspe = res.detspec - res.spespec;
   bkgspecspe_err = sqrt(res.detspec_err^2 + res.spespec_err^2);

   for( i = 1; i <= NEBINS; i++ ) {
      if(lg==1)write,flog,format="  E#%i SPE bkg: %8.3f +-%7.3f cts/s\n", \
                       i, bkgspecspe(i), bkgspecspe_err(i);
      if(lg==2)write,format="  E#%i SPE bkg: %8.3f +-%7.3f cts/s\n", \
                       i, bkgspecspe(i), bkgspecspe_err(i);
   }
   if(lg==1)write,flog,format="Total SPE bkg: %8.3f cts/s\n", \
                      bkgspecspe(sum);
   if(lg==2)write,format="Total SPE bkg: %8.3f cts/s\n", \
                      bkgspecspe(sum);

   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";


//*******************************************************************************


   // *******  Do the spectral plotting     *********

   if(shw) window, 1,style="boxed.gs";


   tmp = max((orate_dsp+orate_err_dsp)/(ob2_dsp-ob1_dsp)); // BIN_S spectrum
   grow,tmp, max((res.detspec+res.detspec_err)/dEbnd);
   if( nsrcs_spe ) {
      grow,tmp, max((orate_spe+orate_err_spe)/(ob2_spe-ob1_spe));
   }
   if( nsrcs_srcl ) {
      grow,tmp, max(jiir_flux+jiir_flux_err);
   }

   // plot (BIN_S) detector spectrum in fine energy bins

   if(shw) {
      plot_spectrum, ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp, itype=3, \
            xr=[2,40],yr=[YRANGE1,1.3*max(tmp)], title=sJMX+" "+swid;

      // plot (BIN_S) detector spectrum in coarse energy bins
      //  identical to background spectrum if no sources are found

      odataplotf,Ebnd1,0.5*(Ebnd1+Ebnd2),Ebnd2, \
             (res.detspec-res.detspec_err)/dEbnd, res.detspec/dEbnd, \
             (res.detspec+res.detspec_err)/dEbnd;

      // plot SPE background

     odataplotf,Ebnd1,0.5*(Ebnd1+Ebnd2),Ebnd2, \
             (bkgspecspe-bkgspecspe_err)/dEbnd, bkgspecspe/dEbnd, \
             (bkgspecspe+bkgspecspe_err)/dEbnd, color="magenta";

      // plot IMA background

     odataplotf,Ebnd1,0.5*(Ebnd1+Ebnd2),Ebnd2, \
             (bkgspecima-bkgspecima_err)/dEbnd, bkgspecima/dEbnd, \
             (bkgspecima+bkgspecima_err)/dEbnd, color="red";

      if( nsrcs_spe ) {

      // plot SPE spectrum in fine energy bins

         oplot_spectrum, ob1_spe, ob2_spe, orate_spe, orate_err_spe, color="blue";

      // plot SPE spectrum in coarse energy bins

         odataplotf,Ebnd1,0.5*(Ebnd1+Ebnd2),Ebnd2, \
              (res.spespec-res.spespec_err)/dEbnd, \
              res.spespec/dEbnd, \
              (res.spespec+res.spespec_err)/dEbnd, color="blue";

      }

      if( nsrcs_srcl ) {

      // plot IMA spectrum in coarse energy bins

         odataplotf,Ebnd1,0.5*(Ebnd1+Ebnd2),Ebnd2,jiir_flux-jiir_flux_err, \
            jiir_flux, jiir_flux+jiir_flux_err,color="green";
      }

   }



//***********************************************************************************

   // *******  Get the hardware trigger rate etc.  *********
   //   from files in the JEMX archive

   if(shw) {
      jemx_archive = get_env("JEMX_ARCHIVE");
      hkfile = jemx_archive+"/rev_2/scw/"+revol+"/"+swid+".001/"+sjmx+"_hk.fits";
      ghk = gz_proxy_file( hkfile );
      hw_fits = rdfitscol( ghk+"["+sJMX+"-CSSW-HRW]", "hardware__trigger" );
      whi = where( hw_fits > 100000 );
      if( numberof(whi) ) hw_fits(whi) -= 2^31;
      wlo = where( hw_fits < 0 );
      if( numberof(wlo) ) hw_fits(wlo) += 2^31;
      hw_rate = double(hw_fits);
      sw_fits = rdfitscol( ghk+"["+sJMX+"-CSSW-HRW]", "software__trigger" );
      whi = where( sw_fits > 100000 );
      if( numberof(whi) ) sw_fits(whi) -= 2^31;
      wlo = where( sw_fits < 0 );
      if( numberof(wlo) ) sw_fits(wlo) += 2^31;
      sw_rate = double(sw_fits);
      accev_fits = rdfitscol( ghk+"["+sJMX+"-CSSW-HRW]", "accepted__events" );
      whi = where( accev_fits > 100000 );
      if( numberof(whi) ) accev_fits(whi) -= 2^31;
      wlo = where( accev_fits < 0 );
      if( numberof(wlo) ) accev_fits(wlo) += 2^31;
      accev_rate = double(accev_fits);
      x = double(indgen(numberof(hw_rate)))*8.; // 8 s per value

      window,2,style="boxed.gs";

      aae = avg(accev_rate);
      ae_renorm = (accev_rate - aae)/aae;
      ahw = avg(hw_rate);
      hw_renorm = (hw_rate - ahw)/aae;
      asw = avg(sw_rate);
      sw_renorm = (sw_rate - asw)/aae;
      sigma = 12.0;
      plot,x,fold_gaussx(x,hw_renorm,sigma),ps=10,yr=[-2,3],color="red", \
                    title=sJMX+" "+swid, xtitle="Seconds";
      oplot,x,fold_gaussx(x,sw_renorm,sigma),ps=10,color="blue";
      oplot,x,fold_gaussx(x,ae_renorm,sigma),ps=10,color="green";
      plotcomments,str="Red curve: Hardware trigger rate",init=1;
      plotcomments,str="Blue curve: Software trigger rate";
      plotcomments,str="Green curve: Accepted events rate";

   }

   if(lg==1)close, flog;

   return res;

}

/* Function dgxe_clean */

func dgxe_clean( jemxNum )
{
   if( is_void(jemxNum) ) {
      write,"Syntax: dgxe_clean, jemxNum";
      return;
   }

   ntot = 0;
   adir = get_env("J_OSA_RES");
   if( typeof(jemxNum) != "string" ) jemxNum = itoa(jemxNum);
   // sky_ima
   fnam = "jmx"+jemxNum+"_sky_ima_q131*.fits";
   list = file_search( fnam, adir+"/sky_ima" );
   nlist = numberof( list );
   ntot += nlist;
   if( nlist ) {
      write,format="Deleting %i files from 'sky_ima'\n", nlist;
      system,"\\rm "+adir+"/sky_ima/"+fnam;
   }
   // srcl_res
   fnam = "jmx"+jemxNum+"_*_q131*.fits";
   list = file_search( fnam, adir+"/srcl_res" );
   nlist = numberof( list );
   ntot += nlist;
   if( nlist ) {
      write,format="Deleting %i files from 'srcl_res'\n", nlist;
      system,"\\rm "+adir+"/srcl_res/"+fnam;
   }
   // evts_shd
   fnam = "jmx"+jemxNum+"_evts_shd_q131*.fits";
   list = file_search( fnam, adir+"/evts_shd" );
   nlist = numberof( list );
   ntot += nlist;
   if( nlist ) {
      write,format="Deleting %i files from 'evts_shd'\n", nlist;
      system,"\\rm "+adir+"/evts_shd/"+fnam;
   }
   if( ntot == 0 ) {
      write,"Nothing to do, quit ...";
   }
}

/* Function dgxe_fill_zone */

func dgxe_fill_zone( jemxNum, zone_id )
/* DOCUMENT dgxe_fill_zone, jemxNum, zone_id

   Fills the file: jmxi_'zone_id'.fits with results from
   'dgxe_ana_swid'

   2008-03-03/NJW
*/
{

   extern NEBINS;

   if( typeof(jemxNum) != "string" ) jemxNum = swrite(format="%1i",jemxNum);
   if( typeof(zone_id) == "string" ) {
      if( strpart(zone_id,1:1) != "p" && strpart(zone_id,1:1) != "m" ) {
         error,"Bad zone_id: "+zone_id;
      }
   } else {
      zone_id = zone_id > 0 ? swrite(format="p%02i", zone_id) : swrite(format="m%02i", -zone_id);
   }
   zone_file = "jmx"+jemxNum+"_"+zone_id+".fits";
   if( !file_test(zone_file) ) {
      write,format="Cannot find %s ...\n", zone_file;
      return;
   }

   // Get the SWIDs in the zone file and allocate arrays

   dol = zone_file+"+1";
   swids = rdfitscol( dol, "swid" );
   nswids = numberof(swids);
   bkg_var = array(double,nswids);
   detspec = array(double,NEBINS,nswids);
   detspec_err = detspec;
   imaspec     = detspec;
   imaspec_err = detspec;
   spespec     = detspec;
   spespec_err = detspec;
   major_src   = array(string, nswids);

   // Go through the SWIDs and do the analysis
   // and update the arrays

   for( i = 1; i <= nswids; i++ ) {
      res = dgxe_ana_swid( jemxNum, swids(i), lg=0 );
      if( is_void(res) ) continue; // happens when files are missing
      pause,2000;
      bkg_var(i) = res.bkg_var;
      detspec(,i) = res.detspec;
      detspec_err(,i) = res.detspec_err;
      imaspec(,i) = res.imaspec;
      imaspec_err(,i) = res.imaspec_err;
      spespec(,i) = res.spespec;
      spespec_err(,i) = res.spespec_err;
      major_src(i) = strpart(res.major_src,1:20);
   }

   // update the zone file with the results

   fh = headfits( dol );
   col_number = fits_colnum( fh, "bkg_var" );
   fits_bintable_poke, dol, 0, col_number, bkg_var;
   col_number = fits_colnum( fh, "detspec" );
   fits_bintable_poke, dol, 0, col_number, detspec;
   col_number = fits_colnum( fh, "detspec_err" );
   fits_bintable_poke, dol, 0, col_number, detspec_err;
   col_number = fits_colnum( fh, "imaspec" );
   fits_bintable_poke, dol, 0, col_number, imaspec;
   col_number = fits_colnum( fh, "imaspec_err" );
   fits_bintable_poke, dol, 0, col_number, imaspec_err;
   col_number = fits_colnum( fh, "spespec" );
   fits_bintable_poke, dol, 0, col_number, spespec;
   col_number = fits_colnum( fh, "spespec_err" );
   fits_bintable_poke, dol, 0, col_number, spespec_err;
   col_number = fits_colnum( fh, "major_src" );
   fits_bintable_poke, dol, 0, col_number, major_src;

   write,"DGXE_FILL_ZONE done ...";

}

/* Function dgxe_mk_zone */

func dgxe_mk_zone( jemxNum, zone_id )
/* DOCUMENT dgxe_mk_zone, jemxNum, zone_id

   The sky is divided into zones that are belts limited by
   galactic latitude of a 1 deg width.
   'zone_id' is a non-zero integer giving the upper galactic
   latitude limit.
   E.g.  zone_id=10 searches for pointings where 9.0 < lat <= 10.0
   and zone_id=-56   -56.0 <= lat < -55.0
   Hence zone_id 00 is non-existing.
   jmx1_p10.fits will contain observations with   9.0 <  lat <= 10
   jmx1_m56.fits will contain observations with -56.0 <= lat < -55.0

   dgxe_mk_zone identifies the SWIDs that may contribute to a zone,
   - calls dgxe_prepare_zone to make a zone file with room for spectra
   - calls 'do_project_a' to produce the spectra
   - calls dgxe_fill_zone to dump the spectra into the zone file
          and the spectra are obtained via a call of dgxe_ana_swid

   2008-03-03/NJW
*/
{

   gauss = "gauss" == get_env("HOST") ? 1 : 0;

// 'zone_id' must be integer and non-zero, and abs(zone_id) <= 90

   t = typeof(zone_id);
   if( t != "int" && t != "long" ) {
      write,"zone_id must be an integer";
      return;
   }
   if( zone_id == 0 || abs(zone_id) > 90 ) {
      write,"zone_id must not be zero or larger than 90 deg";
      return;
   }

   if( typeof(jemxNum) == "string" ) jemxNum = atoi(jemxNum);
   jstrNum = itoa(jemxNum);

   if( zone_id > 0 ) {
      lat = zone_id - 0.5;
      fnam = "p"+swrite(format="%02i",zone_id);
   } else {
      lat = zone_id + 0.5;
      fnam = "m"+swrite(format="%02i",-zone_id);
   }

   // locate the SWIDs where the pointing is within the chosen zone

   list = find_swid_galac( 0., lat, 180.0, 0.5, rev=[170,579], list=1, nof=1, silent=1 );

   // identify the SWIDs already done and back up the file

   zfname = "/home/njw/jemx/DGXE/jmx"+jstrNum+"_"+fnam+".fits";
   if( file_test(zfname) ) {
      zswids = rdfitscol( zfname+"+1", "swid" );
      // 'zswids' is a list of already done SWIDs
      list = filter_done( zswids, list );
      // now 'list' is the list of SWIDs to be done
      if(numberof(list)) back, zfname;
   }

   n = numberof(list);
   if( n ) {
      newlist = dgxe_prepare_zone( jemxNum, list, fnam, maxnum=5 );
      nnew = numberof(newlist);
      if( nnew ) {
         if( jemxNum == 1 ) {
            write_slist,"/r9/njw/jemx/analysis7/q131/swid.list", newlist;
            write,"Now you can proceed with 'do_project_a 1 q131'";
         } else {
            write_slist,"/r9/njw/jemx/analysis7/q132/swid.list", newlist;
            write,"Now you can proceed with 'do_project_a 2 q132'";
         }
         if( gauss ) {
            curdir = get_cwd();
            cd,"/r9/njw/jemx/analysis7";
            system,"do_project_a "+jstrNum+" q13"+jstrNum;
            cd, curdir;
            dgxe_fill_zone, jemxNum, fnam;
         }
      } else {
         write,"No SWIDs survived, try new zone ...";
      }
   } else {
      write,"No pointings in sky zone ...";
   }

}


/* Function dgxe_prepare_zone */

func dgxe_prepare_zone( jemxNum, swid_list, zone_id, maxnum= )
/* DOCUMENT new_list = dgxe_prepare_zone( jemxNum, swid_list, zone_id, maxnum= )

   Receives a list of SWIDs and gets the basic
   information from the pointings_RRRR.fits file(s) and writes a zone file
   with empty spectra.

   'swid_list' is an array of strings. The zone file will get the name
   "jmx1_'zone_id'.fits" if jemxNum == 1.

   Setting keyword 'maxnum' will start a random selection of SWIDs if their
   number exceeds 'maxnum'. Hence the final number may not be precisely 'maxnum'.

   2008-02-28/NJW
   2008-03-04/NJW Updated with maxnum=
*/
{

   extern NEBINS, Pibnd1, Pibnd2, Ebnd1, Ebnd2;
   if( is_void(NEBINS) ) {
      write,"You forgot to run 'setup.i'";
      return [];
   }

   // Check of arguments

   if( is_void(zone_id) ) {
      write,"Syntax: dgxe_prepare_zone, jemxNum, swid_list, zone_id";
      return [];
   }
   if( typeof(jemxNum) != "string" ) jemxNum = swrite(format="%1i", jemxNum );
   if( typeof(zone_id) == "string" ) {
      if( strpart(zone_id,1:1) != "p" && strpart(zone_id,1:1) != "m" ) {
         error,"Bad zone_id: "+zone_id;
      }
   } else {
      zone_id = zone_id > 0 ? swrite(format="p%02i", zone_id) : swrite(format="m%02i", -zone_id);
   }

   nswids = numberof(swid_list);

   //  Validate the SWIDs i.e. look them up in pointings_RRRR.fits

   swid_list = swid_list(sort(swid_list));
   revols = strpart( swid_list, 1:4 );
   revol_prev = "0000";

   swid = exposure = gain = [];
   for( i = 1; i <= nswids; i++ ) {
      if( revol_prev != revols(i) ) {  // Read the pointing file contents
         fil = get_env("J_POINTINGS")+"/pointings_"+revols(i)+".fits";
         if( !file_test(fil) ) {
            write,format="Warning: %s does not exist\n", fil;
            continue;
         }
         dol = fil+"+1";
         swids_p = rdfitscol( dol, "swid" );
         expos_p = rdfitscol( dol, "exposure_j"+jemxNum );
         gains_p = rdfitscol( dol, "gain_j"+jemxNum );
         shds_p = rdfitscol( dol, "shd_j"+jemxNum );
         revol_prev = revols(i);
      }
      w = where( swids_p == swid_list(i) );
      if( numberof(w) == 0 ) {
         write,format="Warning: %s was not found in %s\n", swid_list(i), dol;
         continue;
      }
      w = w(1);
      flag = 1;
      if( expos_p(w) <= 0.0 ) {
         write,format="%s bad EXPOSURE: %.2f\n", swid_list(i), expos_p(w);
         flag = 0;
      }
      if( gains_p(w) <= 0.0 ) {
         write,format="%s bad GAIN: %.2f\n", swid_list(i), gains_p(w);
         flag = 0;
      }
      if( shds_p(w) != 1 ) {
         write,format="%s no SHD: %i\n", swid_list(i), shds_p(w);
         flag = 0;
      }
      if( !flag ) continue;
      grow, swid, swid_list(i);
      grow, exposure, expos_p(w);
      grow, gain, gains_p(w);

   }
   if( is_void(swid) ) {
      write,"DGXE_REGION: No valid SWIDs were identified ...";
      return []; // if no SWIDs are accepted then return 'void'
   }

   kwds_init;
   kwds_set,"INSTRUME","JMX"+jemxNum,"Instrument used";
   kwds_set,"DATE",ndate(3),"Date and time of file creation";
   for(i=1;i<=NEBINS;i++) {
      kwds_set,"PI_MIN"+itoa(i), Pibnd1(i),"Lower PI value";
      kwds_set,"PI_MAX"+itoa(i), Pibnd2(i),"Upper PI value";
   }
   for(i=1;i<=NEBINS;i++) {
      kwds_set,"E_MIN"+itoa(i), Ebnd1(i),"[keV] Lower energy value";
      kwds_set,"E_MAX"+itoa(i), Ebnd2(i),"[keV] Upper energy value";
   }

   nswids = numberof(swid);
   if( maxnum ) {
      if( nswids > maxnum ) {
         sel = where(random(nswids) < (1.0*maxnum)/nswids);
         swid = swid(sel);
         exposure = exposure(sel);
         gain = gain(sel);
      }
   }
   nswids = numberof(swid);
   bkg_var = array(-1.0, nswids );
   ra_scx = array( 0.0, nswids );
   dec_scx = ra_scx;
   roll_sc = ra_scx;
   glon_scx = ra_scx;
   glat_scx = ra_scx;
   std_src_name = "NONE                ";
   major_src = array( std_src_name, nswids);
   detspec     = array(0.0, NEBINS, nswids );
   detspec_err = detspec;
   imaspec     = detspec;
   imaspec_err = detspec;
   bkgspec     = detspec;
   bkgspec_err = detspec;

   for( i = 1; i <= nswids; i++ ) {
      get_pointing_for_swid, swid(i), ra, dec, roll;
      gal = galactic( ra, dec);
      ra_scx(i) = ra;
      dec_scx(i) = dec;
      glon_scx(i) = gal(1) < 0.0 ? 360. + gal(1) : gal(1);
      glat_scx(i) = gal(2);
      roll_sc(i) = roll;
   }

   wrmfitscols, "jmx"+jemxNum+"_"+zone_id+".fits", \
      "SWID", swid, \
      "MAJOR_SRC", major_src, \
      "RA_SCX", ra_scx, \
      "DEC_SCX", dec_scx, \
      "ROLL_SC", roll_sc, \
      "GLON_SCX", glon_scx, \
      "GLAT_SCX", glat_scx, \
      "EXPOSURE", exposure, \
      "GAIN", gain, \
      "BKG_VAR", bkg_var, \
      "DETSPEC", detspec, \
      "DETSPEC_ERR", detspec_err, \
      "IMASPEC", imaspec, \
      "IMASPEC_ERR", imaspec_err, \
      "SPESPEC", bkgspec, \
      "SPESPEC_ERR", bkgspec_err, \
      clobber=1;

   write,format="Has now written %s with %i rows\n", \
    "jmx"+jemxNum+"_"+zone_id+".fits", nswids;

   return swid;

}

/* Function dgxe_skymap */

#include "conv.i"

func dgxe_skymap( jemxNum, chans=, mode=, select= )
/* DOCUMENT map = dgxe_skymap( jemxNum, chans=, mode=, select= )

   Go through the avalable zone files (jmxi_[pm]xx.fits)
   and extract map information

   chans: Either a scalar or an array
          examples:
            chans=3  : use channel 3
            chans=[7,9] : use sum of channels 7 thru 9
          Default: sum of channels 1 thru 9

   mode : "bi" : Background as det. spec - j_ima_iros src flux
          "bp" : Background as det. spec - j_src_spectra src flux
          "ds" : Detector spectrum
          "ip" : j_ima_iros flux - j_src_spectra src flux
          "ns" : Detector spectrum where no sources are found

   select : A three element array [gal long, gal lat, radius] (in degrees)
            for a selection of pointings

   Returns a struct with three maps: map, nmap, wmap each 360x180

   2008-03-04/NJW
*/
{

   local fh, nrows, a11, a12, a13, a14, a15;

   // The following arrays have been defined with '??' and tell
   // what pixels to include to cover a circle of radius 5 deg
   // on the sky:

   extern IIARR, JJARR, WARR, IDXARR;

   if( is_void(IIARR) ) {
      write,"You must do: > file=openb(\"IJWarr.ysav\");restore,file;close,file; first";
      return [];
   }

   ok = 1;
   if( is_void(mode) ) {
      ok = 0;
   } else {
      if( mode != "bi" && mode != "bp" && mode != "ds" && mode != "ip" \
           && mode != "ns" ) {
         ok = 0;
      }
   }
   if( !ok ) {
      write,"The 'mode' keywords must be given as one of:";
      write,"         'bi', 'bp', 'ds', 'ip', and 'ns'";
      return [];
   }

  /*
   * Make sure that 'jemxNum' is a (long) variable and
   *                'jstrNum' is a string
   */

   if( typeof(jemxNum) == "string" ) {
      jstrNum = jemxNum;
      jemxNum = atoi(jemxNum);
   } else {
      jstrNum = itoa(jemxNum);
   }

   if( is_void(chans) ) {
      chans = indgen(9);
   } else {
      if( numberof(chans) > 1 ) \
        chans = indgen(chans(max)-chans(min)+1)+chans(min)-1;
   }


   dir = "/home/njw/jemx/DGXE";
   maps = s_Maps();
   maps.mode = mode;
   maps.chans(1) = min(chans);
   maps.chans(2) = max(chans);
   maps.jemxNum = jemxNum;

  /*
   *  Locate available zone files
   */

   plist = file_search( "jmx"+jstrNum+"_p??.fits", dir );
   mlist = file_search( "jmx"+jstrNum+"_m??.fits", dir );
   list = plist;
   grow, list, mlist;
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No zone files were found";
      return [];
   }

  /*
   *  Walk through all files and update the map for each point
   *  as well as the surroundings as given by arrays IIARR etc.
   *  according to the 'mode' keyword
   */

   first = 1;
   for( i = 1; i <= nlist; i++ ) {
      ptr = rdfitsbin( list(i)+"+1", fh, nrows );
      //+ write,format="Now %s with %i rows\n", list(i), nrows;
      if( nrows == 0 ) continue;
      if( first ) {
         res = array( s_Spec, nrows );
         index = 0;
         first = 0;
      } else {
         grow, res, array( s_Spec, nrows );
      }
      eq_nocopy, a11, *ptr(11);
      eq_nocopy, a12, *ptr(12);
      eq_nocopy, a13, *ptr(13);
      eq_nocopy, a14, *ptr(14);
      eq_nocopy, a15, *ptr(15);
      eq_nocopy, a16, *ptr(16);
      for( j = 1; j <= nrows; j++ ) {
         res(index+j).detspec = a11(j,);
         res(index+j).detspec_err = a12(j,);
         res(index+j).imaspec = a13(j,);
         res(index+j).imaspec_err = a14(j,);
         res(index+j).spespec = a15(j,);
         res(index+j).spespec_err = a16(j,);
      }
      res(index+1:index+nrows).major_src = *ptr(2);
      res(index+1:index+nrows).glon_scx = *ptr(6);
      res(index+1:index+nrows).glat_scx = *ptr(7);
      res(index+1:index+nrows).bkg_var = *ptr(10);

      index += nrows;

   }

   write,format="\nA total of %i SWIDs\n", index;

   if( numberof(select) == 3 ) { // make a selection on distance from sky position
      r = arcdist(res.glon_scx,res.glat_scx,select(1),select(2));
      w = where( r < select(3) );
      nw = numberof(w);
      if( nw ) {
         write,format="\nThe selection left %i SWIDs\n\n", nw;
         res = res(w);
      } else {
         write,format="\n%s SWIDs left in the selection\n\n","No";
      }
      index = nw;
   }

   if( mode == "ns" ) { // allow only empty fields
     /*
      * w = where( res.imaspec(2) == 0.0 );
      *
      *    this simple form seems not to work
      */
      w = [];
      for(i=1;i<=index;i++){if(res(i).imaspec(2)==0) {grow,w,i;}}

      nw = numberof(w);
      if( nw ) {
         write,format="\nThe request for empty fields left %i SWIDs\n\n", nw;
         res = res(w);
      } else {
         write,format="\n%s SWIDs left in the selection\n\n","No";
      }
      index = nw;
      mode = "ds"; // ascertain that detector spectra fill the map

   }

   if( index == 0 ) return [];

  /*
   * 'index' is now the number of all entries
   */

   for( i = 1; i <= index; i++ ) {

     /*
      *  Find pixel in map for update
      */

      conv,res(i).glon_scx,res(i).glat_scx, ix, iy;

      if( iy > 180 || iy <= 0 ) {
         write,format="Warning: iy = %i - out of range, reset\n", iy;
         iy = iy > 180 ? 180 : 1;
      }
      if( mode == "bi" ) {
         value = sum(res(i).detspec(chans) - res(i).imaspec(chans));
      } else if( mode == "bp" ) {
         value = sum(res(i).detspec(chans) - res(i).spespec(chans));
      } else if( mode == "ds" ) {
         value = sum(res(i).detspec(chans));
      } else {
         value = sum(res(i).imaspec(chans) - res(i).spespec(chans));
      }



      lindx = IDXARR(iy);
      lindx_end = iy == 180 ? IDXARR(0) : IDXARR(iy+1)-1;
      for( k = lindx; k <= lindx_end; k++ ) {
         ii = IIARR(k) + ix - 180;
         if( ii > 360 ) ii -= 360;
         if( ii <=  0 ) ii += 360;
         ii = 361 - ii; // to make image agree with coord.syst.
         jj = JJARR(k);
         maps.map(ii,jj) += value*WARR(k);
         maps.wmap(ii,jj) += WARR(k);
         maps.nmap(ii,jj) = 1;
      }

   }

   w = where(maps.nmap);
   eq_nocopy, up, maps.map;
   eq_nocopy, div, maps.wmap;
   up(w) /= div(w);
   maps.map = up;

   return maps;

}

/* Function dgxe_dump_maps */

func dgxe_dump_maps( maps, nam=, plt=, sclmax= )
/* DOCUMENT dgxe_dump_maps, maps, nam=, plt=, sclmax=

   Direct maps will be in file "'nam'.fits" and projected maps
   will be in file "p'nam'.fits"
   Default of 'nam' is "maps".
   Keyword 'plt' will cause plotting of histogram.
   Keyword 'sclmax' indicates the scaling maximum. If zero
           then scaling is skipped. Deafult is 2.0.

   2008-03-11/NJW
*/
{
   eq_nocopy, a, maps.map;
   eq_nocopy, w, maps.wmap;
   eq_nocopy, n, maps.nmap;
   n = double(n);

   local h, x;

   // The following externals bring the input keywords for
   // 'dgxe_skymap' that has generated the maps to dump.

   if( is_void(sclmax) ) {
      sclmax = 2.0;
   }

   a_orig = a;

   if( sclmax > 0 ) {
      s = where(n);
      binsize = (max(a(s))-min(a(s)))/200;
      histos, a(s), h, x, binsize=binsize;
      hf = fold_gaussx( x, h, binsize );
      mfval = x(where(hf==max(hf(2:0)))(1));
      scal = 1.0/mfval;
      a *= scal;
      s = where(a > sclmax);
      if(numberof(s)) a(s) = sclmax;
      s = where(a < 0.0);
      if(numberof(s)) a(s) = 0.0;
      if( plt ) {
         window,0,style="boxed.gs";
         plot,x,h,ps=10;
         oplot,x,hf,ps=10,color="red";
         oplot,mfval*[1,1],[0,max(h)],li=2;
      }
   }

   // Save the maps

   if( !numberof(nam) ) nam = "maps";
   kwds_init;
   kwds_set,"date",ndate(3),"Date of creation";
   kwds_set,"responsi","Niels J. Westergaard","Responsible";
   kwds_set,"maptype","DIRECTMAP","Map directly from dgxe_skymap";
   kwds_set,"nchans",maps.chans(2)-maps.chans(1)+1,"Number of summed energy channels";
   kwds_set,"chanmin",maps.chans(1),"Lower energy channel";
   kwds_set,"chanmax",maps.chans(2),"Upper energy channel";
   kwds_set,"mode",maps.mode,"Designates the type of map";
   kwds_set,"instrume","JMX"+itoa(maps.jemxNum),"Instrument used";

   kwds_set,"EXTNAME","MAP_SCAL","Scaled map";
   if( sclmax > 0 ) {
      kwds_set,"SCLMAX", sclmax, "Scaling maximum";
   } else {
      kwds_set,"SCLMAX", sclmax, "No scaling done";
   }
   fh = writefits(nam+".fits",a,clobber=1,cont=1);
   kwds_del,"SCLMAX";
   kwds_set,"EXTNAME","MAP_ORIG","Original map";
   fh = writefits( fh, a_orig, cont=1);
   kwds_set,"EXTNAME","WEIGHTS","Map of weights";
   fh = writefits( fh, w, clobber=1, cont=1);
   kwds_set,"EXTNAME","NUMBERS","Map of numbers";
   writefits,fh,n,clobber=1;

   local ix, iy;

   N = 180;
   Nh = N/2;
   pa = array(double,2*N,N);
   pn = array(double,2*N,N);
   pw = array(double,2*N,N);
   delt = 180.0/N;
   substep = 0.2*delt;
   substeph = substep/2;

   for( i = 1; i <= 2*N; i++ ) {
      x1 = (i - N - 1) * delt;
      x2 = (i - N    ) * delt;
      for( j = 1; j <= N; j++ ) {
         y1 = (j - Nh - 1) * delt;
         y2 = (j - Nh    ) * delt;

         nvals = 0;
         valsuma = 0.0;
         valsumn = 0.0;
         valsumw = 0.0;
         for(eps=substeph; eps < delt; eps += substep ) {
            for(eta=substeph; eta < delt; eta += substep ) {
               x = x1 + eps;
               y = y1 + eta;
               coords = rever_aitoff(x,y);
               if( is_void(coords) ) continue;
               conv, coords(1), coords(2), ii, jj;
               nvals++;
               valsuma += a(ii,jj);
               valsumn += n(ii,jj);
               valsumw += w(ii,jj);
            }
         }
         if(nvals) {
            pa(i,j) = valsuma/nvals;
            pw(i,j) = valsumw/nvals;
            pn(i,j) = valsumn/nvals;
         }
      }
   }



   kwds_set,"maptype","PROJECTMAP","Map subjected to Aitoff projection";
   kwds_set,"ctype1","GLON-AIT","Hammer-Aitoff projection";
   kwds_set,"ctype2","GLAT-AIT","Hammer-Aitoff projection";
   kwds_set,"crpix1", 180.5,"reference pixel";
   kwds_set,"crpix2",  90.5,"reference pixel";
   kwds_set,"crval1",   0.0,"reference pixel value";
   kwds_set,"crval2",   0.0,"reference pixel value";
   kwds_set,"cdelt1",  -0.9,"degrees/pixel";
   kwds_set,"cdelt2",   0.9,"degrees/pixel";

   kwds_set,"EXTNAME","PMAP_SCAL","Projected scaled map";
   fh = writefits("p"+nam+".fits",pa,clobber=1,cont=1);
   kwds_set,"EXTNAME","PWEIGHTS","Projected map of weights";
   fh = writefits( fh,pw,cont=1);
   kwds_set,"EXTNAME","PNUMBERS","Projected map of numbers";
   writefits,fh,pn;

   write,"Job is done";

}
%FILE% do_project_status.i
func do_project_status( jemxNum, proj_name, srcl=, shd=, ima=, chat= )
/* DOCUMENT do_project_status, jemxNum, proj_name, srcl=, shd=, ima=, chat=

   Check resulting files against analysis7/proj_name/swid.list

   Keywords 'srcl', 'shd', and 'ima' indicate which result to check.
   Giving a value of 2 will cause an update of the 'swid.list' file
   with the missing SWIDs.

   Returns a list (_lst) with members:
                     srcl   shd    ima
     -------------------------------------------------
     n_miss_...        1      6     11    A number
     miss_...          2      7     12    A (string) array of SWIDs
     n_found_...       3      8     13    A number
     found_...         4      9     14    A (string) array of SWIDs
     found_..._size    5     10     15    A (long) array of file sizes in bytes

   2009-07-03/NJW
*/
{
   jstr = "jmx"+itoa(jemxNum);
   swids = read_slist("/r9/njw/jemx/analysis7/"+proj_name+"/swid.list");
   nswids = numberof(swids);
   if( is_void(chat) ) chat = 0;

   //  ---   Testing SRCL-RES files ---

   if( srcl ) {

      if( chat > 0 ) write,"Testing SRCL-RES";
      n_miss_srcl = 0;
      miss_srcl = [];
      n_found_srcl = 0;
      found_srcl = [];
      found_srcl_size = [];
      basdir = "/jemx/njw/srcl_res/";
      for( i = 1; i <= nswids; i++ ) {
         filename = basdir+jstr+"_srcl_res_"+proj_name+"_"+swids(i)+".fits";
         if( chat > 2 ) write,format="Searching %s",filename;
         if( file_test(filename) ) {
            if( chat > 2 ) write," OK";
            n_found_srcl++;
            grow, found_srcl, swids(i);
            grow, found_srcl_size, filesize(filename);
         } else {
            if( chat > 2 ) write," Missing!";
            n_miss_srcl++;
            grow, miss_srcl, swids(i);
         }
      }
      write,format="Result for %s %s %s:\n",strupcase(jstr),proj_name, "SRCL-RES";
      write,format="          %8i Missing\n", n_miss_srcl;
      write,format="          %8i Found\n", n_found_srcl;
      if( srcl==2 ) {
         if( n_miss_srcl == 0 ) {
            write,"Updating of swid.list has been skipped";
         } else {
            fname = "/r9/njw/jemx/analysis7/"+proj_name+"/swid.list";
            back,fname;
            write_slist,fname,miss_srcl;
            write,"Updating of swid.list has been done";
         }
      }

   }

   //  ---   Testing EVTS-SHD files ---

   if( shd ) {

      if( chat > 0 ) write,"Testing EVTS-SHD";
      n_miss_shd = 0;
      miss_shd = [];
      n_found_shd = 0;
      found_shd = [];
      found_shd_size = [];
      basdir = "/jemx/njw/evts_shd/";
      for( i = 1; i <= nswids; i++ ) {
         filename = basdir+jstr+"_evts_shd_"+proj_name+"_"+swids(i)+".fits";
         if( chat > 2 ) write,format="Searching %s",filename;
         if( file_test(filename) ) {
            if( chat > 2 ) write," OK";
            n_found_shd++;
            grow, found_shd, swids(i);
            grow, found_shd_size, filesize(filename);
         } else {
            if( chat > 2 ) write," Missing!";
            n_miss_shd++;
            grow, miss_shd, swids(i);
         }
      }
      write,format="Result for %s %s %s:\n",strupcase(jstr),proj_name, "EVTS-SHD";
      write,format="          %8i Missing\n", n_miss_shd;
      write,format="          %8i Found\n", n_found_shd;
      if( shd==2 ) {
         if( n_miss_shd == 0 ) {
            write,"Updating of swid.list has been skipped";
         } else {
            fname = "/r9/njw/jemx/analysis7/"+proj_name+"/swid.list";
            back,fname;
            write_slist,fname,miss_shd;
            write,"Updating of swid.list has been done";
         }
      }

   }

   //  ---   Testing SKY.-IMA files ---

   if( ima ) {

      if( chat > 0 ) write,"Testing SKY.-IMA";
      n_miss_ima = 0;
      miss_ima = [];
      n_found_ima = 0;
      found_ima = [];
      found_ima_size = [];
      basdir = "/jemx/njw/sky_ima/";
      for( i = 1; i <= nswids; i++ ) {
         filename = basdir+jstr+"_sky_ima_"+proj_name+"_"+swids(i)+".fits";
         if( chat > 2 ) write,format="Searching %s",filename;
         if( file_test(filename) ) {
            if( chat > 2 ) write," OK";
            n_found_ima++;
            grow, found_ima, swids(i);
            grow, found_ima_size, filesize(filename);
         } else {
            if( chat > 2 ) write," Missing!";
            n_miss_ima++;
            grow, miss_ima, swids(i);
         }
      }
      write,format="Result for %s %s %s:\n",strupcase(jstr),proj_name, "SKY.-IMA";
      write,format="          %8i Missing\n", n_miss_ima;
      write,format="          %8i Found\n", n_found_ima;
      if( ima==2 ) {
         if( n_miss_ima == 0 ) {
            write,"Updating of swid.list has been skipped";
         } else {
            fname = "/r9/njw/jemx/analysis7/"+proj_name+"/swid.list";
            back,fname;
            write_slist,fname,miss_ima;
            write,"Updating of swid.list has been done";
         }
      }

   }

   result = _lst( n_miss_srcl, miss_srcl, n_found_srcl, found_srcl, found_srcl_size, \
                  n_miss_shd, miss_shd, n_found_shd, found_shd, found_shd_size, \
                  n_miss_ima, miss_ima, n_found_ima, found_ima, found_ima_size);

   return result;

}
%FILE% draw_arrow.i
/* Function draw_arrow */

func draw_arrow( x0, y0, x1, y1, sw, hw, hl, color=, thick=, tri=, fill= )
/* DOCUMENT draw_arrow,  x0, y0, x1, y1, sw, hw, hl, color=, thick=, tri=, fill=

   Draws an arrow in the current plot window

            (x0,y0) start point in data coordinates
            (x1,y1) end   point in data coordinates
            sw   width of stem in normalized device coordinates
            hw   width of arrow head in normalized device coordinates
            hl   length of arrow head in normalized device coordinates
   Keywords
        color   standard
        thick   standard
        tri     triangular arrowhead
        fill    for filled arrow

   2002-08-30/NJW, translated to Yorick 2009-11-19
   2012-07-03/NJW, updated
*/
{

   // find the aspect ratio:  ysize / xsize

   port = viewport();
   aspect = (port(4)-port(3))/(port(2)-port(1));

   // get start/end coordinates in normalized device coordinates

   mcoord_conv, x0, y0, x0ndc, y0ndc, from="wor", to="ndc";
   mcoord_conv, x1, y1, x1ndc, y1ndc, from="wor", to="ndc";
   //+ y0ndc = y0ndc * aspect
   //+ y1ndc = y1ndc * aspect

   length = sqrt((x1ndc-x0ndc)^2 + (y1ndc-y0ndc)^2);

   om = atan(x1ndc-x0ndc, y1ndc-y0ndc);
   omega = [[cos(om),-sin(om)],[sin(om),cos(om)]];

   if( tri ) {
      x_arrow_ndc = [-sw/2,sw/2,sw/2,hw/2,0,-hw/2,-sw/2,-sw/2];
      y_arrow_ndc = [0,0,length-hl,length-hl,length,length-hl,length-hl,0];
   } else {
      x_arrow_ndc = [0,0,hw/2,0,-hw/2];
      y_arrow_ndc = [0,length,length-hl,length,length-hl];
   }

   arrow_ndc = array(double,2,numberof(x_arrow_ndc));
   arrow_ndc(1,) = x_arrow_ndc;
   arrow_ndc(2,) = y_arrow_ndc;

   arrow_tilt = omega(,+)*arrow_ndc(+,);
   arrow_tilt(1,) = arrow_tilt(1,) + x0ndc;
   arrow_tilt(2,) = arrow_tilt(2,) + y0ndc;

   mcoord_conv, arrow_tilt(1,),arrow_tilt(2,),arrow_worx, arrow_wory, from="ndc",to="wor";

   oplot,arrow_worx,arrow_wory, color=color, thick=thick;
   if( fill ) poly_fillc, arrow_worx,arrow_wory, color=color;

}
%FILE% ds9reg.i
/* Function ds9reg */

func ds9reg( reg_file, im, coords, &shape, &xcen, &ycen, &params, color=, thick=, nop= )
/* DOCUMENT s = ds9reg( reg_file, im, coords, >shape, >xcen, >ycen, >params, color=, thick=, nop= )
            s = ds9reg( , im, coords, >shape, >xcen, >ycen, >params, color=, thick=, nop= )

     A function to transform a ds9 type region file to an 'aspec' region.

     First version: Returns first region found in the region file.
     Second version: Returns next region from the region file. May be repeated until a 'void' is returned.

     Returns an array with image indices.

     The shape can be "c" for circular (default), "a" for annulus, or "b" for box.
     When "d" is given an annulus with center (xcen,ycen) is defined.

     Returned in 'params':
           circular : [xcen, ycen, radius]
           annulus  : [xcen, ycen, radius1, radius2]
           box      : [x1, y1, x2, y2]
*/
{

   extern DS9REG_lines;

   dms = dimsof(im);

  /*
   *   Interpret the region file
   *     It may contain several regions separated by 'fk5', 'physical', or 'image'
   */

   if( typeof( reg_file ) == "string" ) { // Initialize

      if( !file_test(reg_file) ) error,reg_file+" was not found";

      DS9REG_lines = strlowcase(rdfile(reg_file));
      // remove lines starting with '#'
      is = where(strmatch( strpart(DS9REG_lines,1:1), "#"));
      if(numberof(is)) DS9REG_lines = rem_elem(DS9REG_lines, is);
      // remove empty lines i.e. strlen() == 0
      is = where( strlen( DS9REG_lines) == 0);
      if(numberof(is)) DS9REG_lines = rem_elem(DS9REG_lines, is);

   } else if( is_void(DS9REG_lines) ) return -1;

   reg_lines = DS9REG_lines;
   nreg_lines = numberof(reg_lines);

   // search for 'fk5' (1), 'physical' (2), or 'image' (3)
   // Number in parenthesis is the value of 'coty'
   coty = 0;
   i_fk5 = where(strmatch(reg_lines,"fk5"));
   q_fk5 = numberof(i_fk5);
   i_phys = where(strmatch(reg_lines,"physical"));
   q_phys = numberof(i_phys);
   i_imag = where(strmatch(reg_lines,"image"));
   q_imag = numberof(i_imag);
   lnum = 99999;
   if( q_fk5 ) {
      if( i_fk5(1) < lnum ) {
         lnum = i_fk5(1);
         coty = 1;
      }
   }
   if( q_phys ) {
      if( i_phys(1) < lnum ) {;
         lnum = i_phys(1);
         coty = 2;
      }
   } else if( q_imag ) {
      if( i_imag(1) < lnum ) {
         lnum = i_imag(1);
         coty = 3;
      }
   }
   if( !coty ) error,"No fk5, physical, nor image string found";

   // Now we have the coords type, so search for shape in same
   // or next line
   // 'circle' (1), 'box' (2), or 'annulus' (3)

   shaty = 0;
   mnum = nreg_lines > lnum ? lnum+1 : lnum;
   i_cir = where(strmatch(reg_lines(lnum:mnum),"circle"));
   q_cir = numberof(i_cir);
   i_box = where(strmatch(reg_lines(lnum:mnum),"box"));
   q_box = numberof(i_box);
   i_ann = where(strmatch(reg_lines(lnum:mnum),"annulus"));
   q_ann = numberof(i_ann);
   if( q_cir ) {
      l = i_cir(1);
      shaty = 1;
   } else if( q_box ) {
      l = i_box(1);
      shaty = 2;
   } else if( q_ann ) {
      l = i_ann(1);
      shaty = 3;
   }
   if( !shaty ) error,"No circle, box, nor annulus string found";
   code = ["circle","box","annulus"];

   line = reg_lines(lnum:mnum)(l);
   //+ write,"Found line: "+line;

   // eliminate used lines in region file
   //  in preparation for next call unless last region

   if( lnum+l > numberof(DS9REG_lines ) ) {
      DS9REG_lines = [];
   } else DS9REG_lines = DS9REG_lines(lnum+l:0);

   pnums = parse_reg( line );

   //+ write,"pnums: ", pnums;

   if( coty == 1 ) { // (fk5) Convert celestial coordinates to pixels
      local xcen, ycen;
      skypos_fits, coords, xcen, ycen, pnums(2), pnums(3), to_pix=1;
      if( shaty == 1 ) r = pnums(4) / coords.scale;  // circle
      if( shaty == 2 ) {                             // box
         x1 = xcen - 0.5 * pnums(4) / coords.scale;
         x2 = xcen + 0.5 * pnums(4) / coords.scale;
         y1 = ycen - 0.5 * pnums(5) / coords.scale;
         y2 = ycen + 0.5 * pnums(5) / coords.scale;
      }
      if( shaty == 3 ) {                             // annulus
         r1 = pnums(4) / coords.scale;
         r2 = pnums(5) / coords.scale;
      }
   } else {
      xcen = pnums(2);
      ycen = pnums(3);
      if( shaty == 1 ) r = pnums(4);
      if( shaty == 2 ) {                             // box
         x1 = xcen - 0.5 * pnums(4);
         x2 = xcen + 0.5 * pnums(4);
         y1 = ycen - 0.5 * pnums(5);
         y2 = ycen + 0.5 * pnums(5);
      }
      if( shaty == 3 ) {
         r1 = pnums(4);
         r2 = pnums(5);
      }
   }




   shapes = ["c","b","a"];
   shape = shapes(shaty);
   sh = strpart(shape,1:1);
   if( sh == "c" ) { // circular region
      v = span(0,2*pi,50);
      params = [xcen, ycen, r];
      d = distances(dms(2),dms(3),xcen,ycen);
      w = where(d < r);
      if(!nop)oplot,xcen+r*cos(v),ycen+r*sin(v),color=color,thick=thick;
   } else if( sh == "a" ) { // annular region
      v = span(0,2*pi,50);
      d = distances(dms(2),dms(3),xcen,ycen);

      if(!nop)oplot,xcen+r1*cos(v),ycen+r1*sin(v),color=color,thick=thick;
      params = [xcen, ycen, r1, r2];
      if(!nop)oplot,xcen+r2*cos(v),ycen+r2*sin(v),color=color,thick=thick;
      w = where( d > r1 & d < r2 );
   } else {          // box region
      params = [x1, y1, x2, y2 ];
      xnet = indgen(dms(2))(,-:1:dms(3));
      ynet = indgen(dms(3))(-:1:dms(2),);
      w = where(xnet > x1 & xnet < x2 & ynet > y1 & ynet < y2 );
      if(!nop)oplot,[x1,x2,x2,x1,x1],[y1,y1,y2,y2,y1],color=color,thick=thick;
   }
   return w;
}

func parse_reg( line )
/* DOCUMENT params = parse_reg( line )

     Returns parameters for region as a double array
     with first element as type: 1: circle, 2: box, 3: annulus

     If a unit is present in one of the numbers, '"', ''', 'r' will be
     interpreted as 'arcsec', 'arcmin', 'radian' and will be converted to
     degrees, otherwise ignored.

     circle(245.1234,-76.2,35")
     circle 245.1234 -76.2 35" # ...
*/
{
   params = array(double,5); // at least four parameters are required
   code = ["circle","box","annulus"];
   npar = [3,4,4];
   for( i = 1; i <= 3; i++ ) {
      if( (p = strpos(line,code(i))) ) {
         params(1) = shaty = i;
         len = strlen(code(i));
         pp = strpos( line, "#", p+len );
         last = pp > 0 ? pp-1 : strlen(line);
         sline = strpart( line, p+len:last );
         // replace commas and parentheses with space
         sline = strstrrepl( sline, ",", " " );
         sline = strstrrepl( sline, "(", " " );
         sline = strtrim(strstrrepl( sline, ")", " " ));
         parts = strsplit( sline, " " );
         nparts = numberof(parts);
         if( nparts != npar(i) ) {
            write,"line  : "+line;
            write,"sline : "+sline;
            error,"Wrong number of parts";
         }
         // Check for unit
         for( j = 1; j <= nparts; j++ ) {
            //+ write,"Converting "+parts(j);
            factor = 1.; // for converting to degrees
            if( !is_number(parts(j)) ) { // see if last character is an allowed unit
               u = strpart( parts(j), 0:0 );
               parts(j) = strpart( parts(j), 1:-1 );
               if( !is_number(parts(j)) ) error,parts(j)+" is not a number";
               if( u == "\"" ) factor = 1./3600.;  // arcsec
               if( u == "'" ) factor = 1./60.;     // arcmin
               if( u == "r" ) factor = 180./pi;    // radians
            }
            params(1+j) = atof(parts(j))*factor;
         }
         break;
      }
   }
   return params(1:1+npar(i));
}
 
%FILE% du_analysis.i
func du_analysis( basdir, ndirs, redu=, logdir= )
/* DOCUMENT du_analysis, basdir[, ndirs], redu=, logdir=

   Get overview of disk usage with report in /pool1
   The argument 'ndirs' will limit the number of subdirectories
   reported on. If not given the default is 9999.
   If 'du' report already exists, the 'du' command will not be issued
   but the report reused for the summary.

   Keyword 'redu' will force the command 'du' to be issued.

   Keyword 'logdir' will be the directory for the report log
         Default is /pool1

   2008-07-04/NJW
   2008-07-28/NJW, keyword 'redu' added
   2008-10-31/NJW, keyword 'logdir' added
*/
{

   if(is_void(ndirs)) ndirs = 9999;

   // remember where you started

   curdir = get_cwd();

   //  Define output file name

   fbasdir = fullpath(basdir);
   if( is_void(logdir) ) logdir = get_env("HOME");
   if( logdir == "~" ) logdir = get_env("HOME");
   logdir = fullpath(logdir);
   oname = logdir+"/du_"+strcharrepl( fbasdir, "/", "_" )+".txt";
   local dirname, basename;
   splitfname, oname, dirname, basename;

   if( file_test( oname ) && !redu ) {

      write,format="NB - reusing file: %s\n", oname;
      cd, dirname;

   } else {

      //  Change to directory asked for and run 'du'

      cd, basdir;
      write," Running du ...";
      system,"du -k . | rej2slash > "+oname;

      //  Change to directory with report, i.e. /pool1
      //  since 't2s' (tab-to-space) writes an intermediate file

      cd, dirname;
      //+ system,"t2s "+basename;
      t2s, basename;

   }

   //  Read the result of 'du'. Remember that the last line
   //  is the total usage of the disk volume

   sz = rscol( basename, 1, dble=1, silent=1, nomem=1 );
   nm = rscol( basename, 2, str=1, silent=1, nomem=1 );
   n_nm = numberof(nm);
   totsz = sz(0);
   //+ sz = sz(1:-1);
   //+ nm = nm(1:-1);
   if( n_nm > 1 ) {
      sz(0) = totsz - sum(sz(1:-1));
      is = sort(sz)(0:1:-1);
   } else is = [1];
   nm(0) = "<plain files>";
   nd = min([ndirs,n_nm]);

   // The size list is sorted and the result output
   // both to terminal and to report file

   f = open(oname+".sum","w");

   // Write the preambel to the file

   write,f,format="\nReport on disk usage made %s\n", ndate(3);
   write,f,format="by Yorick program %s (NJW)\n\n", "du_analysis.i";
   write,format="Directory: %s\n", fbasdir;
   write,f,format="Directory: %s\n", fbasdir;
   for(i=1;i<=nd;i++) {
      x = sz(is(i))/1024.^2;
      unit = "GB";
      if( x < 0.1 ) {
         x *= 1024.;
         unit = "MB";
      }
      pcnt = sz(is(i))*100./totsz;
      write,format="%8.2f %s %6.2f%%   %s\n", x, unit, pcnt, nm(is(i));
      write,f,format="%8.2f %s %6.2f%%   %s\n", x, unit, pcnt, nm(is(i));
   }
   if( nd == n_nm ) {
      write,format="   (Full list%s\n", ")";
      write,f,format="   (Full list%s\n", ")";
   } else {
      x = sum(sz(is(nd+1:0)))/1024.^2;
      unit = "GB";
      if( x < 0.1 ) {
         x *= 1024.;
         unit = "MB";
      }
      pcnt = sum(sz(is(nd+1:0)))*100./totsz;
      write,format="%8.2f %s %6.2f%%  from %i smaller contributions\n", x, unit, pcnt, n_nm-nd;
      write,f,format="%8.2f %s %6.2f%%   from %i smaller contributions\n", x, unit, pcnt, n_nm-nd;
   }
   x = totsz/1024.^2;
   unit = "GB";
   if( x < 0.1 ) {
      x *= 1024.;
      unit = "MB";
   }
   write,format="%8.2f %s in total\n", x, unit;
   write,f,format="%8.2f %s in total\n\n", x, unit;

   close, f;
   write,format="\nThe original report file is: %s\n", oname;
   write,format="and you'll find the summary in %s\n\n", oname+".sum";

   cd, curdir;
   write,format="\nBack in directory: %s\n\n", curdir;

}
%FILE% du_win.i
func du_win( basdir, n_max, logdir= )
/* DOCUMENT du_win, basdir[, n_max], logdir=

   Get overview of disk usage in a 'Windows' OS with report in 'logdir'.
   The argument 'n_max' will limit the number of subdirectories
   reported on. If not given the default is 9999.

   Keyword 'logdir' will be the directory for the report log

   2011-03-18/NJW, copied from du_analysis
*/
{

   if(is_void(n_max)) n_max = 9999;

   // remember where you started

   curdir = get_cwd();

   //  Define output file name

   fbasdir = fullpath(basdir);
   if( is_void(logdir) ) logdir = ".";
   oname = logdir+"/du_"+strcharrepl( fbasdir, "/", "_" )+".txt";
   local dirname, basename;
   splitfname, oname, dirname, basename;

   // Find plain files and subdirectories in 'basdir'

   local dirs;
   list_plain = lsdir( basdir, dirs );
   if( structof(list_plain) == long ) error,"No such directory is found";
   nlist_plain = numberof(list_plain);
   ndirs = numberof(dirs);
   sz_dirs = array(0.0, ndirs);

   sz_plain = 0.0;
   for( i = 1; i <= nlist_plain; i++ ) sz_plain += filesize(list_plain(i));
   totsz = sz_plain;

   //  Searching the subdirectories

   for( j = 1; j <= ndirs; j++ ) {

      //  Running find_all_files

      write," Running find_all_files for "+dirs(j)+" ...";
      list = find_all_files( dirs(j), chat=1 );
      nlist = numberof(list);
      write,nlist," files found";

      for( i = 1; i <= nlist; i++ ) {
         sz_dirs(j) += filesize(list(i));
      }
      totsz += sz_dirs(j);
   }

   // The size list is sorted and the result output
   // both to terminal and to report file

   is = sort(sz_dirs)(0:1:-1);

   f = open(oname+".sum","w");

   // Write the preambel to the file

   write,f,format="\nReport on disk usage made %s\n", ndate(3);
   write,f,format="by Yorick program %s (NJW)\n\n", "du_win.i";
   write,format="Directory: %s\n", fbasdir;
   write,f,format="Directory: %s\n", fbasdir;
   n_mn = min(ndirs,n_max);
   for( i = 1; i <= n_mn; i++ ) {
      x = sz_dirs(is(i))/1024.^3;
      unit = "GB";
      if( x < 0.1 ) {
         x *= 1024.;
         unit = "MB";
      }
      pcnt = sz_dirs(is(i))*100./totsz;
      write,format="%8.2f %s %6.2f%%   %s\n", x, unit, pcnt, dirs(is(i));
      write,f,format="%8.2f %s %6.2f%%   %s\n", x, unit, pcnt, dirs(is(i));
   }
   if( ndirs == n_mn ) {
      write,format="   (Full list%s\n", ")";
      write,f,format="   (Full list%s\n", ")";
   } else {
      x = sum(sz_dirs(is(n_mn+1:0)))/1024.^3;
      unit = "GB";
      if( x < 0.1 ) {
         x *= 1024.;
         unit = "MB";
      }
      pcnt = sum(sz_dirs(is(n_mn+1:0)))*100./totsz;
      write,format="%8.2f %s %6.2f%%  from %i smaller contributions\n", x, unit, pcnt, ndirs-n_mn;
      write,f,format="%8.2f %s %6.2f%%   from %i smaller contributions\n", x, unit, pcnt, ndirs-n_mn;
   }
   x = totsz/1024.^3;
   unit = "GB";
   if( x < 0.1 ) {
      x *= 1024.;
      unit = "MB";
   }
   write,format="%8.2f %s in total\n", x, unit;
   write,f,format="%8.2f %s in total\n\n", x, unit;

   close, f;
   write,format="\nThe original report file is: %s\n", oname;
   write,format="and you'll find the summary in %s\n\n", oname+".sum";

}
%FILE% ebm.i
extern ebmdoc;
/* DOCUMENT  ebm package

   Functions:
     ebm_track_grp_members
     ebm_get_child_by_name
*/

/* Function ebm_track_grp_members */

func ebm_track_grp_members( grp_dol, check=, rec=, flog=, chat= )
/* DOCUMENT ebm_track_grp_members, grp_dol, check=, rec=, flog=, chat=

   Keyword check: >= 1  file existence is checked
                  >= 2  extension existence is checked
                  >= 3  reading of data is checked
           rec  :  recursive mode i.e. go through all children
           flog :  name of log file or stream
                    The log file will be closed unless it is a stream
          NB: for recursive mode 'flog' should be a stream opened and
              closed outside this function

           chat:   Integer, 0 - 5, the higher the more extra output

   2008-12-02/NJW
*/
{
   local grp_filename, extno, dirname, basename;
   local mem_filename, mem_extno;
   output_separator = "::::*******************************:::::::::";

   if( is_void(check) ) check = 0;
   if( is_void(chat) ) chat = 0;
   if( is_void(flog) ) {
      lg = 0;
   } else {
      if( typeof(flog) == "string" ) {
         flog = open( flog, "w" );
         keep_open = 0; // close when done
      } else if( typeof(flog) == "text_stream" ) {
         keep_open = 1;
      } else {
         write,"flog keyword of unrecognized kind";
         return;
      }
      lg = 1;
   }

   get_exten_no, grp_dol, grp_filename, extno;
   if( !file_test(grp_filename) ) {
      write,format="File not found: %s\n", grp_filename;
      if(lg){
         write,flog,format="File not found: %s\n", grp_filename;
         if(!keep_open)close, flog;
      }
      return;
   }
   splitfname, grp_filename, dirname, basename;
   dirname = app_slash(dirname);

   write,format="Entering group: %s\n", grp_dol;
   if(lg)write,flog,format="Entering group: %s\n", grp_dol;

   grp_hdr = headfits( grp_dol, nocheck=1 );
   extname = fxpar( grp_hdr, "extname" );
   if( extname != "GROUPING" ) error, "ebm_track_grp_members called for non-group.";
   grp_extver = fxpar( grp_hdr, "extver" );
   if( numberof(grp_extver) == 0 ) {
      write,format="No EXTVER keyword, reset to %i\n", 1;
      if(lg)write,flog,format="No EXTVER keyword, reset to %i\n", 1;
      grp_extver = 1;
   } else {
      write,format="   EXTVER keyword for the group is %i\n", grp_extver;
      if(lg)write,flog,format="   EXTVER keyword for the group is %i\n", grp_extver;
   }

   nrows = fxpar( grp_hdr, "naxis2");
   if( numberof(nrows) == 0 ) {
      write,"NAXIS2 keyword is missing in GROUPING structure";
      if(lg)write,flog,"NAXIS2 keyword is missing in GROUPING structure";
      if( rec ) write,output_separator;
      if( rec && lg ) write,flog,output_separator;
      if( lg && !keep_open ) close, flog;
      return;
   }
   if( nrows == 0 ) {
      write,"No rows in the GROUPING structure";
      if(lg)write,flog,"No rows in the GROUPING structure";
      if( rec ) write,output_separator;
      if( rec && lg ) write,flog,output_separator;
      if( lg && !keep_open ) close, flog;
      return;
   } else {
      write,format=" with %i members\n", nrows;
      if(lg)write,flog,format=" with %i members\n", nrows;
   }

   mem_xtension = strtrim(rdfitscol( grp_dol, "member_xtension" ));
   mem_name     = strtrim(rdfitscol( grp_dol, "member_name" ));
   mem_version  = rdfitscol( grp_dol, "member_version" );
   mem_position = rdfitscol( grp_dol, "member_position" );
   mem_location = strtrim(rdfitscol( grp_dol, "member_location" ));
//+   uri_type = strtrim(rdfitscol( grp_dol, "member_uri_type" ));
   n_members = numberof(mem_xtension);

   if( rec ) write,output_separator;
   if( rec && lg ) write,flog,output_separator;
   for( i = 1; i <= n_members; i++ ) {
      if( strlen(mem_location(i)) == 0 ) {
         //+ mem_location(i) = grp_filename;
         mem_location(i) = basename; // of 'grp_filename'
         in_another_file = 0;
      } else in_another_file = 1;
      write,format="#%i %s (%s) %s[pos%i] extver %i   ", i, mem_name(i), \
         mem_xtension(i), mem_location(i), mem_position(i), mem_version(i);
      if(lg)write,flog,format="#%i %s (%s) %s[pos%i] extver %i   ", i, mem_name(i), \
         mem_xtension(i), mem_location(i), mem_position(i), mem_version(i);
      if( check > 0 ) {
         ftest = file_test(dirname+mem_location(i),gz=1);
         if( ftest ) {
            if( in_another_file ) {
               write,format="%s","f";
               if(lg)write,flog,format="%s","f";
            }
            if( check >= 2 ) { // check for extension existence
               if( ftest == 2 ) { // we have gzipped file
                  proxyfile = gz_proxy_file(dirname+mem_location(i),silent=1);
                  write,format="%s","p";
                  if(lg)write,flog,format="%s","p";
               } else { // its own proxy
                  proxyfile = dirname+mem_location(i);
               }
               mem_dol = swrite(format="%s[%s,%i]", proxyfile, mem_name(i), mem_version(i));
               if( chat > 1 ) {
                  write,format="\nDOL(1) %s mem_position: %i\n", mem_dol, mem_position(i);
                  if(lg)write,flog,format="\nDOL(1) %s mem_position: %i\n", mem_dol, mem_position(i);
               }
               get_exten_no, mem_dol, mem_filename, mem_extno;
               if( mem_extno >= 0 ) {
                  mem_dol = swrite(format="%s[%i]", proxyfile, mem_extno);
                  fh = headfits( mem_dol );
                  extver = fxpar(fh,"extver");
                  if( chat > 1 ) {
                     write,format="DOL(2) %s extver: %i\n", mem_dol, extver;
                     if(lg)write,flog,format="DOL(2) %s extver: %i\n", mem_dol, extver;
                  }
               }
               fh = fits_open( proxyfile, "r" );
               if( !fits_cards_test( fits_goto_hdu(fh,mem_extno+1) ) ) {
                  fits_close, fh;
                  write,format="%s", "!e";
                  if(lg)write,flog,format="%s", "!e";
               } else {
                  fits_close, fh;
                  write,format="%s", "e";
                  if(lg)write,flog,format="%s", "e";
                  if( check >= 3 ) { // Check the data reading
                     if( mem_xtension(i) == "BINTABLE" ) {
                        ptr = rdfitsbin( mem_dol );
                        write,format="%s","r";
                        if(lg)write,flog,format="%s","r";
                     } else if( mem_xtension(i) == "IMAGE" ) {
                        im = readfits( mem_dol );
                        write,format="%s","r";
                        if(lg)write,flog,format="%s","r";
                     } else {
                        write,format="%s", "?r";
                        if(lg)write,flog,format="%s", "?r";
                     }
                  }
               }
            }
         } else {
            write,format="%s","!f";
            if(lg)write,flog,format="%s","!f";
         }
         write,"";
         if(lg)write,flog,"";
      }
      if(!check){
         write,"";
         if(lg)write,flog,"";
      }
      if( rec && mem_name(i) == "GROUPING" ) \
          ebm_track_grp_members, dirname+mem_location(i)+ \
         swrite(format="[GROUPING,%i]",mem_version(i)), \
              check=check,rec=1,flog=flog,chat=chat;
   }
   if( rec ) write,output_separator;
   if( rec && lg ) write,flog,output_separator;
   if( lg && !keep_open ) close, flog;
}

/* Function ebm_get_child_by_name */

func ebm_get_child_by_name( file_extno, child_name, \
                   &report, bygrp=, chat=)
/* DOCUMENT list = ebm_get_child_by_name( file_extno, child_name, \
                   >report, bygrp=, chat=)

    Returns a list of DOLs where the EXTNAME matches the given child_name

    Call:   file_extno   File name with extension number appended,
                           e.g.  myfile.fits[6]
                           Counting starts with 0 (zero) so that
                           the primary HDU has extno 0
            child_name   Name of child (EXTNAME) in grouping table

   Return:  report    a string array with elements:
                           1) grpname
                           2) nchild
                           3) n_missing
                           4) errmsg

   Keywords: bygrp     GRPNAME is used instead of EXTNAME for the search

*/
{

   local file, extno;

   // Set returned value in case of malfunction:

   report = array(string,4);
   outfile_extno_res = [];
   grpname = report(1) = "";
   nchild = -1;
   report(2) = itoa(-1);
   n_missing = 0;
   report(3) = itoa(0);
   errmsg = report(4) = "";

   // debug
   lun = open("output","w");
   write,lun,file_extno;
   write,lun,"## child_name:  ", child_name;

   // Separate filename and extension number

   name_init = strpart(file_extno,1:1)  ==  "/" ? "/" : "";
   get_exten_no, file_extno, file, extno;
   tok = strsplit(file,"/");
   n_tok = numberof(tok);

   // Find out if the file exists

   if( !file_test(file) ) {
      write,file," does not exist";
      errmsg = report(4) = "Input file not found";
      return;
   }

   // Make sure that the input is a grouping table

   hdr = headfits(file_extno);

   extname = fxpar(hdr,"EXTNAME");
   grpname = fxpar(hdr,"GRPNAME");
   if( typeof(grpname) == "string" ) report(1) = grpname;

   if( extname  !=  "GROUPING" ) {
      errmsg = report(4) = "Not a grouping table";
      write,"EBM_GET_CHILD_BY_NAME error: Not a grouping table";
      return;
   }

   mempos = rdfitscol(file_extno, 4, silent=1);
   memloc = rdfitscol(file_extno, 5, silent=1);

   n_children = numberof(mempos);
   nchild = n_children;

   //debug
   write,lun,"n_children = ", n_children;

   if( n_children  ==  0 ) {
      errmsg = report(4) = "No children in grouping table";
      write,"EBM_GET_CHILD_BY_NAME error: No children in grouping table";
      return;
   }


   // Search for the requested child

   nhits = 0;
   for( index = 1; index <= n_children; index++ ) {

      outextno = mempos(index) - 1;

      //debug
      write,lun,"index=",index,"  ",outextno,"  ",memloc(index);

      if( strlen(memloc(index))  ==  0 ) { // in same file
         outfile = file;
      } else { // filename given
         tok(n_tok) = strtrim(memloc(index));
         outfile = name_init+strjoin(tok,"/");
      }
      outfile_extno = outfile+"["+itoa(outextno)+"]";

      //debug
      write,lun,"outfile_extno: ", outfile_extno;

      // Make sure that the requested file exists. If not skip
      // write warning and continue

      //+ list = file_search(outfile, );

      if( file_test(outfile) ) { //   The file does exist!

         // Get the header

         hdr = headfits( outfile+"+"+itoa(outextno) );

         if( bygrp ) {
            compname = fxpar(hdr,"GRPNAME");
            if( typeof(compname) != "string" ) compname = "!!!!!!!";
          } else {
            compname = fxpar(hdr,"EXTNAME");
          }
         //debug
         write,lun,"compname: ", compname;

         if( compname  ==  child_name ) {
            nhits++;
            //debug
            write,lun,"Agree! hit #", nhits;

            errmsg = report(4) = "";
            if( nhits  ==  1 ) {
               outfile_extno_res = outfile_extno;
            } else {
               grow, outfile_extno_res, outfile_extno;
            }
         }

      } else {

         n_missing++;
         if( chat ) {
            write,"Warning: file in group: ", outfile;
            write,"does not exist. Skip and continue ...";
         }

      }

   }

   if( nhits  ==  0 ) {
      errmsg = report(4) = "Child does not exist in group";
      write,"EBM_GET_CHILD_BY_NAME error: Requested child was";
      write,"         not found in grouping table";
   }

   // Report on number of missing elements

   if( n_missing  >  0 ) {
      write,"Warning: "+itoa(n_missing)+" files are missing";
   }

   //debug
   close,lun;

   return;

}
%FILE% encircled_fraction.i
/**************************************************************************
   Find the encircled fraction curve from position arrays in x and y
   2010-10-19/NJW
****************************************************************************/
struct s_Enc {
   double radius;
   double fraction;
}

func encircled_fraction( x, y, weight=, silent= )
/* DOCUMENT res = encircled_fraction( x, y, weight=, silent= )

   Returns a struct with elements
           res.radius   and    res.fraction

   Keywords:  weight      must have same size as x
              silent      suppresses print of center position

   E.g.   HPD = interp(res.radius,res.fraction,0.5)(1)*2;
*/
{
   n = numberof(x);
   if( numberof(y) != n ) error,"Mismatch between x and y";
   if( !is_void(weight) ) if( numberof(weight) != n) error,"Mismatch between x and weight";
   // find the center
   xcen = wavg(x);
   ycen = wavg(y);
   if(!silent)write,format="xcen ycen = %10.4f %10.4f\n", xcen, ycen;
   // from the preliminary center define distances:
   r = sqrt((x-xcen)^2 + (y-ycen)^2);
   is = sort(r);
   r = r(is);
   x = x(is);
   y = y(is);
   if( is_void(weight) ) {
      weight = array(1.,n);
   } else {
      weight = weight(is);
   }
   // avoid outliers in the second determination of the center:
   xcen = wavg(x(1:n/2));
   ycen = wavg(y(1:n/2));
   if(!silent)write,format="xcen ycen = %10.4f %10.4f\n", xcen, ycen;
   res = array(s_Enc,n);
   res.radius = r;
   res.fraction = weight(psum)/weight(sum);

   return res;

}
%FILE% euler.i
extern eulerdoc;
/* DOCUMENT euler package ****************************
 *
 *   Various coordinate transformation tools
 *   between spherical systems; in particular
 *   Equatorial and Galactic.
 * 
 *   2004-11-26/NJW
 *
         aitoff
         crossprod
         equatorial
         euler
         galactic
         jconv_coord
         lonlat
         rever_aitoff
         vector
 *************************************************/

/* Function euler */

func euler( a, b, c )
/* DOCUMENT matrix = euler( a, b, c )

   Returns a matrix that defines the transformation
   through the thre Euler angles a, b, and c expressed
   in radians.

   2004-11-25/NJW

*/

{
   co = cos(a);
   si = sin(a);
   ta = [[co,-si,0],[si,co,0],[0,0,1]];
   co = cos(b);
   si = sin(b);
   tb = [[co,0,-si],[0,1,0],[si,0,co]];
   co = cos(c);
   si = sin(c);
   tc = [[co,-si,0],[si,co,0],[0,0,1]];
   return tc(,+)*(tb(,+)*ta(+,))(+,);
}

/* Function crossprod */

func crossprod( a, b )
/* DOCUMENT c = crossprod( a, b )

   Returns the cross product of 2 3-element arrays
*/

{
   return [a(2)*b(3) - a(3)*b(2),
           a(3)*b(1) - a(1)*b(3),
           a(1)*b(2) - a(2)*b(1)];
}

/* Function equatorial */

func equatorial( gl, gb )
/* DOCUMENT radec = equatorial( gl, gb )

   Get equatorial coordinates from galactic when expressed in degrees
   Value 'n' in radec(n,).
   All Right Ascensions are in radec(,1) and all declinations in radec(,2)

   SEE ALSO: galactic

*/

{
   require, "string.i";

   dr = pi / 180;
   //+ ez = [cos(192.8604*dr)*cos(27.1278*dr), \
   //+       sin(192.8604*dr)*cos(27.1278*dr), \
   //+                        sin(27.1278*dr)];
   //+ ez = [-0.86766645981482, -0.19809110265025,0.45597678621091];
   //+ ex = [cos(266.4051*dr)*cos(-28.9362*dr), \
   //+       sin(266.4051*dr)*cos(-28.9362*dr), \
   //+                        sin(-28.9362*dr)];
   //+ ex = [-0.05487394293840,-0.87343697152730,-0.48383541329218];
   //+ ra_NGP = 192.8604; // old value
   //+ ra_NGP = 192.859508 * dr; // J2000

   ra_NGP = 192.859588 * dr; // J2000
   //+ dec_NGP = 27.128336 * dr; // J2000
   dec_NGP = 27.12825285 * dr; // J2000
   ez = [cos(ra_NGP)*cos(dec_NGP), \
         sin(ra_NGP)*cos(dec_NGP), sin(dec_NGP)];
   //+ ez = [-0.86766645981482, -0.19809110265025,0.45597678621091];
   ra_CGAL = 266.4051 * dr; // J2000
   dec_CGAL = -28.936175 * dr; // J2000
   ex = [cos(ra_CGAL)*cos(dec_CGAL), \
         sin(ra_CGAL)*cos(dec_CGAL), sin(dec_CGAL)];

   ey = crossprod( ez, ex );
   //+ ey = [0.49411047375510,-0.44482900433204,0.74698192509303];
   toeq = [ex, ey, ez];
   c = cos(gb*dr);
   sgal = transpose([cos(gl*dr)*c,sin(gl*dr)*c,sin(gb*dr)]);
   seq = toeq(,+)*sgal(+,);
   //+ seq2 = seq^2;
   //+ norms = sqrt(seq2(sum,));
   //+ seq /= norms(-,); // normalize for numerical round-off
   // normalize to suppress numerical round-off errors
   seq /= sqrt((seq^2)(sum,))(-,);
   alf = atan(seq(2,),seq(1,))/dr;
   if( is_scalar(alf) ) {
      if( alf < 0 ) alf += 360;
   } else {
      w = where( alf < 0 );
      nw = numberof(w);
      if( nw > 0 ) alf(w) += 360;
   }
   dec = asin(seq(3,)) / dr;
   return [alf,dec];
}


/* Function galactic */

func galactic( ra, dec )
/* DOCUMENT glb = galactic( ra, dec )

   Get galactic coordinates from equatorial when expressed in degrees
   Value 'n' in glb(n,).
   All longitudes are in glb(,1) and all latitudes in glb(,2)

   SEE ALSO: equatorial

*/

{
   dr = pi / 180;
   //+ ra_NGP = 192.8604; // old value
   //+ ra_NGP = 192.859508 * dr; // J2000
   ra_NGP = 192.859588 * dr; // J2000
   //+ dec_NGP = 27.128336 * dr; // J2000
   dec_NGP = 27.12825285 * dr; // J2000
   ez = [cos(ra_NGP)*cos(dec_NGP), \
         sin(ra_NGP)*cos(dec_NGP), sin(dec_NGP)];
   //+ ez = [-0.86766645981482, -0.19809110265025,0.45597678621091];
   ra_CGAL = 266.4051 * dr; // J2000
   dec_CGAL = -28.936175 * dr; // J2000
   ex = [cos(ra_CGAL)*cos(dec_CGAL), \
         sin(ra_CGAL)*cos(dec_CGAL), sin(dec_CGAL)];
   //+ ex = [-0.05487394293840,-0.87343697152730,-0.48383541329218];
   ey = crossprod( ez, ex );
   //+ ey = [0.49411047375510,-0.44482900433204,0.74698192509303];
   togal = transpose([ex, ey, ez]);
   c = cos(dec*dr);
   seq = transpose([cos(ra*dr)*c,sin(ra*dr)*c,sin(dec*dr)]);
   sgal = togal(,+)*seq(+,);
   //+ sgal2 = sgal^2;
   //+ norms = sqrt(sgal2(sum,));
   // normalize to suppress numerical round-off errors
   sgal /= sqrt((sgal^2)(sum,))(-,);
   //+ sgal /= norms(-,); // normalize for numerical round-off
   gl = atan(sgal(2,),sgal(1,))/dr;
   gb = asin(sgal(3,)) / dr;
   return [gl,gb];
}

/* Function vector */

func vector( lon, lat, deg= )
/* DOCUMENT unit_vector = vector( lon, lat, deg= )

   Returns a unit vector when longitude and latitude
   (or Right Ascension and Declination)
   are given in radians. Keyword 'deg' changes unit to degrees.

   If only one argument is supplied then it must be an array
   of dimension N x 2 so that lon(,1) are the longitudes and
   lon(,2) are the latitudes.

   SEE ALSO: lonlat

*/

{
   if( is_void( lat ) ) {
      dms = dimsof(lon);
      if( dms(1) != 2 ) error,"Bad dimensionality";
      if( dms(3) != 2 ) error,"Bad dimensionality or 2. dim";
      lat = lon(,2);
      lon = lon(,1);
   }
   dr = deg ? pi / 180 : 1.0;
   c = cos(lat * dr);
   return [cos(lon*dr)*c, sin(lon*dr)*c, sin(lat*dr)];
}

/* Function lonlat */

func lonlat( unit_vec, deg= )
/* DOCUMENT lonlat = lonlat( unit_vec, deg= )

   Returns a two_element array with longitude and latitude
   (or Right Ascension and Declination)
   in radians when unit vector is given. Keyword 'deg'
   changes unit to degrees.

   'unit_vec' can be an array of dimension N x 3; then the
   returned value will be an array of dimension N x 2

   SEE ALSO: vector
*/

{
   dms = dimsof( unit_vec );
   dr = deg ? pi / 180 : 1.0;
   if( dms(1) == 1 ) {
      unit_vec /= sqrt(sum(unit_vec^2));
      res = array(double,2);
      res(2) = asin(unit_vec(3));
      res(1) = atan( unit_vec(2), unit_vec(1) );
   } else if( dms(1) == 2 ) {
      N = dms(2);
      for(i=1;i<=N;i++) {
         unit_vec(i,) /= sqrt(sum(unit_vec(i,)^2));
      }
      res = array(double,N,2);
      res(,2) = asin(unit_vec(,3));
      res(,1) = atan( unit_vec(,2), unit_vec(,1) );
   } else error,"Illegal dimension";

   return res/dr;

}

/* Function aitoff */

func aitoff(l,b)
/* DOCUMENT res = aitoff(l,b)

 NAME:
       AITOFF
 PURPOSE:
       Convert longitude, latitude to X,Y using an AITOFF projection.
 EXPLANATION:
       This procedure can be used to create an all-sky map in Galactic 
       coordinates with an equal-area Aitoff projection.  Output map 
       coordinates are zero longitude centered.

 INPUTS:
       L - longitude - scalar or vector, in degrees
       B - latitude - same number of elements as L, in degrees

 OUTPUTS:
       X - X coordinate, same number of elements as L.   X is normalized to
               be between -180 and 180
       Y - Y coordinate, same number of elements as L.  Y is normalized to
               be between -90 and 90.

 SEE ALSO: rever_aitoff

 NOTES:
       See AIPS memo No. 46, page 4, for details of the algorithm.  This
       version of AITOFF assumes the projection is centered at b=0 degrees.

 REVISION HISTORY:
       Written  W.B. Landsman  STX          December 1989
       Modified for Unix:
               J. Bloch        LANL SST-9      5/16/91 1.1
       Converted to IDL V5.0   W. Landsman   September 1997
       Converted to Yorick     Niels J. Westergaard 2007

*/
{
   degrad = pi / 180.0;
   sa = l;
   n = numberof(sa);
   if( n == 1 ) sa = array(sa,1);
   x180 = where (sa > 180.0);
   if( numberof(x180) > 0) sa(x180) -= 360.;
   alpha2 = degrad * sa/2;
   delta = b * degrad;
   cdec = cos(delta);
   denom = sqrt(1. + cdec*cos(alpha2));
   res = array(0.0,2,n);
   res(1,) = 180. * cdec*sin(alpha2)/denom;
   res(2,) = 90. * sin(delta)/denom;

   return res;
}

/* Function rever_aitoff */

func rever_aitoff(x_in,y_in)
/* DOCUMENT res = rever_aitoff( x, y)


  Reverse Aitoff projection, assume degrees
    -180 <  x  < 180
     -90 <  y  <  90

   ALSO SEE: aitoff

   2004-11-03/NJW

*/

{

   radeg = 180.0 / pi;
   x = x_in;
   n = numberof(x);
   if( n == 1 ) x = array(x,1);
   w = where( x > 180. );
   nw = numberof(w);
   if( nw > 0 ) x(w) -= 360;
   w = where( x < -180. );
   nw = numberof(w);
   if( nw > 0 ) x(w) += 360;
   x = x / 180.0;
   y = y_in / 90.0;
   
   r2 = x^2 + y^2;
   
   if( max(r2) >= 1.0 ) {
      //+ print,"REVER_AITOFF error, x,y outside valid region";
      return [];
   }
   
   d = 2.0 - r2;
   sqd = sqrt(d);
   del = asin(y*sqd);
   alp = asin(x*sqd/cos(del));
   
   res = array(0.0,2,n);
   res(1,) = 2 * alp * radeg;
   res(2,) = del * radeg;
   
   return res;
}

/* Function precess */

func precess( &ra, &dec, equinox1, equinox2, radian= )
/* DOCUMENT
;+
; NAME:
;      PRECESS
; PURPOSE:
;      Precess coordinates from EQUINOX1 to EQUINOX2.
; EXPLANATION:
;      For interactive display, one can use the procedure ASTRO which calls
;      PRECESS or use the /PRINT keyword.   The default (RA,DEC) system is
;      FK5 based on epoch J2000.0 but FK4 based on B1950.0 is available via
;      the /FK4 keyword.
;
;      Use BPRECESS and JPRECESS to convert between FK4 and FK5 systems
; CALLING SEQUENCE:
;      PRECESS, ra, dec, [ equinox1, equinox2, /PRINT, /FK4, /RADIAN ]
;
; INPUT - OUTPUT:
;      RA - Input right ascension (scalar or vector) in DEGREES, unless the
;              /RADIAN keyword is set
;      DEC - Input declination in DEGREES (scalar or vector), unless the
;              /RADIAN keyword is set
;
;      The input RA and DEC are modified by PRECESS to give the
;      values after precession.
;
; OPTIONAL INPUTS:
;      EQUINOX1 - Original equinox of coordinates, numeric scalar.  If
;               omitted, PRECESS will query for EQUINOX1 and EQUINOX2.
;      EQUINOX2 - Equinox of precessed coordinates.
;
; OPTIONAL INPUT KEYWORDS:
;      /PRINT - If this keyword is set and non-zero, ) the precessed
;               coordinates are displayed at the terminal.    Cannot be used
;               with the /RADIAN keyword
;      /FK4   - If this keyword is set and non-zero, the FK4 (B1950.0) system
;               will be used otherwise FK5 (J2000.0) will be used instead.
;      /RADIAN - If this keyword is set and non-zero, ) the input and
;               output RA and DEC vectors are in radians rather than degrees
;
; RESTRICTIONS:
;       Accuracy of precession decreases for( declination values near 90
;       degrees.  PRECESS should not be used more than 2.5 centuries from
;       2000 on the FK5 system (1950.0 on the FK4 system).
;
; EXAMPLES:
;       (1) The Pole Star has J2000.0 coordinates (2h, 31m, 46.3s,
;               89d 15" 50.6"); compute its coordinates at J1985.0
;
;       IDL> precess, ten(2,31,46.3)*15, ten(89,15,50.6), 2000, 1985, /PRINT
;
;               ====> 2h 16m 22.73s, 89d 11" 47.3"
;
;       (2) Precess the B1950 coordinates of Eps Ind (RA = 21h 59m,33.053s,
;       DEC = (-56d, 59", 33.053") to equinox B1975.
;
;       IDL> ra = ten(21, 59, 33.053)*15
;       IDL> dec = ten(-56, 59, 33.053)
;       IDL> precess, ra, dec ,1950, 1975, /fk4
;
; PROCEDURE:
;       Algorithm from Computational Spherical Astronomy by Taff (1983),
;       p. 24. (FK4). FK5 constants from "Astronomical Almanac Explanatory
;       Supplement 1992, page 104 Table 3.211.1.
;
; PROCEDURE CALLED:
;       Function PREMAT - computes precession matrix
;
; REVISION HISTORY
;       Written, Wayne Landsman, STI Corporation  August 1986
;       Correct negative output RA values   February 1989
;       Added /PRINT keyword      W. Landsman   November, 1991
;       Provided FK5 (J2000.0)  I. Freedman   January 1994
;       Precession Matrix computation now in PREMAT   W. Landsman June 1994
;       Added /RADIAN keyword                         W. Landsman June 1997
;       Converted to IDL V5.0   W. Landsman   September 1997
;       Correct negative output RA values when /RADIAN used    March 1999
;-
*/
{

   deg_to_rad = pi/180.0;

   npts = numberof(ra);
   if( npts == 0 ) error,"PRECESS error, bad argument";

   if( radian ) {
      ra_rad= double(ra);
      dec_rad = double(dec);
   } else {
      ra_rad = ra*deg_to_rad;     // Convert to radians
      dec_rad = dec*deg_to_rad;
   }

   a = cos( dec_rad );

   if( npts == 1 ) {

      x = [a*cos(ra_rad), a*sin(ra_rad), sin(dec_rad)]; //input direction

   } else {

      x = array(double,npts,3);
      x(,1) = a*cos(ra_rad);
      x(,2) = a*sin(ra_rad);
      x(,3) = sin(dec_rad);
      x = transpose(x);

   }


   sec_to_rad = deg_to_rad/3600.0;

// Use PREMAT function to get precession matrix from Equinox1 to Equinox2

   r = premat(equinox1, equinox2);

   x2 = r(,+)*x(+,);      // rotate to get output direction cosines

   if( npts == 1 ) {                 // Scalar

      ra_rad = atan(x2(2),x2(1));
      dec_rad = asin(x2(3));

   } else {                // Vector

      ra_rad = atan(x2(2,),x2(1,));
      dec_rad = asin(x2(3,));

   }

   ra_rad = zero2pi(ra_rad);
   if( radian ) {
      ra = ra_rad;
      dec = dec_rad;
   } else {
      ra = ra_rad/deg_to_rad;
      dec = dec_rad/deg_to_rad;
   }

}

/* Function premat */

func premat( equinox1, equinox2 )
/* DOCUMENT
;+
; NAME:
;       PREMAT
; PURPOSE:
;       Return the precession matrix needed to go from EQUINOX1 to EQUINOX2.
; EXPLANTION:
;       This matrix is used by the procedures PRECESS and BARYVEL to precess
;       astronomical coordinates
;
; CALLING SEQUENCE:
;       matrix = PREMAT( equinox1, equinox2 )
;
; INPUTS:
;       EQUINOX1 - Original equinox of coordinates, numeric scalar.
;       EQUINOX2 - Equinox of precessed coordinates.
;
; OUTPUT:
;      matrix - double precision 3 x 3 precession matrix, used to precess
;               equatorial rectangular coordinates
;
; OPTIONAL INPUT KEYWORDS:
    FK4 option has been removed in this version; works with FK5 (NJW/2009-08-07)

;       /FK4   - If this keyword is set, the FK4 (B1950.0) system precession
;               angles are used to compute the precession matrix.   The
;               default is to use FK5 (J2000.0) precession angles
;
; EXAMPLES:
;       Return the precession matrix from 1950.0 to 1975.0 in the FK4 system
;
;       IDL> matrix = PREMAT( 1950.0, 1975.0, /FK4)
;
; PROCEDURE:
;       FK4 constants from "Computational Spherical Astronomy" by Taff (1983),
;       p. 24. (FK4). FK5 constants from "Astronomical Almanac Explanatory
;       Supplement 1992, page 104 Table 3.211.1.
;
; REVISION HISTORY
;       Written, Wayne Landsman, HSTX Corporation, June 1994
;       Converted to IDL V5.0   W. Landsman   September 1997
;-
*/
{

   deg_to_rad = pi/180.0;
   sec_to_rad = deg_to_rad/3600.0;

   t = 0.001*( equinox2 - equinox1);

   st = 0.001*( equinox1 - 2000.);

//  Compute 3 rotation angles
   a = sec_to_rad * t * (23062.181 + st*(139.656 +0.0139*st) \
            + t*(30.188 - 0.344*st+17.998*t));

   b = sec_to_rad * t * t * (79.280 + 0.410*st + 0.205*t) + a;

   c = sec_to_rad * t * (20043.109 - st*(85.33 + 0.217*st) \
              + t*(-42.665 - 0.217*st -41.833*t));


   sina = sin(a);  sinb = sin(b) ; sinc = sin(c);
   cosa = cos(a);  cosb = cos(b) ; cosc = cos(c);

   r = array(double,3,3);
   r(,1) = [ cosa*cosb*cosc-sina*sinb, sina*cosb+cosa*sinb*cosc,  cosa*sinc];
   r(,2) = [-cosa*sinb-sina*cosb*cosc, cosa*cosb-sina*sinb*cosc, -sina*sinc];
   r(,3) = [-cosb*sinc, -sinb*sinc, cosc];

   return r;
}

/* Function jconv_coord */

func jconv_coord( ra_scx, dec_scx, posang, &ra_src, \
                  &dec_src, &cosy_src, &cosz_src, \
                  to_eq=, to_sc=, chat= )
/* DOCUMENT omega = jconv_coord( ra_scx, dec_scx, posang, >ra_src,
                         >dec_src, >cosy_src, >cosz_src,
                         to_eq=, to_sc=, chat= )

 Procedure to perform coordinate transformations between equatorial
 coordinates and _SPACECRAFT_ coordinates.

 Returns the applied transformation matrix.

 Pointing information ra_scx, dec_scx, and posang must be given
 Keyword  to_eq  will return ra_src and dec_src when cosy_src and cosz_src
                                                  are given
 Keyword  to_sc  will return cosy_src and cosz_src when
                                ra_src and dec_src are given

   000726/NJW (IDL version)
   2009-01-28/NJW translated to Yorick from IDL

 At input: all angles are given in degrees
           cosy_src and cosz_src have no unit

*/
{

   // Check presence and number of keywords

   control = 0;
   if( to_eq ) {
      control = 1;
   }
   if( to_sc ) {
      control++;
      to_eq = 0;
   }
   if( control  !=  1 ) {
      error,"JCONV_COORD error, zero or two \"to_\" keywords";
   }


   dr = pi / 180; // degrees to radians

   ra_scx_rad = ra_scx * dr;
   dec_scx_rad = dec_scx * dr;
   posang_rad = posang * dr;

   if( ! to_eq ) {
      if( !is_void(ra_src) && !is_void(dec_src) ) {
         ra_src_rad = ra_src * dr;
         dec_src_rad = dec_src * dr;
      }
   }

   // Pointing direction: x-axis

   // RA && Dec of two other axes: y and z

   ra_scy_rad = ra_scx_rad - atan(-cos(posang_rad), -sin(dec_scx_rad)*sin(posang_rad));
   if( ra_scy_rad  <  0. ) ra_scy_rad = ra_scy_rad + 2*pi;

   dec_scy_rad = asin(cos(dec_scx_rad)*sin(posang_rad));

   ra_scz_rad = ra_scx_rad - atan(sin(posang_rad), -sin(dec_scx_rad)*cos(posang_rad));
   if( ra_scz_rad  <  0. ) ra_scz_rad = ra_scz_rad + 2*pi;
   dec_scz_rad = -asin(-cos(dec_scx_rad)*cos(posang_rad));

   if( chat ) {
      write,format="RA,DEC of SC Y-axis: %7.3 %7.3\n", ra_scy_rad/dr, dec_scy_rad/dr;
      write,format="RA,DEC of SC Z-axis: %7.3 %7.3\n", ra_scz_rad/dr, dec_scz_rad/dr;
   }

   // Pointing in EQ system

   x_eq = [cos(ra_scx_rad)*cos(dec_scx_rad), \
           sin(ra_scx_rad)*cos(dec_scx_rad), \
           sin(dec_scx_rad)];

   // SC Y-axis direction in EQ system

   y_eq = [-sin(ra_scx_rad)*cos(posang_rad) \
                 - sin(dec_scx_rad)*cos(ra_scx_rad)*sin(posang_rad),\
            cos(ra_scx_rad)*cos(posang_rad) \
                 - sin(dec_scx_rad)*sin(ra_scx_rad)*sin(posang_rad),\
            cos(dec_scx_rad)*sin(posang_rad)];

   // SC Z-axis direction in EQ system

   z_eq = [sin(ra_scx_rad)*sin(posang_rad) \
                 - sin(dec_scx_rad)*cos(ra_scx_rad)*cos(posang_rad),\
           -cos(ra_scx_rad)*sin(posang_rad) \
                 - sin(dec_scx_rad)*sin(ra_scx_rad)*cos(posang_rad),\
            cos(dec_scx_rad)*cos(posang_rad)];



   if( to_eq ) {

      // Define transformation matrix

      omega = array(double,3,3);
      omega(*,1) = x_eq;
      omega(*,2) = y_eq;
      omega(*,3) = z_eq;

      if( !is_void(cosy_src) && !is_void(cosz_src) ) {
         s_sc = array(double,3);
         s_sc(2) =   cosy_src;
         s_sc(3) =   cosz_src;
         s_sc(1) = sqrt(1. - s_sc(2)^2 - s_sc(3)^2);

         s_eq = omega(,+) * s_sc(+);

         dec_src_rad = asin(s_eq(3));
         ra_src_rad = zero2pi(atan(s_eq(2),s_eq(1)));

         dec_src = dec_src_rad / dr;
         ra_src = ra_src_rad / dr;
      }

      return omega;

   } else {

      // Define transformation matrix

      omega = array(double,3,3);
      omega(1,*) = x_eq;
      omega(2,*) = y_eq;
      omega(3,*) = z_eq;

      if( !is_void(ra_src) && !is_void(dec_src) ) {
         s_eq = array(double,3);
         s_eq(1) = cos(ra_src_rad) * cos(dec_src_rad);
         s_eq(2) = sin(ra_src_rad) * cos(dec_src_rad);
         s_eq(3) = sin(dec_src_rad);

         s_sc = omega(,+) * s_eq(+);

         cosy_src =  s_sc(2);
         cosz_src =  s_sc(3);
      }

      return omega;

   }

}

%FILE% expodecayfit.i
func expodecayfit( t, y, dy, pl=, ini= )
/* DOCUMENT p = expodecayfit( t, y, dy, pl=, ini= )

    Fits  p(1) * exp( -p(2) * t ) to y
    using weight 1/dy^2
    (defined in function edf_modelf)

    Keyword 'pl' for plotting
            'ini' for initial parameters 'p'
*/
{

   // initial guess
   if( is_void(ini) ) {
      p = [10., 1.];
   } else {
      p = ini;
   }

   res = lmfit( edf_modelf, t, p, y, 1./dy^2 );
   write,format="Chi2 red = %12.6f\n", res.chi2_last/res.nfree;
   write,format="Constant: %10.4f\n", p(1);
   write,format="   Decay: %10.4f\n", p(2);
   if( pl ) {
      dataplot, t, y, dy, xbar=1;
      oplot,t,edf_modelf( t, p ),color="red";
   }
   return p;

}
func edf_modelf( t, p )
{
   return p(1) * exp( -p(2) * t );
}
%FILE% faketext.i
/* laver ikke alt for umulige ord
 * sikrer vokaler, skyer konsonant sammenstillinger
 */
func faketext( nwords )
{
   multiplicity = \
    [ 643, 165, 322, 288, 1057, 310, \
      162, 292, 691, 11, 66, 390, \
      319, 597, 582, 226, 21, 563, \
      521, 801, 236, 69, 93, 70, \
      127, 38];

   lclet = array(char(97),multiplicity(1));
   for( i = 2; i <= 26; i++ ) {
      grow, lclet, array(char(96+i),multiplicity(i));
   }
   nlclet = numberof(lclet);

   full_stop = 46;
   comma = 44;
   space = 32;
   len_shortw = 2;
   len_longw  = 10;

   len_avg_sentence = 15;
   len_avg_word = 5;

   nsentences = nwords/len_avg_sentence + 1;

   // distribute words in sentences

   nwords_per_sentence = long(poisson(array(len_avg_sentence,nsentences)));
   differ = nwords - nwords_per_sentence(sum);

   if( differ > 0 ) { // too few words, add until match
      for(i=1;i<=differ;i++) {
         idx = (i-1)%nsentences + 1;
         nwords_per_sentence(idx)++;
      }
   } else if( differ < 0 ) { // too many words, subtract until match
      differ = -differ;
      n = 1;
      i = 0;
      while( n <= differ ) {
         i++;
         idx = (i-1)%nsentences + 1;
         if( nwords_per_sentence(idx) > 7 ) {
            nwords_per_sentence(idx)--;
            n++;
         }
      }
   }

   text = array( string, nsentences );

   // Loop over sentences

   for( isen = 1; isen <= nsentences; isen++ ) {

      // Compose words

      ctext = [];
      for( iwor = 1; iwor <= nwords_per_sentence(isen); iwor++ ) {
         do {
            len_word = long(poisson(len_avg_word));
         } while( len_word < len_shortw || len_word > len_longw );
         idx_letters = long(random(len_word)*nlclet + 1)
         cword = lclet(idx_letters); // array of characters
         if( iwor == 1 ) cword(1) -= 32; // make upper case
         grow, ctext, cword;
         if( iwor < nwords_per_sentence(isen) ) {
            grow, ctext, space; // add a space
         }
      }
      grow, ctext, full_stop; // add a full stop
      grow, ctext, 0; // terminate the string
      text(isen) = string(&ctext);
   }

   return text;
}
%FILE% fconvol.i
/***************************************
   Library for FFT convolution

   fconvol
   fkernel
   gfconvol

   2007-02-06/NJW
****************************************/


/* Function fkernel */

func fkernel( kernel, dim1, dim2)
/* DOCUMENT fk = fkernel( kernel, dim1, dim2 )

   Returns the FFT transform of the kernel in dimensions
   dim1 and dim2 that must be the same as the array to
   convolve with the kernel

   2005-03-30/NJW
*/

{
   require, "idlx.i";

   dmsof = dimsof(kernel);
   m1 = (dmsof(2)-1)/2;
   m2 = (dmsof(3)-1)/2;
   ks = array(double,dim1,dim2);
   n1 = (dim1 + 1)/2;
   n2 = (dim2 + 1)/2;
   ks(n1-m1:n1+m1, n2-m2:n2+m2) = kernel;
   ks = shift(ks,-n1,-n2);
   return fft(ks,1);
}

/* Function fconvol */

func fconvol( arr, fkern )
/* DOCUMENT res = fconvol( arr, fkern )

   Returns the convolution of double array 'arr' and
   the kernel represented by its Fourier transform 'fkern'
   as returned from function 'fkernel'
*/

{
   dmsof = dimsof(arr);
   dmsk = dimsof(fkern);
   if( dmsof(2) != dmsk(2) || dmsof(3) != dmsk(3) ) {
      print,"fconvol: mismatching array dimensions";
      return [];
   }
   norm = (1.0*dmsof(2))*dmsof(3);
   farr = fft(arr,1);
   p = fft(farr*fkern,-1);
   return p.re / norm;
}

/* Function gfconvol */

func gfconvol( image, sigma, widen= )
/* DOCUMENT folded_image = gfconvol( image, sigma, widen= )

   returns image folded with Gauss kernel with sigma 'sigma'
   in unit of pixels.

   Keyword 'widen' will enlarge image with this amount
                   before convolution to avoid spilling
                   overflow

   2007-02-06/NJW
   2009-11-04/NJW added keyword 'widen' and functionality
*/
{
   require, "image.i";

   wimage = image;
   dms = dimsof(wimage);
   nx = dms(2);
   ny = dms(3);
   if( dms(2)%2 == 0 ) {
      // repeat last row to make dimension odd
      we = array(structof(image),dms(2)+1,dms(3));
      we(1:dms(2),) = wimage;
      we(0,) = wimage(0,);
      wimage = we;
   }
   dms = dimsof(wimage);
   if( dms(3)%2 == 0 ) {
      // repeat last column to make dimension odd
      we = array(structof(image),dms(2),dms(3)+1);
      we(,1:dms(3)) = wimage;
      we(,0) = wimage(,0);
      wimage = we;
   }
   if( widen ) wimage = widen_image( wimage, widen );

   kdim = int(5.*sigma)*2 + 1;
   ker = gkernel(kdim,kdim,sigma);

   dms = dimsof(wimage);
   fker = fkernel( ker, dms(2), dms(3) );
   res = fconvol( wimage, fker );
   if( widen ) res = res(widen+1:-widen,widen+1:-widen);
   return res(1:nx,1:ny);

}
%FILE% femte.i
nmax = -(2^31+1);
imax = long((nmax/2)^0.2);

for( i = 1; i <= imax; i++ ) {
for( j = 1; j <= i; j++ ) {
   s = i^5 + j^5;
   rod = s^0.20;
   for( k = 1; k <= rod; k++ ) {
      rest = s - k^5;
      rrod = rest^0.20;
      irrod = long(rrod+0.5);
      if( abs(rrod-irrod) < 1.e-8 ) {
         if( k != i && k != j ) {
            write,i,j,k,irrod;
         }
      }
   }
}}
%FILE% fff.i
      nperc = 0;
      pos = 0;
      first = 1;
      prevpos = 1;
      while( (pos = strpos( fmt, "%", pos+1 ) ) ) {
         if( !first ) {
            if( prevpos == 1 ) {
               finfmt = strpart( fmt, prevpos:pos-1 );
            } else {
               grow, finfmt, strpart( fmt, prevpos:pos-1 );
            }
            prevpos = pos;
         } else {
            first = 0;
         }
         nperc++;
      }
      grow, finfmt, strpart( fmt, prevpos:999 );
%FILE% fflatfield.i
/* Function fflatfield */

func fflatfield( im, freq, &ffim, sel= )
/* DOCUMENT new_im = fflatfield( im, freq[, >ffim], sel= )

   The image 'im' is Fourier transformed and
   frequencies above 'freq' are removed.
   'freq' is an integer or a two-element vector of
   integers where each is smaller than half of the
   corresponding dimension.
   The flattened image is then subtracted from the
   original image.
   Keyword 'sel' must be an array of same dimension
   as 'im' with 1 where pixels are useful and zero
   elsewhere.

   2010-09-20/NJW

*/
{
   dms = dimsof(im);
   o1 = dms(2)%2;
   o2 = dms(3)%2;
   if( dms(1) != 2 ) {
      write,"Not a 2D image";
      return [];
   }
   dosel = 0;
   if( !is_void(sel) ) {
      d = dimsof(sel);
      if( d(1) != 2 ) {
         write,"'sel' is not a 2D image";
         return [];
      }
      if( d(2) != dms(2) || d(3) != dms(3) ) {
         write,"'sel' is not commensurate with 'im'";
         return [];
      }
      dosel = 1;
   }
   wsel = dosel ? where( sel ) : indgen(dms(2)*dms(3));
   //   Avoid changing the input image
   freq1 = numberof(freq) > 1 ? freq(1) : freq;
   freq2 = numberof(freq) > 1 ? freq(2) : freq;
   im1 = im;
   fim = fft(im,-1);
   /*
    *   The higher frequencies are removed symmetrically
    *   so that the backwards transformation has zero
    *   imaginary part except for rounding-off errors.
    */
   i1 = 1 + freq1;
   i2 = dms(2) + 1 - freq1;
   j1 = 1 + freq2;
   j2 = dms(3) + 1 - freq2;
   fim(i1:i2,j1:j2) = 0.0;
   ffim = fft(fim,1).re/numberof(im);
   
   //    Subtraction
   diff  = im - ffim;
   //    Substitute image parts that exceed 3sigma
   //    to avoid subtracting too much around sources
   //+ rms_1 = wrms( diff(wsel) );
   //+ q = where( abs(diff) > 3*rms_1 );
   //+ if( numberof(q) > 0 ) {
   //+    im1(q) = gim(q);
   //+    gim = gfconvol( im1, sigma );
   //+    diff = im - gim;
   //+ }

   return diff;
}


%FILE% fhat.i
extern fhatdoc;
/* DOCUMENT *****************************
 *
 *   A system of functions that can approximate a
 *   given function provided the scale size
 *   (_FHAT_SCALE) is of the same size as the scale
 *  of the function variations.
 *
 *   Functions:
 *
 *    fhat            - fhat(x) returns the value of the fhat single
 *    fhats           - fhats(x,coefs)
 *    fhat_info       - fhat_info   prints to the terminal
 *    fhat_adapt      - define required externals for an interval
 *    fhat_fit        - fit a set of coefficients to a function
 *    set_fhat_num    - set external _FHAT_NUM
 *    set_fhat_scale  - set external _FHAT_SCALE
 *    set_fhat_max    - set external _FHAT_MAX
 *    set_fhat_min    - set external _FHAT_MIN
 *    fhat_oplot      - overplot individual contributions
 */
func fhat(x)
/* DOCUMENT res = fhat(x)
*/
{
   if( is_scalar(x) ) {
      if( abs(x) >= _FHAT_SCALE ) {
         return 0.0;
      } else {
         return 0.5*(1.0 + cos(pi*x/_FHAT_SCALE));
      }
   } else {
      res = double(x);
      w = where( abs(x) >= _FHAT_SCALE );
      m = where( abs(x) <  _FHAT_SCALE );
      if( numberof(w) ) res(w) = 0.0;
      if( numberof(m) ) res(m) = 0.5*(1.0 + cos(pi*x(m)/_FHAT_SCALE));
      return res;
   }
}
func set_fhat_num( nhat )
/* DOCUMENT set_fhat_num, nhat
*/
{
   extern _FHAT_SCALE, _FHAT_NUM;

   if( nhat < 2 ) error,"nhat must be larger than 1";

   _FHAT_NUM = long(nhat);
   if( !is_void(_FHAT_MIN) && !is_void(_FHAT_MAX) ) {
      _FHAT_SCALE = (_FHAT_MAX - _FHAT_MIN)/(_FHAT_NUM-1);
   }
}
func set_fhat_scale( scale )
/* DOCUMENT set_fhat_scale, scale
*/
{
   extern _FHAT_SCALE;

   _FHAT_SCALE = double(scale);
}
func set_fhat_max( value )
/* DOCUMENT set_fhat_max, value
*/
{
   extern _FHAT_MAX;

   _FHAT_MAX = double(value);
}
func set_fhat_min( value )
/* DOCUMENT set_fhat_min, value
*/
{
   extern _FHAT_MIN;

   _FHAT_MIN = double(value);
}
func fhats( x, coefs )
/* DOCUMENT res = fhats(x,coefs)
*/
{
   n = numberof(coefs);
   y = coefs(1)*fhat(x-_FHAT_MIN);
   for(i=2;i<=n;i++) y += coefs(i)*fhat(x-_FHAT_MIN-(i-1)*_FHAT_SCALE);
   return y;
}
func fhat_info
/* DOCUMENT fhat_info
*/
{
   write,format="Scale value : %12.6f\n", _FHAT_SCALE;
   write,format="  Min value : %12.6f\n", _FHAT_MIN;
   write,format="  Max value : %12.6f\n", _FHAT_MAX;
   write,format="  Num value : %5i\n", _FHAT_NUM;
}
func fhat_adapt( x, nhat)
/* DOCUMENT fhat_adapt, x, nhat
*/
{
   extern _FHAT_MIN, _FHAT_MAX, _FHAT_SCALE, _FHAT_NUM;

   if( nhat < 2 ) error,"nhat cannot be less than 2";

   _FHAT_MIN = double(min(x));
   _FHAT_MAX = double(max(x));
   _FHAT_SCALE = (_FHAT_MAX - _FHAT_MIN)/(nhat-1);
   _FHAT_NUM = nhat;
}
func fhat_fit( x, y, nhat )
/* DOCUMENT coefs = fhat_fit( x, y[, nhat] )

   The argument 'nhat' will, if present, define externals
   for the range defined by 'x'.
*/
{
   if( !is_void(nhat) ) fhat_adapt, x, nhat;
   coefs = array(double, _FHAT_NUM);
   // make initial guess
   coefs(1) = y(1);
   for(i = 2; i <= _FHAT_NUM; i++ ) {
      xh = _FHAT_MIN + (i-1)*_FHAT_SCALE;
      w = where(abs(x-xh) == min(abs(x-xh)))(1);
      coefs(i) = y(w);
   }
   result = lmfit(fhats, x, coefs, y );
   write,format="%i iterations by lmfit\n", result.niter;

   return coefs;
}
func fhat_oplot( x, coefs, color=, li= )
/* DOCUMENT fhat_oplot, x, coefs, color=, li=
*/
{
   n = numberof(coefs);
   for( i = 1; i <= n; i++ ) {
      c = array(double,n);
      c(i) = coefs(i);
      oplot,x,fhats(x,c),color=color,li=li;
   }
}
%FILE% filt.i
plot,[0],[0],xr=[0,1],yr=[0,1];
a = distances(20,20,0,10);
pli,a,0.1,0.1,0.8,0.8;
// prepare for polygon plotting
z = [10];
y = [0.5,0.8,0.7,0.4];
x = [0.2,0.6,0.9,0.3];
n = [4];
plfp,z,y,x,n;
plfp,[],y,x,n;

%FILE% find_iden_files.i
/* Function find_iden_files */

#include "md5.i"

func find_iden_files( list=, file=, rec= )
/* DOCUMENT find_iden_files, list=, file=, rec=

   Identifies identical files. Returns a list of names where
   number 1 and 2 are identical etc. Returns void if no such
   identical files are found.

   Keywords:
      list   -   a string array with directory names
      file   -   the name of a text files with directory names
      rec    -   recursive search for files

   Only one of the keywords "list|file" can be used at a time.

   2012-01-20/NJW

*/
{
   local subdirs;

   if( numberof(list) && numberof(file) ) error,"Only a single keyword is accepted";

   if( numberof(file) ) {
      dirnames = rdfile( file );
   } else {
      dirnames = list;
   }

   filelist = [];
   ndirnames = numberof(dirnames);

   search_func = rec ? file_rsearch : file_search;
   for( i = 1; i <= ndirnames; i++ ) grow, filelist, search_func( "*", dirnames(i));
   nfilelist = numberof(filelist);

   write," Now we have all "+itoa(nfilelist)+" files, get their md5sums ...";
   md5arr = array(string, nfilelist);
   for(i = 1; i <= nfilelist; i++ ) md5arr(i) = md5sum(filelist(i),hex=1);
   write," Now we have all md5sums, combine and sort ...";

   is = sort(md5arr);
   md5arr = md5arr(is);
   filelist = filelist(is);

   write," Start searching ...";

   idenlist = [];
   curpos = 1;
   while( curpos < nfilelist ) {
      if( curpos%20 == 0 ) write,format="Done %i of %i ...\n", curpos, nfilelist;
      cur_md5 = md5arr(curpos);
      testpos = curpos + 1;
      first = 1;
      while( testpos <= nfilelist ) {
         test_md5 = md5arr(testpos);
         if( test_md5 != cur_md5 ) break;
         // same md5, could be an identity
         cur_file = filelist(curpos);
         test_file = filelist(testpos);
         if( 0 == cmp(cur_file,test_file) ) {
            // # Heureka, found a coincidence
            grow, idenlist, cur_file; // must be copied every time to keep the sync
                        // between odd and even indices.
            grow, idenlist, test_file;
            if(first)write,format="(%s)   cur_file : %s\n", cur_md5, cur_file;
            write,format="(%s)  test_file : %s\n", test_md5, test_file;
            first = 0;
         }
         testpos++;
      }
      curpos = testpos;
   }

   return idenlist;
}
%FILE% find_swid_radec_ttime.i
/* Function find_swid_radec_ttime */

func find_swid_radec_ttime( ra0, dec0, rad1, .., offax=, rev=, tstart=, \
                      tstop=, list=, nof=, silent=, lst=, gal= )
/* DOCUMENT list = find_swid_radec( ra0, dec0, rad1[, rad2][, offax=]
                       [,rev=][, tstart=][, tstop=][, list=]
                       [,nof=][, silent=][, lst=][, gal=] )

   Find the INTEGRAL SWIDs where the pointing is less than 'rad1'
   away from (ra0,dec0) or - if 'rad2' is greater than rad1 - greater than 'rad1'
   and less than 'rad2' away

   This version writes the total elapsed time with the soure in the FOV i.e.
   not corrected for vignetting.

    Ca. 2003-05/NJW
    2006-10-02/NJW  translated to Yorick language
    2007-11-16/NJW  updated with 'gal' keyword

     If rad2 (in degrees) is not given or less than rad1 then the
     pointings with distance < rad1 (in degrees) will be presented
     else the pointings with distance rad1 < dist < rad2
     will be presented

   Keywords:
             offax:  When set the result will be sorted
                     by increasing off-axis angle
             rev:    Either scalar integer or 2 element integer
                     array with min and max revolution number
             tstart: Time in IJD for start of interval
             tstop:  Time in IJD for end of interval
             list :  Makes returned list a list of SWIDs (default)
             lst  :  Makes returned list a list of SWIDs in jemx.lst format
                         (overrides setting of 'list')
             nof  :  Flag to avoid file writing
             gal  :  Flag to interpret input coordinates as galactic
*/
{

   local swid, ra, dec, posangle, ut, ijd, telapse, mode1, mode2;

   if( is_void(rad1) ) {
      write,"Syntax: list = find_swid_radec(ra,dec,rad1[,rad2], keywords... )";
      return [];
   }
   //
   //  Initialize
   //
   if( is_void(silent) ) silent = 0;
   first = 1;
   tbegin = is_void( tstart ) ? 0.0 : tstart;
   // if( tstart ) { tbegin = tstart; } else { tbegin = 0.0; }
   tend = is_void( tstop ) ? 1.0e9 : tstop;
   // if( tstop ) { tend = tstop; } else { tend = 1.0e9; }
   ra0 = double(ra0);
   dec0 = double(dec0);
   rad1 = double(rad1);
   if( gal ) {
      lon0 = ra0;
      lat0 = dec0;
      radec0 = equatorial( ra0, dec0 );
      ra0 = radec0(1);
      dec0 = radec0(2);
   } else {
      galac0 = galactic( ra0, dec0 );
      lon0 = galac0(1);
      lat0 = galac0(2);
   }

   rad2 = 0.0;
   if( more_args() ) {
      rad2 = double(next_arg());
   }
   //
   // Get list of pointing files
   //
   base = get_env("J_POINTINGS");

   if( numberof(rev) ) {
      if( typeof(rev) == "string" ) {
         revarr = str2arr( rev );
      } else {
         if( numberof( rev ) == 2 ) {
            revarr = indgen(long(rev(2)-rev(1))+1) + long(rev(1)) - 1;
         } else {
            revarr = long(rev)
         }
      }
      nrev = numberof(revarr);
      for( i = 1; i <= nrev; i++ ) {
         revstr = swrite(revarr(i),format="%4.4i");
         tmp = base+"/pointings_"+revstr+"p.dat";
         if( !silent ) write,tmp;
         ybase = base+"/ysav"+swrite(revarr(i)/100,format="%02i/");
         ytmp = ybase+"pointings_"+revstr+"p.ysav";
         if( !silent ) write,ytmp;
         if( i == 1 ) {
            pf_list = tmp;
            ypf_list = ytmp;
         } else {
            grow,pf_list,tmp;
            grow,ypf_list,ytmp;
         }
      }
   } else {
      pf_list = file_search("pointings_*p.dat", base);
      ypf_list = pf_list;
      npf_list = numberof(pf_list);
      for( i = 1; i <= npf_list; i++ ) {
         pos = strpos( pf_list(i),"_" );
         revstra = strpart(pf_list(i), pos+1:pos+4 );
         drevstra = strpart(pf_list(i),pos+1:pos+2);
         ybase = base+"/ysav"+drevstra;
         ytmp = ybase+"/pointings_"+revstra+"p.ysav";
         ypf_list(i) = ytmp;
      }
   }
   npf_list = numberof(pf_list);
   if( npf_list == 0 ) {
      if(!silent) write,"find_swid_radec error: no pointing files of required kind found";
      return [];
   }

   if( !nof ) {

      // Open output file

      outfilename = get_next_filename("find_swid_radec_???.dat");
      fout = open(outfilename,"w");
      n = write(fout,format="%s\n","// Results from find_swid_radec");
      n = write(fout,format="// created %s\n", ndate(3));
      n = write(fout,format="// ra0  = %7.3f; deg\n", ra0);
      n = write(fout,format="// dec0 = %7.3f; deg\n", dec0);
      n = write(fout,format="// lon0 = %7.3f; deg\n", lon0);
      n = write(fout,format="// lat0 = %7.3f; deg\n", lat0);
      if( rad2 < rad1 ) {
         n = write(fout,format="// radius = %7.3f; deg\n", rad1);
      } else {
         n = write(fout,format="%s\n","// selection in annulus");
         n = write(fout,format="// rad1 = %7.3f; deg\n", rad1);
         n = write(fout,format="// rad2 = %7.3f; deg\n", rad2);
      }
      if( tstart ) {
         n = write(fout,format="// tstart = %14.8f; IJD\n", tstart);
      }
      if( tstop ) {
         n = write(fout,format="// tstop = %14.8f; IJD\n", tstop);
      }
      if( numberof(rev) ) {
         if( nrev == 1 ) {
            n = write(fout,format="// rev_begin = %4i\n", revarr(1));
            n = write(fout,format="// rev_end   = %4i\n", revarr(1));
         } else {
            n = write(fout,format="// rev_begin = %4i\n", revarr(1));
            n = write(fout,format="// rev_end   = %4i\n", revarr(0));
         }
      }

   }

   ntotal = 0;
   for( ipf_list = 1; ipf_list <= npf_list; ipf_list++ ) {

      if( file_test(ypf_list(ipf_list)) ) {
         if( !silent ) write,"Reading binary file "+ypf_list(ipf_list);
         bfile = openb( ypf_list(ipf_list) );
         restore,bfile, swid, ra, dec, posangle, ut, ijd, telapse, \
                     mode1, mode2;
         close, bfile;
      } else {
         if( !silent ) write,"Reading usual text file "+pf_list(ipf_list);
         if( ! file_test(pf_list(ipf_list)) ) {
            if( !silent ) write,pf_list(ipf_list)+" was not found";
            continue;
         }
      /*
       * swid = rscol( pf_list(ipf_list),1, str=1, silent=1);
       * ra = rscol( pf_list(ipf_list), 2, silent=1);
       * dec = rscol( pf_list(ipf_list), 3, silent=1);
       * posangle = rscol( pf_list(ipf_list), 4, silent=1);
       * ut = rscol( pf_list(ipf_list), 5, str=1, silent=1);
       * ijd = rscol( pf_list(ipf_list), 6, silent=1);
       * telapse = rscol( pf_list(ipf_list),7, silent=1);
       * mode1 = rscol( pf_list(ipf_list), 8, str=1, silent=1);
       * mode2 = rscol( pf_list(ipf_list), 9, str=1, silent=1);
       */

         rstab,pf_list(ipf_list),9,swid,ra,dec,posangle,ut,ijd,telapse, \
              mode1, mode2,typ="sfffsffss",silent=1;

         bfile = createb( ypf_list(ipf_list) );
         save, bfile,  swid, ra, dec, posangle, ut, ijd, telapse, \
                 mode1, mode2;
         close, bfile;
      }

      dist = arcdist(ra0, dec0, ra, dec);

      if( abs(rad2) < 1.e-10 ) {

         w = where( dist < rad1);
         nw = numberof(w);

      } else {

         w = where( dist > rad1 & dist < rad2);
         nw = numberof(w);

      }

      if( nw > 0 ) {

         if( first ) {
            first = 0;
            swid_all = swid(w);
            ra_all = ra(w);
            dec_all = dec(w);
            posangle_all = posangle(w);
            ut_all = ut(w);
            ijd_all = ijd(w);
            telapse_all = telapse(w);
            mode1_all = mode1(w);
            mode2_all = mode2(w);
            dist_all = dist(w);
         } else {
            grow,swid_all,swid(w);
            grow,ra_all,ra(w);
            grow,dec_all,dec(w);
            grow,posangle_all,posangle(w);
            grow,ut_all,ut(w);
            grow,ijd_all,ijd(w);
            grow,telapse_all,telapse(w);
            grow,mode1_all,mode1(w);
            grow,mode2_all,mode2(w);
            grow,dist_all,dist(w);
         }

         ntotal += nw;

      }

   }
   if( ntotal == 0 ) {
      if(!silent) write,"Sorry, no pointings found!";
      return [];
   }

   if( offax ) {
      is = sort(dist_all);
      swid_all = swid_all(is);
      ra_all = ra_all(is);
      dec_all = dec_all(is);
      posangle_all = posangle_all(is);
      ut_all = ut_all(is);
      ijd_all = ijd_all(is);
      telapse_all = telapse_all(is);
      mode1_all = mode1_all(is);
      mode2_all = mode2_all(is);
      dist_all = dist_all(is);
   }

   noutput = 0;
   list = "";
   list_list = [];
   expo_tot = 0.0;
   for( i = 1; i <= ntotal; i++ ) {
      // apply the time selection
      if( ijd_all(i) > tbegin && ijd_all(i) < tend ) {
         //+ eff_factor = 1. - dist_all(i)/6.4;
         //+ eff_factor = 1. - dist_all(i)/5.0;
         //+ expo_contrib = eff_factor > 0.0 ? telapse_all(i) * eff_factor : 0.0;

         // The 'eff_factor' is set to 1 for this version

         expo_contrib = telapse_all(i);
         expo_tot += expo_contrib;
         grow,list_list,swid_all(i);
         if( !nof) {
            write,fout,format="%s%10.4f%9.4f%9.3f  %s%10.3f%6.0f  %s  %s %8.2f %7.0f\n",
            swid_all(i),ra_all(i),dec_all(i),posangle_all(i),
            ut_all(i),ijd_all(i),telapse_all(i),
            mode1_all(i),mode2_all(i),dist_all(i), expo_contrib;
         }
         noutput++;
      }
   }

   lst_list = array("",ntotal);
   for( i = 1; i <= ntotal; i++ ) {
      lst_list(i) = "./scw/"+strpart(swid_all(i),1:4)+"/"+swid_all(i)+".001/swg.fits[1]";
   }

   if( !nof ) {
      write,fout,format="//\n// Total exposure for selected position is %14.5e s\n", \
                expo_tot;
      close,fout;
   }

   if( !silent ) {
      write,format="Found %i SWIDs in selected revolutions\n", ntotal;
      if( noutput == 1 ) {
         write,format="%i has been selected by time\n", noutput;
      } else {
         write,format="%i have been selected by time\n", noutput;
      }
      write,format="Total exposure for selected position is %14.4e s\n", expo_tot;
      if( !nof ) write,"Output is directed to "+outfilename;

   }

   if( !is_void(lst) ) { return lst_list; } else {return list_list;}

}


%FILE% fitpoly.i
/*
 * fitpoly.i
 * least squares fit of polynomial to data
 */

func fitpoly(n, x, y, w)
/* DOCUMENT fitpoly(n, x, y)
         or fitpoly(n, x, y, w)

     return [a0,a1,a2,...aN], the coefficients of the least squares
     fit polynomial of degree N to the data points (X, Y).

     X and Y must be arrays of N+1 or more points.  The optional
     parameter W is a weight array, which must be conformable with
     X and Y; it defaults to 1.0.  If the standard deviation of Y
     is sigma, conventional wisdom is that W = 1/sigma^2.

   SEE ALSO: poly2
*/
{
  if (is_void(w)) w = 1.;
  scale = 1./max(abs(x));
  x *= scale;
  y = double(y);

  xi = w*array(1.,dimsof(x));
  matrix = array(sum(xi), n+1, n+1);
  rhs = array(sum(y), n+1);

  power = indgen(0:n)(,-:1:n+1) + indgen(0:n)(-:1:n+1,);
  for (i=1 ; i<=2*n ; i++) {
    xi*= x;
    matrix(where(power==i))= sum(xi);
    if (i<=n) rhs(i+1)= sum(y*xi);
  }

  xi= LUsolve(matrix, rhs);
  xi(2:n+1)*= scale^indgen(n);

  return xi;
}

func poly2(x, a)
/* DOCUMENT poly2(x, a)
     N = numberof(a) - 1
     returns the polynomial  a(1) + a(2)*x + a(3)*x^2 + ... + a(0)*x^N
     The data type and dimensions of the result, and conformability rules
     for the inputs are identical to those for the expression.
   SEE ALSO: poly, polyn, dpolyn, ddpolyn
*/
{
  y = array(structof(x), dimsof(x));
  for( i = dimsof(a)(0); i > 0; i--) y = a(..,i) + y*x;
  return y;
}
%FILE% fits_calc_pcount.i
func fits_calc_pcount( filename )
/* DOCUMENT pcount = fits_calc_pcount( filename )
*/
{
   local fname, extno;
   get_exten_no, filename, fname, extno;

   nbytes = filesize( fname );
   write,format="nbytes = %i\n", nbytes;

   fh = fits_open( fname, "r" );
   fh = fits_next_hdu( fh );
   xtension = fits_get_xtension(fh);
   write,format="XTENSION = %s\n", xtension;
   if( xtension != "BINTABLE" ) {
      write,"Not a BINTABLE so quit!";
      return [];
   }
   old_pcount = fits_get_pcount(fh);
   write,format="Existing PCOUNT = %i\n", old_pcount;
   dms = fits_get_dims(fh);

   descr = _car(fh,3);
   // descr(3) is address (in file) of data i.e. where data start
   write,format="Data start at %i\n", descr(3);
   write,format="Number of bytes of ordinary data = %i\n", dms(2)*dms(3);

   pcount = nbytes - descr(3) - dms(2)*dms(3);
   write,format="New PCOUNT = %i\n", pcount;

   return pcount;

}

%FILE% fits_col_stat.i
/* Function fits_col_stat */

func fits_col_stat( dol, col_id )
/* DOCUMENT fits_col_stat, dol, col_id

    Outputs how many times each value (must be integer)
    occurs in the given column.

    2012-12-07/NJW
*/
{
   local filename, extno;
   get_exten_no, dol, filename, extno;
   if( !file_test(filename) ) error,"File not found: "+filename;
   c = rdfitscol(dol, col_id);
   if( structof(c) != int && structof(c) != long ) error,"Column type is not integer";

   c = reform(c, numberof(c));

   c = c(sort(c));
   u = grow(uniq(c),numberof(c));
   n = u(dif);
   nn = numberof(n);
   write,"     Value   Number of occurrences";
   for( i = 1; i <= nn; i++ ) {
      write,format="%10i  %10i\n", c(u(i)), n(i);
   }
}
%FILE% fits_fh_verify.i
func fits_fh_verify( &fh )
/* DOCUMENT fh = fits_fh_verify( >fh )

   Removes empty cards and updates the identifiers

   2009-06-25/NJW
*/
{
   cards = _car(fh,1);
   ncards = numberof(cards);
   ids = fits_ids(cards);
   w = where(ids >= 0.0 );
   if( numberof(w) == 0 ) error, "##5## fh is completely corrupted";
   cards = cards(w);
   ids = ids(w);
   _car, fh, 1, cards;
   _car, fh, 2, ids;
   return fh;
}
%FILE% fits_gparse.i
//+ local _fits_parse_comment;
func fits_gparse(card, &keyw, &comment )
/* DOCUMENT value = fits_gparse(card, >keyw, >comment );

     More general version of fits_parse
     The '=' sign is not necessarily in position 9

     Return value  of a single  FITS card (CARD  is a scalar  string).  The
     type of the scalar result is as follow:
        - string for a string or a commentary FITS card
        - char ('T' for true or 'F' for false) for a logical FITS card
        - long for an integer FITS card
        - double for a real FITS card
        - complex for a complex FITS card

     Trailing   spaces   (which    are   irrelevant   according   to   FITS
     specifications)   get   discarded   from   the  returned   value   for
     string-valued cards (not commentary cards).

     In order to save a call to  fits_id, if ID is non-nil it is assumed to
     be the numerical identifier of the card, i.e. fits_id(CARD).

     The   comment  part   of   CARD  is   stored   into  external   symbol
     _fits_parse_comment which is a string (possibly nil) for a valued card
     and void (i.e. []) for a commentary card.

     If the  SAFE keyword is true,  the routine returns an  empty result in
     case of error.

   SEE ALSO: fits, fits_get, fits_id. */
{
  extern _fits_parse_comment;
  extern _fits_id_comment, _fits_id_history;

   //-- scan for = sign and insert where appropriate

   poss = strpos( card, " ", 1 ); // position of first space
   unquote_card = strdelcom( card ); // forget what is between quotes
   pose = strpos( unquote_card, "=", 1 );
   if( pose == 0 && poss >= 9 ) error,"##1## Bad format too long keyword";
   if( pose == 1 ) error,"##2## Bad format equal sign cannot be first";
   if( poss == 1 ) error,"##3## Bad format may not start with space";
   if( pose == 0 ) {
      part1 = strpart(card,1:poss);
      part1 = strpadd(part1,8," ");
      part2 = strpart(card,poss+1:);
      card = part1+"="+part2;
      pose = 9;
   } else if( pose < 9 ) {
      part1 = strpart(card,1:pose-1);
      part2 = strpart(card,pose:);
      card = part1+strpadd("",9-pose," ")+part2;
      pose = 9;
   } else if( pose > 9 ) { // make sure that only spaces exist between
                           // keyword and = sign
      if( poss >= 9 ) error,"##4## Bad format too long keyword";
      s = strpart(card,poss:pose-1);
      cs = *pointer(s);
      if( anyof(cs(1:-1)!=32) ) error,"##5## Bad format non space between keyword and =";
      part1 = strpart(card,1:8);
      part2 = strpart(card,pose:);
      card = part1+part2;
   }
   //-- end of update
  id = fits_id(card);
  tail = strpart(card, 9:);
  keyw = strtoupper( strtrim(strpart(card,1:8)));

  /* Deal with commentary card. */
  if (id == 0.0 || id == _fits_id_comment || id == _fits_id_history) {
    _fits_parse_comment = [];
    return tail;
  }

  /* Use first non-space character after '=' for faster guess (I don't
     want to be too strict there: FITS standard requires that bytes
     9-10 be "= " for a valued-card, but the following sread format
     succeeds if bytes 9-80 is a "=" followed by any number of spaces
     and at least a non-space character). */
  r = s = _fits_parse_comment = string(0);
  if ((n = sread(tail, format="%1[=]%1s", r, s)) != 2) {
    if (n == 0) {
      /* Must be END card. */
      if (id == _fits_id_end) {
        comment = _fits_parse_comment = [];
        return;
      }
    } else /* n = 1 */ {
      /* Undefined keyword. */
      return;
    }
  } else if (strmatch("0123456789+-.", s)) {
    /* Numerical value...
       ... try integer value: */
    re = 0;
    n = sread(tail, format="=%d%1s %[^\a]", re, s, _fits_parse_comment);
    comment = _fits_parse_comment;
    if (n==1 || (n>1 && s=="/")) return re;

    /* ... try real value: */
    re = 0.0;
    n = sread(tail, format="=%f%1s %[^\a]", re, s, _fits_parse_comment);
    comment = _fits_parse_comment;
    if (n==1 || (n>1 && s=="/")) return re;

    /* ... try complex value: */
    im = 0.0;
    n = sread(tail, format="=%f%f%1s %[^\a]", re, im, s, _fits_parse_comment);
    comment = _fits_parse_comment;
    if (n==2 || (n>2 && s=="/")) return re + 1i*im;

  } else if (s=="T" || s=="F") {
    /* Logical value. */
    value = (s == "T" ? 'T' : 'F');
    n = sread(tail, format="= "+s+"%1s %[^\a]", s, _fits_parse_comment);
    comment = _fits_parse_comment;
    if (n==0 || (n>0 && s=="/")) return value;

  } else if (s=="'" && sread(tail, format="= '%[^\a]", s)) {
    /* String value. */
    q = p1 = p2 = string(0);
    value = "";
    do {
      if (sread(s, format="%[^']%[']%[^\a]", p1, q, p2)) value += p1;
      else if (! sread(s, format="%[']%[^\a]", q, p2)) break;
      if ((n = strlen(q)) > 1) value += strpart(q, :n/2);
    } while ((s=p2) && !(n%2));
    if (! sread(s, format="%1s %[^\a]", q, _fits_parse_comment) || q=="/") {
      /* discard trailing spaces which are not significant in FITS */
       comment = _fits_parse_comment;
      i = numberof((c = *pointer(value)));
      while (--i) { if (c(i) != ' ') return string(&c(1:i)); }
      return "";
    }
  } else if (s == "/") {
    /* Undefined keyword with comment. */
    sread, tail, format="= / %[^\a]", _fits_parse_comment;
    comment = _fits_parse_comment;
    return;
  }

  //+ if (! safe) error, "syntax error in FITS card \""+strpart(card, 1:8)+"\"";
}
%FILE% fits_image_poke.i
/* Function fits_image_poke */

func fits_image_poke( dol, new_image, chat= )
/* DOCUMENT fits_image_poke, dol, new_image, chat=

   Substitutes the image in a FITS image extension

   2010-02-19/NJW, cloned from fits_bintable_poke
*/
{

   if( is_void(new_image) ) error,"Entered void value";
   if( is_void(chat) ) chat = 0;

   dms = dimsof( new_image );
   local filename, extno; get_exten_no, dol, filename, extno;
   fh = fits_open( filename, 'r' );
   fh = fits_goto_hdu( fh, extno+1 );

   xtension = fxpar( fh, "XTENSION" );
   if( xtension != "IMAGE" ) error,"The xtension: "+xtension+" is not IMAGE";
   naxis = fxpar( fh, "NAXIS" );
   if( naxis != dms(1) ) error,"Number of dimension mismatch";
   if(chat)write,format="NAXIS = %i\n",naxis;
   naxes = array(long,naxis);
   for( i = 1; i <= naxis; i++ ) {
      naxes(i) = fxpar( fh, "NAXIS"+itoa(i) );
      if(chat)write,format="NAXIS%i = %i\n", i, naxes(i);
      if( naxes(i) != dms(i+1) ) error,"Dimension "+itoa(i)+" mismatch";
   }

   bitpix = fxpar( fh, "BITPIX" );

  /*
   * There are cases such a Linux on 64 bit machines where
   *  sizeof(long) == 8. This is not compatible with FITS J-type
   *  where 4 bytes are expected. Hence if 'new_image' is of type 'long'
   *  it must be converted to 'int'.
   */

   if( typeof(new_image) == "long" && sizeof(long) == 8 ) {
      new_image = int(new_image);
   }
   type = typeof( new_image );
   if( bitpix == 16 ) {
      if(chat)write,"BITPIX is 16, a type 'short' is expected";
      if( type != "short" ) error,"Not type 'short'";
   } else if( bitpix == 32 ) {
      if(chat)write,"BITPIX is 32, a type 'int' or 'long' is expected";
      if( type != "int" && type != "long" ) error,"Not type 'int' or 'long'";
   } else if( bitpix == -32 ) {
      if(chat)write,"BITPIX is -32, a type 'float' is expected";
      if( type != "float" ) error,"Not type 'float'";
   } else if( bitpix == -64 ) {
      if(chat)write,"BITPIX is -64, a type 'double' is expected";
      if( type != "double" ) error,"Not type 'double'";
   } else {
      error,"Type '"+type+"' is not supported";
   }


   // new file (temporary)

   filenameo = "_tmp_.fits";
   fho = fits_open( filenameo, 'w', overwrite=1 );

   // Calculate address where replacement begins

   // address in file of start of data section

   address = _car(fh,3)(3);

   if(chat)write,format="Address of image data: %i\n", address;

   // copy file until start of image-data section

   vc = array(char,1);
   for( addr=0; addr < address; addr++ ) {
      _read, _car(fh,4), addr, vc;
      _write, _car(fho,4), addr, vc;
   }

   // write the new data ('addr' is pointing to the beginning)

   _write, _car(fho,4), addr, new_image;

   addr += sizeof( new_image );

   // copy remainder of file

   while( _read( _car(fh,4), addr, vc) == 1 ) _write, _car(fho,4), addr++, vc;

   fits_close, fh;
   fits_close, fho, nopad=1;

   cp, filenameo, filename;
   remove, filenameo;

}
%FILE% fits_modhead.i
/*****************************************************

   The 'fits_modhead' project is (temporarily) halted
   due to problems in kfits.i

   Functions involved: 
              fits_fh_verify.i
              fits_gparse.i
              kfits.i.006

    2009-06-26/NJW
******************************************************/

func fits_modhead( dol, newfile, tpl=, chat=  )
/* DOCUMENT fits_modhead, dol, newfile, tpl=, chat=

   Modify the header of a FITS extension

   Keyword 'tpl' must be the name of a file with FITS keyword(s)
   to be inserted (default name: tpl.txt).

   2009-06-24/NJW
*/
{
   local filename, extno;
   local keyw, comment;
   local cards, ids;

   get_exten_no, dol, filename, extno;
   if( !file_test(filename) ) {
      write,filename+" does not exist";
      return;
   }
   if( chat ) {
      write,"Updating header in "+filename+" with extno = "+itoa(extno);
   }

   if( is_void(tpl) ) tpl = "tpl.txt";
   if( !file_test(tpl) ) {
      write,"Text file "+tpl+" does not exist";
      return;
   }

   if( is_void(chat) ) chat = 0;

   klist = read_slist(tpl);
   nklist = numberof(klist);
   if( chat ) prstrarr, klist;

   fh = fits_open( filename, 'r' );
   fhtypes = fits_list( fh );

   if( file_test(newfile) ) remove, newfile;
   fho = fits_create( newfile );

   for( hdu = 1; hdu <= numberof(fhtypes); hdu++ ) {
      fh = fits_goto_hdu( fh, hdu );
      // copy all keywords to output file handle
      _car, fho, 1, _car(fh,1);
      num_keys_in = numberof(_car(fh,1));
      num_rec_in = num_rec_out = num_keys_in / 36 + 1;
            // The 'END' card is not included in fh

      if( chat ) {
         ncards = _fits_get_cards(fh, cards, ids);
         write,format="In HDU#%i there are %i cards:\n", hdu, ncards;
         prstrarr, cards;
         write,"-----------------------";
      }


      //----- if this is the indicated extension then the
      //      update of the keywords must be done

      if( hdu == extno+1 ) {
         for( i = 1; i <= nklist; i++ ) {
            value = fits_gparse( klist(i), keyw, comment );
            fits_set, fho, keyw, value, comment;
         }
         num_keys_out = numberof(_car(fho,1));
         num_rec_out = num_keys_out / 36 + 1;
         fho = fits_rehash(fho); // update identifiers
         if( chat ) {
            ncards = _fits_get_cards(fho, cards, ids);
            write,format="%i cards to be written:\n", ncards;
            prstrarr, cards;
            write,"-----------------------";
         }
      }
            
      // copy all keyword numerical identifiers to output file handle
      //+ _car, fho, 2, _car(fh,2);

      // update file address of current HDU
      descr = _car(fh,3); // [(1) HDU number, (2) address CHDU, (3) address data of CHDU,
                          //  (4) numberof written bytes, (5) 'w']
      descro = descr;
      descro(3) += 2880*(num_rec_out - num_rec_in);
      descro(4) = descro(3);
      // make sure file mode is 'w'
      descro(5) = 'w';
      _car, fho, 3, descro;

      fits_write_header, fho;
      if( hdu == 1 ) continue;

      if( fhtypes(hdu) == "IMAGE" ) {
         a = fits_read_array( fh );
         fits_write_array, fho, a;
      } else if( fhtypes(hdu) = "BINTABLE" ) {
         ptr = fits_read_bintable( fh );
         fits_write_bintable, fho, ptr;
      } else {
         write,"Warning: extension type not supported";
      }
   }
   fits_close, fh;
   fits_close, fho;
}
%FILE% fjerde.i

for( i = 1; i <= 181; i++ ) {
for( j = 1; j <= i; j++ ) {
   s = i^4 + j^4;
   rod = s^0.25;
   for( k = 1; k <= rod; k++ ) {
      rest = s - k^4;
      rrod = rest^0.25;
      irrod = long(rrod+0.5);
      if( abs(rrod-irrod) < 1.e-8 ) {
         if( k != i && k != j ) {
            write,i,j,k,irrod;
         }
      }
   }
}}
%FILE% ftest.i


func syl(x,&y)
{
   extern a;

   y = 2*x;
   a = x;
   print,"value of b: ", b;
   return x*x;
}

func sav(z)
{
   extern b;

   b = z*z;
   print,"value of a: ", a;

   return 1;
}
%FILE% geometry.i
#include "draw_arrow.i"

extern geometrydoc;
/* DOCUMENT A package for various geometry tasks

    2008-07-31/NJW

   A polygon is an array of points (struct s_Point) and it is
   assumed to be closed i.e. first point connecting to last point.
   To be useful for hatching three or more points are
   demanded as well as no 'crossing' i.e. no sides may
   be intersecting.

   Types: point, line, delline, semidelline, circle

   Functions:
       box2plg                  draw_polygon             
       circle2plg               hatch                    
       cur_circle               init_canvas              
       cur_delline              inter_c_c                
       cur_line                 inter_dl_dl              
       cur_point                inter_dl_l               
       cur_polygon              inter_l_c                
       dcder                    inter_l_l                
       delline_p_p              inter_l_plg              
       dist_p_l                 line_p_angle             
       dist_p_p                 line_p_p                 
       draw_circle              line_perp_p_p            
       draw_delline             mirror_p_l               
       draw_line                verify_plg               
       draw_point               inside_plg
       ginter_l_l               inter_sdl_l
       inter_sdl_dl             inter_sdl_sdl
       vec_p_p                  get_vec_angle
       vec_r_angle              draw_garrow
   Structs:
       s_Circle
       s_DelLine
       s_Line
       s_Point
       s_Arc

*/

Inf_px = 300.; Inf_mx = -300.;
Inf_py = 300.; Inf_my = -300.;
Inf_r = 300.;

//+ window, 1, style="boxed.gs";
//+ window, 0, style="axes.gs";

// Straight line: ax + by = c

struct s_Line{
   string type;
   double a;
   double b;
   double c;
}

// Point (x,y) and Vector

struct s_Point{
   string type;
   double x;
   double y;
}

// Delimited straight line: ax + by = c
//  between p1 and p2
// and Semi-delimited line, then p1 is the real delimiter
// and p2 is the indicator of which side.

struct s_DelLine{
   string type;
   double a;
   double b;
   double c;
   s_Point p1;
   s_Point p2;
}

// Circle (center,radius)

struct s_Circle{
   string type;
   s_Point center;
   double radius;
}

// Arc (center, radius, angle1, angle2)

struct s_Arc{
   string type;
   s_Point center;
   double radius;
   double angle1;
   double angle2;
}

// Initialize plotting

func init_canvas( dimen, axes=, pane= )
/* DOCUMENT init_canvas, dimension, axes=, pane=
    opens a plotting window limited by +-dimension
    in both x and y.

    Axes will be shown when keyword 'axes' is set.
    Keyword 'pane' defines the window.
*/
{
   if( is_void(dimen) ) {
      write,"Syntax: init_canvas, dimension[, axes=][, pane=]";
      return;
   }
   if( is_void(pane) ) pane = 0;
   if( axes ) {
      window,pane;
   } else window,pane,style="nobox.gs";

   plot,dimen*[-0.5,0.5],dimen*2*[1.,1.],xr=dimen*[-1.,1.],yr=dimen*[-1.,1.];
}

// Enter a point by the cursor

func cur_point(void, lbl= )
/* DOCUMENT p = cur_point( lbl= )
    Defines a point (struct s_Point) by cursor input
    on the current canvas. If keyword 'lbl' is given,
    'draw_point' will be called with the label.
*/
{
   p = s_Point();
   p.type = "point";
   c = curmark1(ps=12,symsize=0.3);
   p.x = c(1);
   p.y = c(2);

   if( numberof(lbl) ) draw_point, p, lbl=lbl;

   return p;
}

// Enter a circle by the cursor

func cur_circle(void)
/* DOCUMENT c = cur_circle()
    Defines a circle (struct s_Circle) by cursor input
    for center and a point on the periphery on the current canvas.
*/
{
   write,"Define the center of the circle ...";
   c = cur_point();
   write,"Select any point on the periphery: ...";
   r = cur_point();
   res = s_Circle();
   res.type = "circle";
   res.center = c;
   res.radius = dist_p_p( c, r );
   draw_circle, res;

   return res;
}

// Enter an arc by the cursor

func cur_arc(void)
/* DOCUMENT a = cur_arc()
    Defines an arc (struct s_Arc) by cursor input
    for center, first point on circle (defines radius and 'angle1')
    and terminating angle.
*/
{
   write,"Define the center of the circle ...";
   c = cur_point();
   write,"Select the first point on the periphery: ...";
   p1 = cur_point();
   a = s_Arc();
   a.type = "arc";
   a.center = c;
   a.radius = dist_p_p( c, p1 );
   v1 = vec_p_p( c, p1 );
   a.angle1 = get_vec_angle( v1 );
   write,"Define the second angle: ...";
   p2 = cur_point();
   v2 = vec_p_p( c, p2 );
   a.angle2 = get_vec_angle( v2 );

   draw_arc, a;

   return a;
}

// Define a vector by start point and end point

func vec_p_p( start_point, end_point )
/* DOCUMENT v = vec_p_p( start_point, end_point )
     defines a vector (same struct as point)
*/
{
   v = s_Point();
   v.type = "vector";
   v.x = end_point.x - start_point.x;
   v.y = end_point.y - start_point.y;
   return v;
}

// Define a vector by radius and angle (in degrees)

func vec_r_angle( radius, angle )
/* DOCUMENT v = vec_r_angle( radius, angle )
     defines a vector (same struct as point)
*/
{
   v = s_Point();
   v.type = "vector";
   v.x = radius * cos(angle*pi/180.);
   v.y = radius * sin(angle*pi/180.);
   return v;
}

// Get angle (in degrees) of vector

func get_vec_angle( vector )
/* DOCUMENT angle = get_vec_angle( vector )
     Angle in degrees
*/
{
   if( vector.type != "vector" ) error,"Illegal argument";
   return atan(vector.y, vector.x)*180./pi;
}

// Enter a line by the cursor

func cur_line(void)
/* DOCUMENT l = cur_line()
    Defines a line (struct s_Line) by cursor input
    for two points on the line on the current canvas.
*/
{
   write,"Define the first point of the line ...";
   p1 = cur_point();
   write,"Define the second point of the line ...";
   p2 = cur_point();
   return line_p_p( p1, p2 );
}

// Enter a delimited line by the cursor

func cur_delline(void)
/* DOCUMENT l = cur_delline()
    Defines a delimited line (struct s_DelLine) by cursor input
    for the two endpoints of the line on the current canvas.
*/
{
   write,"Define the first end point of the line ...";
   p1 = cur_point();
   write,"Define the second end point of the line ...";
   p2 = cur_point();
   line = line_p_p( p1, p2 );
   res = s_DelLine();
   res.type = "delline";
   res.a = line.a;
   res.b = line.b;
   res.c = line.c;
   res.p1 = p1;
   res.p2 = p2;
   return res;
}

// Enter a semi-delimited line by the cursor

func cur_semidelline(void)
/* DOCUMENT l = cur_semidelline()
    Defines a semi-delimited line (struct s_DelLine) by cursor input
    for an endpoint and a guide point of the line on the current canvas.
*/
{
   write,"Define the end point of the line ...";
   p1 = cur_point();
   write,"Define the guide point of the line ...";
   p2 = cur_point();
   line = line_p_p( p1, p2 );
   res = s_DelLine();
   res.type = "semidelline";
   res.a = line.a;
   res.b = line.b;
   res.c = line.c;
   res.p1 = p1;
   res.p2 = p2;
   return res;
}

// Enter a polygon by the cursor

func cur_polygon( void, ps=, symsize= )
/* DOCUMENT plyg = cur_polygon( ps=, symsize= )
    Defines a polygon (struct s_Polygon) by cursor input
    for each corner of the polygon on the current canvas.
    Keywords: ps - plotsymbol, symsize - symbol size
*/
{
   write,"Enter polygon points: ... ";
   if( is_void(ps) ) ps = 2;
   if( is_void(symsize) ) symsize = 1.;
   res = curmark( ps=ps, symsize=symsize );
   nres = numberof(res);
   pol = array(s_Point, nres/2);
   pol(*).type = "point";
   pol(*).x = res(1::2);
   pol(*).y = res(2::2);
   return pol;
}

func verify_plg( polygon )
/* DOCUMENT result = verify_plg( polygon )
    Returns 1 if there are no crossing sides of the polygon
    else 0 (zero).
*/
{
   n = numberof( polygon );
   if( n < 3 ) return 0; // must have 3 or more sides
   // test all sides against all other sides
   // a side is from point i to point i+1;
   // if i+1 > n then 1 is to be used
   for( i = 1; i <= n; i++ ) {
      i2 = i == n ? 1 : i+1;
      dlinei = delline_p_p(polygon(i), polygon(i2));
      for( j = i+1; j <= n; j++ ) {
         j2 = j == n ? 1 : j+1;
         dlinej = delline_p_p(polygon(j), polygon(j2));
         q = inter_dl_dl( dlinei, dlinej );
         if( !is_void(q) ) {
            // if 'q' is (almost) identical to an apex then it
            // is rejected as an intersection
            if( min(abs(polygon.x-q.x)) + min(abs(polygon.y-q.y)) > 1.e-9 ) \
                 return 0; // side crossing occurred
         }
      }
   }

   // when you get here all sides have been tested

   return 1;
}

// Distance from point to point

func dist_p_p( point1, point2 )
{
   return sqrt((point1.x-point2.x)^2 + (point1.y-point2.y)^2);
}

// Distance from line to point

func dist_p_l( point, line )
{
   a = line.a;
   b = line.b;
   c = line.c;
   m = sqrt(a*a+b*b);

   return (point.x*a + point.y*b - c)/m;
}

// Mirror point in line

func mirror_p_l( point, line )
{
   d = dist_p_l( point, line );
   m = sqrt(line.a^2 + line.b^2);
   mp = s_Point();
   mp.type = "point";
   mp.x = point.x - 2*d*line.a/m;
   mp.y = point.y - 2*d*line.b/m;

   return mp;
}

// Get point from x,y values

func xy2point( x, y )
/* DOCUMENT p = xy2point( x, y)

*/
{
   p = s_Point()
   p.type = "point";
   p.x = double(x);
   p.y = double(y);
   return p;
}

// Line through two points

func line_p_p( point1, point2 )
{
   l = s_Line();
   l.type = "line";
   l.a = point1.y - point2.y;
   l.b = point2.x - point1.x;
   l.c = point1.x*l.a + point1.y*l.b;

   return l;
}

// Line through a point at an angle

func line_p_angle( point, angle )
/* DOCUMENT l = line_p_angle( point, angle )

     returns an unlimited line.
     'angle' in degrees.
*/
{
    // angle in degrees
    point2 = s_Point();
    point2.type = "point";
    point2.x = point.x + cos(angle*pi/180.);
    point2.y = point.y + sin(angle*pi/180.);
    return line_p_p( point, point2 );
}

// Delimited line between two points

func delline_p_p( point1, point2 )
{
   dl = s_DelLine();
   dl.type = "delline";
   dl.a = point1.y - point2.y;
   dl.b = point2.x - point1.x;
   dl.c = point1.x*dl.a + point1.y*dl.b;
   dl.p1 = point1;
   dl.p2 = point2;

   return dl;
}

// Semi-delimited line between two points
//  First point is the end point, second is guide point

func semidelline_p_p( point1, point2 )
{
   dl = s_DelLine();
   dl.type = "semidelline";
   dl.a = point1.y - point2.y;
   dl.b = point2.x - point1.x;
   dl.c = point1.x*dl.a + point1.y*dl.b;
   dl.p1 = point1;
   dl.p2 = point2;

   return dl;
}

// Line perpendicular and midway between two points

func line_perp_p_p( point1, point2 )
{
   x1 = point1.x; y1 = point1.y;
   x2 = point2.x; y2 = point2.y;
   x0 = (x1 + x2)/2;
   y0 = (y1 + y2)/2;
   l = s_Line();
   l.a = x1 - x2;
   l.b = y1 - y2;
   l.c = (x1*x1-x2*x2+y1*y1-y2*y2)/2;

   return l;
}

// Generic intersection of two lines
// meaning that the line types are read from the struct

func ginter_l_l( line1, line2 )
{
   if( line1.type == "line" ) {
      if( line2.type == "line" ) {
         return inter_l_l( line1, line2 );
      } else if( line2.type == "delline" ) {
         return inter_dl_l( line2, line1 );
      } else if( line2.type == "semidelline" ) {
         return inter_sdl_l( line2, line1 );
      } else {
        error,"Illegal line type for line2";
      }
   } else if( line1.type == "delline" ) {
      if( line2.type == "line" ) {
         return inter_dl_l( line1, line2 );
      } else if( line2.type == "delline" ) {
         return inter_dl_dl( line1, line2 );
      } else if( line2.type == "semidelline" ) {
         return inter_sdl_dl( line2, line1 );
      } else {
        error,"Illegal line type for line2";
      }
   } else if( line1.type == "semidelline" ) {
      if( line2.type == "line" ) {
         return inter_sdl_l( line1, line2 );
      } else if( line2.type == "delline" ) {
         return inter_sdl_dl( line1, line2 );
      } else if( line2.type == "semidelline" ) {
   
      } else {
        error,"Illegal line type for line2";
      }
   } else {
     error,"Illegal line type for line1";
   }
}

// Intersection of two lines

func inter_l_l( line1, line2 )
{
   D = line1.a*line2.b - line1.b*line2.a;
   if( abs(D) < 1.e-10 ) return [];
   p = s_Point();
   p.type = "point";
   p.x = (line1.c*line2.b - line1.b*line2.c)/D;
   p.y = (line1.a*line2.c - line1.c*line2.a)/D;
   return p;
}

// Intersection of two delimited lines

func inter_dl_dl( delline1, delline2 )
{
   // distances from line1 to p1 and p2 of line2 must have
   // different signs and vice versa
   d1_1 = dist_p_l( delline1.p1, delline2 );
   d1_2 = dist_p_l( delline1.p2, delline2 );
   if( d1_1*d1_2 > 0.0 ) return []; // they have same sign
   d2_1 = dist_p_l( delline2.p1, delline1 );
   d2_2 = dist_p_l( delline2.p2, delline1 );
   if( d2_1*d2_2 > 0.0 ) return []; // they have same sign
   q = inter_l_l( delline1, delline2 );
   if( is_void(q) ) error,"inter_dl_dl error: surprise! should not happen";
   return q;
}

// Intersection of delimited line and (unlimited) line

func inter_dl_l( delline1, line2 )
{
   // distances from line2 to p1 and p2 of delline1 must have
   // different signs
   d1_1 = dist_p_l( delline1.p1, line2 );
   d1_2 = dist_p_l( delline1.p2, line2 );
   if( d1_1*d1_2 > 0.0 ) return []; // they have same sign
   q = inter_l_l( delline1, line2 );
   if( is_void(q) ) error,"inter_dl_l error: surprise! should not happen";
   return q;
}

// Intersection of line and semi-delimited line

func inter_sdl_l( semidelline1, line2 )
{
   // Find intersection as if both were unlimited lines
   // and then check for guide point
   p = inter_l_l( semidelline1, line2 );
   vsdl = [(semidelline1.p2).x - (semidelline1.p1).x, (semidelline1.p2).y - (semidelline1.p1).y];
   vcross = [p.x - (semidelline1.p1).x, p.y - (semidelline1.p1).y];
   return sum(vsdl*vcross) > 0.0 ? p : [];
}

// Intersection of a semi-delimited line and a delimited line

func inter_sdl_dl( semidelline1, delline2 )
{
   // distances from line1 to p1 and p2 of line2 must have
   // different signs
   d2_1 = dist_p_l( delline2.p1, semidelline1 );
   d2_2 = dist_p_l( delline2.p2, semidelline1 );
   if( d2_1*d2_2 > 0.0 ) return []; // they have same sign
   p = inter_l_l( semidelline1, delline2 );
   vsdl = [(semidelline1.p2).x - (semidelline1.p1).x, (semidelline1.p2).y - (semidelline1.p1).y];
   vcross = [p.x - (semidelline1.p1).x, p.y - (semidelline1.p1).y];
   return sum(vsdl*vcross) > 0.0 ? p : [];
}

// Intersection between two semi-delimited lines

func inter_sdl_sdl( semidelline1, semidelline2 )
{
   // Find intersection as if both were unlimited lines
   // and then check for both guide points
   p = inter_l_l( semidelline1, semidelline2 );
   vsdl = [(semidelline1.p2).x - (semidelline1.p1).x, (semidelline1.p2).y - (semidelline1.p1).y];
   vcross = [p.x - (semidelline1.p1).x, p.y - (semidelline1.p1).y];
   if( sum(vsdl*vcross) < 0.0 ) return [];
   vsdl = [(semidelline2.p2).x - (semidelline2.p1).x, (semidelline2.p2).y - (semidelline2.p1).y];
   vcross = [p.x - (semidelline1.p2).x, p.y - (semidelline2.p1).y];
   if( sum(vsdl*vcross) < 0.0 ) return [];
   return p;
}

// Intersection between line and circle

func inter_l_c( line, circle )
{
   a = line.a;
   b = line.b;
   c = line.c;
   p = circle.center.x;
   q = circle.center.y;
   r = circle.radius;

   if( abs(a) > abs(b) ) { // solve for x
      A = a^2 + b^2;
      B = -2*b*b*p - 2*a*c + 2*b*q*a;
      C = c^2 - 2*b*q*c + b^2 * p^2 + b^2 * q^2 - r^2 * b^2;

      D = B^2 - 4*A*C;

      if( D < 0 ) {
         write, "Sorry, no solution";
         return [];
      }
      x = [(-B+sqrt(D))/(2*A), (-B-sqrt(D))/(2*A)];
      y = (c - a*x)/b;
   } else { // solve for y
      A = a^2 + b^2;
      B = -2*a*a*q - 2*b*c + 2*b*p*a;
      C = c^2 - 2*a*p*c + a^2 * p^2 + a^2 * q^2 - r^2 * a^2;

      D = B^2 - 4*A*C;

      if( D < 0 ) {
         write, "Sorry, no solution";
         return [];
      }
      y = [(-B+sqrt(D))/(2*A), (-B-sqrt(D))/(2*A)];
      x = (c - b*y)/a;
   }
   res = array( s_Point, 2 );
   res(*).type = "point";
   res(1).x = x(1);
   res(1).y = y(1);
   res(2).x = x(2);
   res(2).y = y(2);

   return res;

}

// Generic line drawing

func gdraw_line( line, li=, thick=, color=, ends= )
/* DOCUMENT gdraw_line, line, li=, thick=, color=, ends=

    Draws a line whatever type it has.
*/
{
   if( line.type == "line" ) {
      draw_line, line, li=li, thick=thick, color=color;
   } else if( line.type == "delline" ) {
      draw_delline, line, li=li, thick=thick, color=color, ends=ends;
   } else if( line.type == "semidelline" ) {
      draw_semidelline, line, li=li, thick=thick, color=color, ends=ends;
   } else error,"Illegal line type";
}

// Draw a given line on existing window

func draw_line( line, li=, thick=, color= )
{
   if( line.b == 0.0 ) { // vertical x = c/a
      oplot, [1,1]*line.c/line.a, [Inf_my, Inf_py];
   } else if( line.a == 0.0 ) { // horizontal y = c/b
      oplot, [Inf_mx, Inf_px], [1,1]*line.c/line.b;
   } else {
      if( abs(line.a) > abs(line.b) ) {
         y1 = Inf_my;
         x1 = (line.c - line.b * y1)/line.a;
         y2 = Inf_py;
         x2 = (line.c - line.b * y2)/line.a;
      } else {
         x1 = Inf_mx;
         y1 = (line.c - line.a * x1)/line.b;
         x2 = Inf_px;
         y2 = (line.c - line.a * x2)/line.b;
      }
      oplot,[x1,x2],[y1,y2], li=li, thick=thick, color=color;
   }
}

// Draw a given delimited line on existing window

func draw_delline( delline, li=, color=, thick=, ends= )
{
   oplot,[delline.p1.x,delline.p2.x],[delline.p1.y,delline.p2.y], \
      li=li, color=color, thick=thick;
   if( ends ) {
      draw_point, delline.p1, lbl="P1";
      draw_point, delline.p2, lbl="P2";
   }
}

// Draw a given semi-delimited line on existing window

func draw_semidelline( semidelline, li=, color=, thick=, ends= )
{
   d = dist_p_p( semidelline.p1, semidelline.p2 );
   distant_point = [semidelline.p2.x - semidelline.p1.x, semidelline.p2.y - semidelline.p1.y]*Inf_r/d;
   oplot,[semidelline.p1.x,distant_point(1)],[semidelline.p1.y,distant_point(2)], \
      li=li, color=color, thick=thick;
   if( ends ) {
      draw_point, semidelline.p1, lbl="P1";
   }
}

// Draw a polygon on existing window

func draw_polygon( polygon, li=, color=, fill=, thick=, ends= )
/* DOCUMENT draw_polygon, polygon, li=, color=, fill=, thick=, ends=

   'polygon' must be array of struct 's_Point'

   If keyword 'fill' is set then the polygon is filled.
*/
{
   n = numberof( polygon );
   // a side is from point i to point i+1;
   // if i+1 > n then 1 is to be used
   for( i = 1; i <= n; i++ ) {
      i2 = i == n ? 1 : i+1;
      dlinei = delline_p_p(polygon(i), polygon(i2));
      draw_delline, dlinei, li=li, color=color, thick=thick;
      if( ends ) draw_point, polygon(i),lbl="p"+itoa(i);
   }
   if( fill ) poly_fillc, polygon.x, polygon.y,color=color;
}

func draw_point( point, lbl= )
/* DOCUMENT draw_point, point, lbl=

     Keyword 'lbl' can be an integer or a string
*/   
{
   oplot,[point.x],[point.y],ps=12,symsize=0.3;
   if( numberof(lbl) ) {
      if( structof(lbl) == int || structof(lbl) == long ) lbl = itoa(lbl);
      xyouts,point.x,point.y,lbl;
   }
}

func draw_arc( arc, li=, color=, thick=, cnt=, lbl= )
/* DOCUMENT draw_arc, arc, li=, color=, thick=, cnt=, lbl=
*/
{
   draw_circle, arc, li=li, color=color, thick=thick, cnt=cnt, lbl=lbl;
}

func draw_circle( circle, li=, color=, thick=, cnt=, lbl= )
/* DOCUMENT draw_circle, circle, li=, color=, thick=, cnt=, lbl=
       Works also for arc.
*/
{
   if( circle.type == "circle" ) {
      v = span(0,2*pi,100);
   } else if( circle.type == "arc" ) {
      v = span(circle.angle1, circle.angle2, 100)*pi/180.;
   }
   x = circle.radius*cos(v) + circle.center.x;
   y = circle.radius*sin(v) + circle.center.y;


   oplot,x,y,li=li,color=color,thick=thick;
   if( cnt ) {
      draw_point, circle.center, lbl=lbl;
   }
}

func circle2plg( circle, num )
{
   if( is_void(num) ) num = 100;
   v = span(0,2*pi,num+1)(1:-1); // avoid repetition
   p = array(s_Point,num);
   p(*).type = "point";
   p.x = circle.radius*cos(v) + circle.center.x;
   p.y = circle.radius*sin(v) + circle.center.y;
   return p;
}

func inter_c_c( circ1, circ2 )
{

   extern Circ1, Circ2;

   x1 = circ1.center.x;
   y1 = circ1.center.y;
   r1 = circ1.radius;

   x2 = circ2.center.x;
   y2 = circ2.center.y;
   r2 = circ2.radius;

   window, 0;

   xmx = max([circ1.center.x+circ1.radius, circ2.center.x+circ2.radius]);
   xmn = max([circ1.center.x-circ1.radius, circ2.center.x-circ2.radius]);
   ymx = max([circ1.center.y+circ1.radius, circ2.center.y+circ2.radius]);
   ymn = max([circ1.center.y-circ1.radius, circ2.center.y-circ2.radius]);
   range = 0.6*max([xmx-xmn,ymx-ymn]);
   u = [-1,1];
   plot,range*u,range*u,ps=1;
   draw_circle, circ1, cnt=1, lbl="C_1";
   draw_circle, circ2, cnt=1, lbl="C_2";

   d = sqrt((x1-x2)^2 + (y1-y2)^2);
   if( d > r1 + r2 ) {
      write,"Sorry, no solution, circles too far apart";
      return [];
   }
   if( d < abs(r1 - r2) ) {
      write,"Sorry, no solution, one circle completely inside the other";
      return [];
   }

   Circ1 = circ1;
   Circ2 = circ2;

   // angles for min and max

   vmax = zero2pi(atan(y1-y2,x1-x2));
   vmin = zero2pi(vmax + pi);

   v = span(0,2*pi,1000);
   dcder, v, dc, ddcdv;
   dcder, vmax, dcmax, ddcdvmax;
   dcder, vmin, dcmin, ddcdvmin;

   window,1;
   plot,v,dc;

   oplot, [vmax],[dcmax],ps=3;
   oplot, [vmin],[dcmin],ps=4;

   window,0;

   v0 = nraphson( dcder, vmin, vmax, 1.e-10 );
   s1 = s_Point(type="point", x=circ1.radius*cos(v0)+circ1.center.x, \
                y=circ1.radius*sin(v0)+circ1.center.y);
   draw_point,s1,lbl="S_1";
   l = line_p_p(circ1.center, circ2.center);
   s2 = mirror_p_l( s1, l );
   draw_point,s2,lbl="S_2";

   solut = array( s_Point, 2 );
   solut(*).type = "point";
   solut(1) = s1;
   solut(2) = s2;

   return solut;

}

func dcder( v, &dc, &ddcdv )
/* DOCUMENT dcder, angle, >dc, >ddcdv

     returns the smallest distance between a point on circle1 (given by
     the angle 'angle' (in radians)) and the closest point on circle2
     - positive if outside circle1 and negative if inside
     as the second parameter and its derivative as the third parameter.
     This is compatible with the 'nraphson' root-finding function.

     Externals Circ1 and Circ2 must be defined beforehand.

     2008-08-01/NJW
*/
{

      extern Circ1, Circ2;

      cv = cos(v);
      sv = sin(v);
      x = Circ1.radius*cv + Circ1.center.x;
      y = Circ1.radius*sv + Circ1.center.y;
      g = (x-Circ2.center.x)^2 + (y-Circ2.center.y)^2;
      dc = sqrt(g) - Circ2.radius;
      dgdv = -2*Circ1.radius*sv*(Circ1.radius*cv + Circ1.center.x - Circ2.center.x) \
           +  2*Circ1.radius*cv*(Circ1.radius*sv + Circ1.center.y - Circ2.center.y);
      ddcdv = 0.5*dgdv/sqrt(g);
}

// Intersections between line and polygon

func inter_l_plg( line, polygon )
{
   n = numberof(polygon);
   qq = [];
   for( i = 1; i <= n; i++ ) {
      i2 = i == n ? 1 : i+1;
      dlinei = delline_p_p(polygon(i), polygon(i2));
      q = inter_dl_l( dlinei, line );
      if( !is_void(q) ) grow, qq, q;
   }
   return qq;
}

// Intersections between delimited line and polygon

func inter_dl_plg( delline, polygon )
{
   n = numberof(polygon);
   qq = [];
   for( i = 1; i <= n; i++ ) {
      i2 = i == n ? 1 : i+1;
      dlinei = delline_p_p(polygon(i), polygon(i2));
      q = inter_dl_dl( dlinei, delline );
      if( !is_void(q) ) grow, qq, q;
   }
   return qq;
}

// Hatch an area defined by a polygon

func hatch( polygon, angle, dist, color=, li=, thick=, wor= )
/* DOCUMENT hatch, polygon, angle, dist, color=, li=, thick=, wor=

   Draws a hatched polygon (array of struct 's_Point'). Hatch lines are tilted an
   'angle' (in degrees) with respect to horizontal. Their distance are given by
   'dist'.

   Keyword 'wor' is to be set if the polygon is given in
    'world coordinates'

   Other keywords are as for 'plot'.
*/
{
   local ndc_ply, wqq;

   if( !verify_plg(polygon) ) {
      write,"The polygon could not be verified - do nothing";
      return;
   }
   if( angle > 89. || angle < -89. ) {
      write,"Angle not in acceptable range - do nothing";
      return;
   }

   if( wor ) {
      gcoord_conv, polygon, ndc_ply, from="wor", to="ndc";
      polyg = ndc_ply;
   } else polyg = polygon;

   // Get extremes of polygon i.e. enclosing rectangle
   n = numberof( polyg );
   xmax = max(polyg.x);
   xmin = min(polyg.x);
   ymax = max(polyg.y);
   ymin = min(polyg.y);
   recta = box2plg( xmin, xmax, ymin, ymax );
   //+ recta = array(s_Point,4);
   //+ recta(*).type = "point";
   //+ recta(1).x = xmax;
   //+ recta(1).y = ymin;
   //+ recta(2).x = xmin;
   //+ recta(2).y = ymin;
   //+ recta(3).x = xmin;
   //+ recta(3).y = ymax;
   //+ recta(4).x = xmax;
   //+ recta(4).y = ymax;

   p = s_Point();
   p.type = "point";
   if( angle >= 0.0 ) {
      p.x = xmax;
      p.y = ymin;
   } else {
      p.x = xmin;
      p.y = ymin;
   }
   l = line_p_angle( p, angle );
   norm = sqrt(l.a^2 + l.b^2);
   dx = dist*l.a/norm;
   dy = dist*l.b/norm;



   do {

      p.x += dx;
      p.y += dy;
      l = line_p_angle( p, angle );
      qrect = inter_l_plg( l, recta );

      // get the intersections between line and polygon

      qq = inter_l_plg( l, polyg );
      nqq = numberof(qq);
      if( nqq == 0 ) continue;
      if( nqq%2 == 1 ) error,"odd number of intersections with polygon";
      // sort according x value
      is = sort(qq.x);
      qq = qq(is);

      if( wor ) {
         gcoord_conv, qq, wqq, from="ndc", to="wor";
      } else wqq = qq;

      for(i = 1; i <= nqq/2; i++ ) {
         oplot,[wqq(2*(i-1)+1).x,wqq(2*(i-1)+2).x], \
               [wqq(2*(i-1)+1).y,wqq(2*(i-1)+2).y], \
               color=color, li=li, thick=thick;
      }

   } while( numberof(qrect) );

}

func box2plg( xmin, xmax, ymin, ymax )
/* DOCUMENT b = box2plg( xmin, xmax, ymin, ymax )

    returns a 4-apex polygon.
*/
{
   recta = array(s_Point,4);
   recta(*).type = "point";
   recta(1).x = xmax;
   recta(1).y = ymin;
   recta(2).x = xmin;
   recta(2).y = ymin;
   recta(3).x = xmin;
   recta(3).y = ymax;
   recta(4).x = xmax;
   recta(4).y = ymax;
   return recta;
}

/* Function gcoord_conv */

func gcoord_conv( ply_in, &ply_out, from=, to= )
/* DOCUMENT gcoord_conv, ply_in, >ply_out, from=, to=

   Convert coordinates between NDC (Normalized Device Coordinates)
   keyword value "ndc", virtual coordinates (keyword value "vir")
   and world (i.e. data space) (keyword value "wor") coordinates.
   The (A4) device coordinates have been expanded by a factor of
   sqrt(2) in the y direction compared to NDC. [not implemented]

   Input and result is a polygon i.e. array of struct s_Point

   2009-03-19/NJW cloned from mcoord_conv of package 'plot.i'
*/
{
   if( is_void(from) ) {
      write,"Keyword 'from' not defined";
      return;
   }
   if( is_void(to) ) {
      write,"Keyword 'to' not defined";
      return;
   }
   // avoid changing input coords
   ply = ply_in;

   v = viewport()(1:4);
   w = limits()(1:4);
   wind = 1 + window();
   local xlog, ylog;
   mlogxy, xlog, ylog, get=1;

   from = strlowcase(from);
   to = strlowcase(to);
   if( from == "ndc" ) fco = v;
   if( from == "vir" ) fco = [0.,1.,0.,1.];
   if( from == "wor" ) fco = w;
   if( to == "ndc" ) tco = v;
   if( to == "vir" ) tco = [0.,1.,0.,1.];
   if( to == "wor" ) tco = w;

   if( from == "wor" ) {
      // World to linear
      if( xlog ) {
         fco(1) = log(fco(1));
         fco(2) = log(fco(2));
         ply.x = log(ply.x);
      }
      if( ylog ) {
         fco(3) = log(fco(3));
         fco(4) = log(fco(4));
         ply.y = log(ply.y);
      }
   }
   if( to == "wor" ) {
      // linear to world
      if( xlog ) {
         tco(1) = log(tco(1));
         tco(2) = log(tco(2));
      }
      if( ylog ) {
         tco(3) = log(tco(3));
         tco(4) = log(tco(4));
      }
   }
   ply_out = ply_in;
   fac = (ply.x - fco(1))/(fco(2)-fco(1));
   ply_out.x = tco(1) + fac*(tco(2) - tco(1));
   fac = (ply.y - fco(3))/(fco(4) - fco(3));
   ply_out.y = tco(3) + fac*(tco(4) - tco(3));

   if( to == "wor" ) {
      if( xlog ) ply_out.x = exp(ply_out.x);
      if( ylog ) ply_out.y = exp(ply_out.y);
   }

   return;
}

// Translate a polygon

func translate_plg( polygon, dx, dy )
/* DOCUMENT new_plg = translate_plg( polygon, dx, dy )
            new_plg = translate_plg( polygon, vector )
*/
{
   if( typeof(dx) == "struct_instance" ) {
      if( dx.type != "vector" ) error,"Illegal argument";
      dy = dx.y;
      dx = dx.x;
   }
   n = numberof(polygon);
   r = polygon;
   for( i = 1; i <= n; i++ ) {
      r(i).x += dx;
      r(i).y += dy;
   }
   return r;
}

// Rotate a polygon

func rotate_plg( polygon, angle )
/* DOCUMENT  plg = rotate_plg( polygon, angle )
     Where angle is in degrees. The axis of rotation is the average position.
*/
{
   n = numberof(polygon);
   res = polygon;
   cen = s_Point();
   cen.x = avg(polygon.x);
   cen.y = avg(polygon.y);
   an = angle*pi/180.;
   can = cos(an); san = sin(an);
   for( i = 1; i <= n; i++ ) {
      v = vec_p_p(cen,polygon(i));
      x = v.x * can - v.y * san;
      y = v.x * san + v.y * can;
      res(i).x = cen.x + x;
      res(i).y = cen.y + y;
   }

   return res;
}


// Decide if a given point is inside a polygon

func inside_plg( pnt, polyg )
/* DOCUMENT ans = inside_plg( pnt, polyg )

   returns 1 if pnt is inside polyg and 0 otherwise
*/
{
   if( !verify_plg(polyg) ) {
      write,"The polygon could not be verified - do nothing";
      return [];
   }
   // First determine a point that is definitely inside
   // by checking the diagonals of the enclosing box
   // Get extremes of polygon i.e. enclosing rectangle
   n = numberof( polyg );
   eps = 1.e-3;
   xmax = max(polyg.x) + eps;
   xmin = min(polyg.x) - eps;
   ymax = max(polyg.y) + eps;
   ymin = min(polyg.y) - eps;
   recta = box2plg( xmin, xmax, ymin, ymax );
   if( pnt.x < xmin ) return 0;
   if( pnt.x > xmax ) return 0;
   if( pnt.y < ymin ) return 0;
   if( pnt.y > ymax ) return 0;

   ll = xy2point(xmin,ymin);
   ur = xy2point(xmax,ymax);
   diagonal = line_p_p( ll, ur );
   // get the intersections between diagonal and polygon
   qq = inter_l_plg( diagonal, polyg );
   nqq = numberof(qq);
   if( nqq > 0 ) {
      if( nqq%2 == 1 ) error,"odd number of intersections with polygon";
      // sort according x value
      is = sort(qq.x);
      qq = qq(is);
      pinside = xy2point( 0.5*(qq(1).x + qq(2).x), 0.5*(qq(1).y + qq(2).y ) );
      draw_point,pinside,lbl="A1";
   } else {
      ul = xy2point(xmin,ymax);
      lr = xy2point(xmax,ymin);
      diagonal = line_p_p( ll, ur );
      // get the intersections between diagonal and polygon
      qq = inter_l_plg( diagonal, polyg );
      nqq = numberof(qq);
      if( nqq > 0 ) {
         if( nqq%2 == 1 ) error,"odd number of intersections with polygon";
         // sort according x value
         is = sort(qq.x);
         qq = qq(is);
         pinside = xy2point( 0.5*(qq(1).x + qq(2).x), 0.5*(qq(1).y + qq(2).y ) );
      draw_point,pinside,lbl="A2";
      } else error,"##43##";
   }

   // define line connecting the given point and the inside point

   lcon = delline_p_p( pnt, pinside );
   qq = inter_dl_plg( lcon, polyg );
   nqq = numberof(qq);
   return (nqq+1)%2;
}

//   Draw an arrow

func draw_garrow( point1, point2, sw, hw, hl, color=, fill=, thick=, tri= )
/* DOCUMENT draw_garrow, point1, point2, sw, hw, hl, color=, fill=, thick=, tri=

     Uses function 'draw_arrow' to draw an arrow from point1 to point2.

     Arguments: sw   stem width in NDC coordinates
                hw   head width
                hl   head length

     Keywords:  color, thick   standard
                tri   for triangular arrowhead
                fill  for filled arrow
*/
{
   if( point1.type != "point" ) error,"Illegal point1 argument";
   if( point2.type != "point" ) error,"Illegal point2 argument";
   draw_arrow, point1.x, point1.y, point2.x, point2.y, sw, hw, hl, \
                color=color, fill=fill, thick=thick, tri=tri;
}
%FILE% get_count_rate.i
func get_count_rate( arffile, emin=, emax=, photflux= )
{
   local ener, arf;

   if( is_void(photflux) ) {
      mk_photflux,nof=1;
   } else {
      rd_photflux, photflux;
   }
   // now we have Eline, Flux, Sx_photflux

   if( is_void(emin) ) emin = Eline(1);
   if( is_void(emax) ) emax = Eline(0);
   w = where( Eline >= emin & Eline <= emax );

   rd_arf, arffile, ener, arf;

   arf = interp(arf, ener, Eline);

   return sum((Flux(w)(zcen))*(arf(w)(zcen))*(Eline(w)(dif)));

}
%FILE% get_imatype.i
func get_imatype( fitsname, imatype, num )
/* DOCUMENT extno = get_imatype( fitsname, imatype, num )

     Returns the extension number where the num'th of
     requested IMATYPE appears. Returns nill if not found.
*/
{
   n = nfits_extens( fitsname );
   if( is_void(num) ) num = 1;
   imatype = strupcase(strpart(imatype,1:5));

   count = 0;
   for( i = 1; i <= n; i++ ) {
      hdr = headfits( fitsname+"+"+itoa(i) );
      imtyp = fxpar( hdr, "IMATYPE" );
      if( is_void(imtyp) ) continue;
      imtyp = strpart(imtyp,1:5);
      if( imtyp == imatype ) { // right extension, check the number
         count++;
         if( count == num ) return i;
      }
   }

   // checked all extensions without a hit - return void

   return [];
}
%FILE% get_list_of_externs.i
func get_list_of_externs( filename )
{
   // get rid of all /* */ comments
   system,"c_rm_comment "+filename;
   // now filename+"nc" exists
   ncfilename = filename+"nc";
   // then get text cleaned for // comments
   text = rm_slashcom(ncfilename);
   ntext = numberof(text);
   list = [];

   for( i = 1; i <= ntext; i++ ) {
      wds = str_get_words( text(i), skip='"' );
      if( is_void(wds) ) continue;

      if( wds(1) == "extern" ) { // open for closer inspection
         grow, list, wds(2:0);
         // Are we done?
         pos = strpos(text(i),";");
         while( !pos ) { // apparently not - go on
            i++;
            wds = str_get_words( text(i), skip='"' );
            if( !is_void(wds) ) grow, list, wds;
            pos = strpos(text(i),";");
         }
      }
   }
   remove, ncfilename;
   return list;
}
%FILE% get_mikes_scat_frac.i
/* Function get_mikes_scat_frac */

func get_mikes_scat_frac( energy, angle )
/* DOCUMENT frac = get_mikes_scat_frac( energy, angle )

      Returns the scattered fraction for the given energy (in keV)
      and angle (in radians).
      Saves the table in external variables: Mikes_scat_arr, Mikes_ener, and Mikes_ang

   2012-03-02/NJW
*/
{
   extern Mikes_scat_arr, Mikes_ener, Mikes_ang;

   if( numberof(Mikes_scat_arr) < 1216 ) {
      write,"Reading table ...";
      Mikes_scat_arr = rsmat( "/home/njw/nustar/BNL_data/Mikes_NuSTAR_scatter_table_120302.txt" , silent=1 );
      Mikes_ang = Mikes_scat_arr(1,2:0)*1.e-3; // convert to radians
      Mikes_ener = Mikes_scat_arr(,1)(2:0); // keV
      Mikes_scat_arr = Mikes_scat_arr(2:0,2:0);
   }
   return interp2( Mikes_scat_arr, Mikes_ener, Mikes_ang, energy, angle );
}
%FILE% get_numbers_from_figure.i
/* Function get_numbers_from_figure */

func get_numbers_from_figure( axis )
/* DOCUMENT get_numbers_from_figure, axis

    Saves result into external variables:
       COOR_1, MEAS_1  for axis 1
       COOR_2, MEAS_2  for axis 2

   If a change in measured values has been done then a recalculation
   can be done by function 'recalc' (no arguments).

   Other external variables:
          ITYPE_1, COORFIX1_1, COORFIX2_1, MEASFIX1_1, MEASFIX2_1
          ITYPE_2, COORFIX1_2, COORFIX2_2, MEASFIX1_2, MEASFIX2_2


*/
{
   extern COOR_1, ITYPE_1, COORFIX1_1, COORFIX2_1, MEASFIX1_1, MEASFIX2_1;
   extern COOR_2, ITYPE_2, COORFIX1_2, COORFIX2_2, MEASFIX1_2, MEASFIX2_2;
   extern MEAS_1, MEAS_2;

   write,"Set the scale";
   s = rdline(prompt="Linear (0) or log (1) scale ? ... ");
   itype = atoi(s);
   s = rdline(prompt="Enter two coordinate fix points ... ");
   t = strsplit(s," ");
   c1 = atof(t(1));
   c2 = atof(t(2));
   s = rdline(prompt="Enter two measures of fix points ... ");
   t = strsplit(s," ");
   m1 = atof(t(1));
   m2 = atof(t(2));

   if( axis == 1 ) {
      ITYPE_1 = itype;
      COORFIX1_1 = c1;
      COORFIX2_1 = c2;
      MEASFIX1_1 = m1;
      MEASFIX2_1 = m2;
   }
   if( axis == 2 ) {
      ITYPE_2 = itype;
      COORFIX1_2 = c1;
      COORFIX2_2 = c2;
      MEASFIX1_2 = m1;
      MEASFIX2_2 = m2;
   }
   i = 1;
   val = [];
   mes = [];
   do {
      s = rdline(prompt="Enter measure of point "+itoa(i)+": ... ");
      l = strlen(s);
      if( l ) {
         m = atof(s);
         grow, mes, m;
         if( itype ) { // log scale
            c = exp(log(c1)+(m-m1)*(log(c2)-log(c1))/(m2-m1));
         } else {      // lin scale
            c = c1+(m-m1)*(c2-c1)/(m2-m1);
         }
         grow, val, c;
         i++;
      }
   } while( l );

   if( axis == 1 ) {
      COOR_1 = val;
      MEAS_1 = mes;
   }
   if( axis == 2 ) {
      COOR_2 = val;
      MEAS_2 = mes;
   }
}

/* Function recalc */

func recalc
{
   
   extern COOR_1, ITYPE_1, COORFIX1_1, COORFIX2_1, MEASFIX1_1, MEASFIX2_1;
   extern COOR_2, ITYPE_2, COORFIX1_2, COORFIX2_2, MEASFIX1_2, MEASFIX2_2;
   extern MEAS_1, MEAS_2;

   // Do axis #1
   if( ITYPE_1 ) { // log scale
      COOR_1 = exp(log(COORFIX1_1)+(MEAS_1-MEASFIX1_1)*(log(COORFIX2_1)-log(COORFIX1_1))/(MEASFIX2_1-MEASFIX1_1));
   } else {      // lin scale
      COOR_1 = COORFIX1_1+(MEAS_1-MEASFIX1_1)*(COORFIX2_1-COORFIX1_1)/(MEASFIX2_1-MEASFIX1_1);
   }
   // Do axis #2
   if( ITYPE_2 ) { // log scale
      COOR_2 = exp(log(COORFIX1_2)+(MEAS_2-MEASFIX1_2)*(log(COORFIX2_2)-log(COORFIX1_2))/(MEASFIX2_2-MEASFIX1_2));
   } else {      // lin scale
      COOR_2 = COORFIX1_2+(MEAS_2-MEASFIX1_2)*(COORFIX2_2-COORFIX1_2)/(MEASFIX2_2-MEASFIX1_2);
   }
}

/* Function cur_get_numbers_from_figure */

func cur_get_numbers_from_figure
/* DOCUMENT cur_get_numbers_from_figure

    Saves result into external variables:
       COOR_1, MEAS_1  for axis 1
       COOR_2, MEAS_2  for axis 2

   If a change in measured values has been done then a recalculation
   can be done by function 'recalc' (no arguments).

   Other external variables:
          ITYPE_1, COORFIX1_1, COORFIX2_1, MEASFIX1_1, MEASFIX2_1
          ITYPE_2, COORFIX1_2, COORFIX2_2, MEASFIX1_2, MEASFIX2_2


*/
{
   extern COOR_1, ITYPE_1, COORFIX1_1, COORFIX2_1, MEASFIX1_1, MEASFIX2_1;
   extern COOR_2, ITYPE_2, COORFIX1_2, COORFIX2_2, MEASFIX1_2, MEASFIX2_2;
   extern MEAS_1, MEAS_2;

   write,"Set the scales";
   s = rdline(prompt="Linear (0) or log (1) scale ? Two values for x y ... ");
   t = strsplit(s," ");
   itypex = atoi(t(1));
   itypey = atoi(t(2));
   s = rdline(prompt="Enter two coordinate fix points for the X axis ... ");
   t = strsplit(s," ");
   c1x = atof(t(1));
   c2x = atof(t(2));
   s = rdline(prompt="Enter two coordinate fix points for the Y axis ... ");
   t = strsplit(s," ");
   c1y = atof(t(1));
   c2y = atof(t(2));
   r = curmark1(prompt="Mark the lower left fix point ... ");
   m1x = r(1);
   m1y = r(2);
   r = curmark1(prompt="Mark the upper right fix point ... ");
   m2x = r(1);
   m2y = r(2);

   ITYPE_1 = itypex;
   COORFIX1_1 = c1x;
   COORFIX2_1 = c2x;
   MEASFIX1_1 = m1x;
   MEASFIX2_1 = m2x;

   ITYPE_2 = itypey;
   COORFIX1_2 = c1y;
   COORFIX2_2 = c2y;
   MEASFIX1_2 = m1y;
   MEASFIX2_2 = m2y;

   //  Enter all the points


   r = curmark(ps=12,symsize=0.3);

   MEAS_1 = r(1::2);
   MEAS_2 = r(2::2);

   recalc;

   write,"Please find coordinates in COOR_1 and COOR_2 external variables.";
}
%FILE% get_plot_char_sizes.i
print_chars = [33, 34, 35, 37, 38, 47, 40, 41, 61, 63, 64, 36,126,    123,125, \
               91, 93, 43,124, 39, 42, 45,     46, 48, 49, 50, 51, 52, 53, 54, \
               55, 56, 57, 58, 44, 59, 60, 62, 92, 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, 97, 98, 99,100,101,102,103, \
              104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119, \
              120,121,122];
// 'hat' is character 94 avoided in the first round
// 'underscore' is character 95 avoided in the first round
//  for their special meaning for the Yorick text output

nprint = numberof(print_chars);
f = open("char_sizes.scm","a");

h_arr = [8,10,12,14,16,18,24,36];
h_case = 6;
ntest = h_case > 5 ? 10 : 20;

write,f,format="// block = %i\n", h_case;
write,f,format="// height = %i\n", h_arr(h_case);

for( i = 1; i <= nprint; i++ ) {
   c = print_chars(i);
   plot,[-1],xr=[0,1],yr=[0,1];
   p = array(char(c),ntest);
   sp = string(&p);
   mcoord_conv, 0.2,0.5, llxwor, llywor, from="ndc", to="wor";
   plt,sp,0.2,0.5,height=h_arr(h_case);
   oplot,[llxwor],[llywor],ps=12;
   cur = curmark1();
   write,format="cursor position wor: %.3f %.3f\n", cur(1), cur(2);
   mcoord_conv, cur(1), cur(2), lrxndc, lryndc, from="wor", to="ndc";
   write,format="cursor position ndc: %.3f %.3f\n", lrxndc, lryndc;

   write,format="char horizontal size : %.6f in NDC units\n", \
      (lrxndc-0.2)/ntest;
   write,f,format="  %4i  %.6f\n", c, (lrxndc-0.2)/ntest;
}
close, f;
%FILE% get_plot_char_sizes_n.i
print_chars = [48,49,50,51,52,53,54,55,56,57];
// 'hat' is character 94 avoided in the first round
// 'underscore' is character 95 avoided in the first round
//  for their special meaning for the Yorick text output

nprint = numberof(print_chars);
f = open("char_sizes_n.scm","a");

h_arr = [8,10,12,14,16,18,24,36];
h_case = 8;
ntest = h_case > 5 ? 10 : 20;

write,f,format="// block = %i\n", h_case;
write,f,format="// height = %i\n", h_arr(h_case);

for( i = 1; i <= nprint; i++ ) {
   c = print_chars(i);
   plot,[-1],xr=[0,1],yr=[0,1];
   p = array(char(c),ntest);
   sp = string(&p);
   mcoord_conv, 0.2,0.5, llxwor, llywor, from="ndc", to="wor";
   plt,sp,0.2,0.5,height=h_arr(h_case);
   oplot,[llxwor],[llywor],ps=12;
   cur = curmark1();
   write,format="cursor position wor: %.3f %.3f\n", cur(1), cur(2);
   mcoord_conv, cur(1), cur(2), lrxndc, lryndc, from="wor", to="ndc";
   write,format="cursor position ndc: %.3f %.3f\n", lrxndc, lryndc;

   write,format="char horizontal size : %.6f in NDC units\n", \
      (lrxndc-0.2)/ntest;
   write,f,format="  %4i  %.6f\n", c, (lrxndc-0.2)/ntest;
}
close, f;
%FILE% get_pmap.i
/* Function get_pmap */

func get_pmap( xsrc, ysrc, &xpmap, &ypmap )
/* DOCUMENT pmap = get_pmap( xsrc, ysrc, >xpmap, >ypmap )

   returns a 100x100 map of NDC positions with a value
   the higher the more preferred.
   Arguments x(y)pmap get the axis arrays in NDC.

*/
{
   // NDC window limits
   vp = viewport();

   xpmap = span(vp(1),vp(2),101)(zcen);       // pixel centers
   ypmap = span(vp(3),vp(4),101)(zcen);       // pixel centers

/*
 *  Position map
 *      high value: a preferable position
 *      negative value: a forbidden position
 */

   pmap = array(double,100,100);

   yroof = 1.0 * abs(ypmap-ysrc);
   pmap += max(yroof) - yroof(-,);
   xroof = 1.0 * abs(xpmap-xsrc);
   pmap += max(xroof) - xroof(,-);

   // regions below the source are less preferred

   w = where(ypmap < ysrc);
   if(numberof(w)) pmap(,w) *= 0.7;

   return pmap;

}
%FILE% get_runnumber.i
func get_runnumber( str )
{
   // Assume a 5 digit number following 'Run' in string 'str'
   pos = strpos(str,"Run");
   if( !pos ) error,"Did not find 'Run'";
   return atoi(strpart(str,pos+3:pos+7));
}
%FILE% get_slit.i
/*****************************************************
 *
 *  Get slit position etc. for given run number
 *
 *  Functions:
 *      get_slit     - returns a struct
 *      nevparse     - a parsing (return of integer) function
 *      get_position - return a motor position
 *
 *****************************************************/

struct s_Slit {
   double blade(4); // Blade [xmin, xmax, ymin, ymax]
   double yaw;      // Yaw in mdeg
   double roll;     // Roll in deg
   long sector;     // Sector number 1 thru 6
   long subgroup;   // Subgroup number
   string detector; // Detector name
}

func get_slit( run_number, chat= )
/* DOCUMENT r = get_slit( run_number, chat= )

    reads the Nevis command log in /home/njw/nustar/nevis_log and
    returns a struct with elements:
             double blade(4); // Blade [xmin, xmax, ymin, ymax]
             double yaw;      // Yaw in mdeg
             double roll;     // Roll in deg
             long sector;     // Sector number 1 thru 6
             long subgroup;   // Subgroup number
             string detector; // Detector name

   A run_number of zero will provoke a re-reading of the text file
   and definition of rno_directory and wrno.
*/
{
   extern command_log_text, rno_directory, wrno;

   if( run_number == 0 ) {
      command_log_text = rno_directory = wrno = [];
   }

   if( is_void(command_log_text) ) {
      write,"Reading /home/njw/nustar/nevis_log/CommandLog.txt ...";
      command_log_text = rdfile("/home/njw/nustar/nevis_log/CommandLog.txt");
   }
   nlines = numberof(command_log_text);

   if( is_void(rno_directory) || is_void(wrno) ) {
      write,"Setting wrno and rno_directory ...";
      wrno = where(strmatch(command_log_text,"RUN#"));
      nwrno = numberof(wrno);
      rno_directory = array(long,nwrno);
      for( i = 1; i <= nwrno; i++ ) {
         rno_directory(i) = atoi(strsplit(command_log_text(wrno(i))," ")(0))
      }
      // You get the line number:  lineno = wrno(where(rno_directory == your_run_number))
   }

   if( run_number == 0 ) return [];

   res = s_Slit();

   z = where(rno_directory == run_number);
   if( numberof(z) == 0 ) {
      write,"No such run number found!";
      return [];
   }

   lineno = wrno(z)(1);
   if( chat ) write,"Found line: "+command_log_text(lineno);

   // Locate most recent detector indicator

   for( i = lineno-1; i > 0; i-- ) {
      posge = strpos(command_log_text(i),"ELOG GE");
      if( posge > 0 ) {
         if( chat ) write,"Found Ge detector line "+command_log_text(i);
         res.detector = "Ge";
         break; // no need to check for SDD
      } // did not find Ge detector in this line, try SDD
      possdd = strpos(command_log_text(i),"ELOG SDD");
      if( possdd > 0 ) {
         if( chat ) write,"Found SDD detector line "+command_log_text(i);
         res.detector = "SDD";
         break;
      }
   }
   if( i == 0 ) error,"##1##";

   // Locate subgroup and sector

   for( i = lineno-1; i > 0; i-- ) {
      pos = strpos(command_log_text(i),"ELOG SG");
      if( pos > 0 ) {
         if( chat ) write,"Found subgroup line "+command_log_text(i);
         pose = strpos(command_log_text(i)," ",pos+7);
         subgroup = atoi(strpart(command_log_text(i),pos+7:pose-1));
         p = strpos(command_log_text(i),"SECTOR");
         if( p > 0 ) {
            sector = atoi(strsplit(command_log_text(i)," ")(0));
            if( chat ) write,"Found sector "+itoa(sector);
         } else {
            if( chat ) write,"Did not find sector";
            sector = 0;
         }
         break;
      }
   }
   if( i == 0 ) error,"##2##";
   res.sector = sector;
   res.subgroup = subgroup;

   // Locate optic axis azimuth and current value

   for( i = lineno-1; i > 0; i-- ) {
      pos = strpos(command_log_text(i),"OPTIC AXIS ASSUMED");
      if( pos > 0 ) {
         if( chat ) write,"Found optic axis line "+command_log_text(i);
         p = strpos(command_log_text(i),"AZ =");
         if( p > 0 ) {
            az_optic_axis = nevparse( command_log_text(i),p+3);
            if( chat ) write,"Found az optic axis: "+itoa(az_optic_axis);
         } else {
            if( chat ) write,"Did not find az optic axis";
            az_optic_axis = -999;
         }
         break;
      }
   }
   if( i == 0 ) error,"##3##";

   for( i = lineno-1; i > 0; i-- ) {
      pos = strpos(command_log_text(i),"OPTIC MOVED");
      if( pos > 0 ) {
         if( chat ) write,"Found optic moved line "+command_log_text(i);
         p = strpos(command_log_text(i),"AZ =");
         if( p > 0 ) {
            az_optic_pos = nevparse( command_log_text(i),p+3);
            if( chat ) write,"Found az optic position: "+itoa(az_optic_pos);
         } else {
            if( chat ) write,"Did not find az optic position";
            az_optic_pos = -999;
         }
         break;
      }
   }
   if( i == 0 ) error,"##4##";

   // Determine yaw angle as optic position - optic axis

   res.yaw = double(az_optic_pos - az_optic_axis); // Unit is mdeg



   // Locate most recent slit position (motor #15)

   su_pos = get_position( lineno, 15, chat=chat );

   // Get the lower and upper blade position in x (motor# 10 & 9)

   lbx_pos = get_position( lineno, 10, chat=chat );
   ubx_pos = get_position( lineno, 9, chat=chat );

   // Get the lower and upper blade position in y (motor# 8 & 7)

   lby_pos = get_position( lineno, 8, chat=chat );
   uby_pos = get_position( lineno, 7, chat=chat );

   res.blade(1) = su_pos + lbx_pos;
   res.blade(2) = su_pos + ubx_pos;
   res.blade(3) =   0.0  + lby_pos;
   res.blade(4) =   0.0  + uby_pos;

   // Get the roll angle

   roll = get_position( lineno, 3, chat=chat );
   res.roll = roll;

   return res;
}

func get_position( lineno, motor, chat= )
{
   extern command_log_text;

   smotor = itoa( motor );

   for( i = lineno-1; i > 0; i-- ) {
      pos = strpos(command_log_text(i),"SETPOS "+smotor+" ");
      if( pos > 0 ) {
         if( chat ) write,"Found motor#"+smotor+" position: "+command_log_text(i);
         pos = atoi(strsplit( command_log_text(i), " " )(0));
         pos_mm = pos / 1000.;
         if( chat ) write,"  -  translates to "+ftoa(pos_mm,ndec=2)+" mm";
         break;
      }
   }

   if( i ) return pos_mm;
   if( chat ) write,"Did not find this motor: "+smotor;
   return [];
}

func nevparse( str, pos )
{
   // Assume string like: ...ABC 22 KLM ...
   // where 'pos' points to 'A'
   // Then the following number will be returned (enclosed in blanks)

   len = strlen(str);
   i = pos;
   while( strpart(str,i:i) != " " ) i++;
   while( strpart(str,i:i) == " " ) i++;
   j = i;
   c = strpart(str,j:j);
   while( c == "-" || c == "+" || is_digit(c) ) {
      j++;
      if( j > len ) break;
      c = strpart(str,j:j);
   }
   return atoi( strpart(str,i:j-1) );
}
%FILE% get_xspec_fit_params.i
struct s_Parval {
   int model;
   string component;
   string name;
   string unit;
   double value;
   string status;
   double value_err;
}
struct s_Fitqual {
   int dof;
   double red_chi2;
}

func get_xspec_fit_params( xspec_log_file, &fitqual, flux=, outfile=, silent= )
/* DOCUMENT get_xspec_fit_params, xspec_log_file, >fitqual, flux=, outfile=, silent=
    or      res = get_xspec_fit_params( xspec_log_file, flux=, outfile=, silent= )

   Assumes that the fitting parameters are found between a line with
     =================
   and
     _________________

  Extract power law fitting parameters from XSPEC logfile

  Returns an array of structs 's_Parval' with elements:
     model, component, name, unit, value, value_err, status

  and a struct 'fitqual' with elements red_chi2 and dof.

  If the keyword 'flux' is set then it returns a 5x2-element array where
  the flux is the last number.

 2004-06-03/NJW, original IDL version
 2008-08-12/NJW translated to Yorick
 2011-03-31/NJW updated with keyword 'flux'
 2013-01-18/NJW More general version
*/
{


   logfile = xspec_log_file;

   flag = typeof( outfile ) == "string";
   if( flag ) lun = open( outfile,"a");
   
   
   lines = rdfile(logfile);
   nlines = numberof(lines);
   
   // Search for the presence of "======================="

   idx1 = where(strmatch(lines,"================================"));
   idx2 = where(strmatch(lines,"________________________________"));
   nidx1 = numberof(idx1);
   if( nidx1 != numberof(idx2) ) error,"##1##";

   nparams = idx2(0) - idx1(0) - 4;
   idx1 = idx1(0) + 4;
   idx2 = idx2(0) - 1;
   if(!silent)prstrarr, lines(idx1:idx2+10);

   // Locate 'Reduced chi-squared' following the parameter list

   fitqual = s_Fitqual();
   idx3 = where(strmatch(lines(idx2+2:0),"Reduced chi-squared"));
   if( numberof(idx3) > 0 ) {
      line = lines(idx3(1)+idx2+1);
      p = strpos(line,"squared")+9;
      pf = strpos(line,"for",p);
      pd = strpos(line,"degrees",pf);
      fitqual.red_chi2 = atof(strpart(line,p:pf-1));
      fitqual.dof = atoi(strpart(line,pf+3:pd-1));
   } else {
      fitqual.red_chi2 = 0.0;
      fitqual.dof = 0;
   }

   res = array( s_Parval, nparams );

   for( i = 1; i <= nparams; i++ ) {
      line = lines(idx1 + i - 1);
      res(i).model = atoi(strpart(line, 6:10));
      res(i).component = strtrim(strpart(line,11:24));
      res(i).name = strtrim(strpart(line,25:35));
      res(i).unit = strtrim(strpart(line,36:43));
      res(i).value = atof(strpart(line,44:55));
      rem = strtrim(strpart(line,56:0));
      if( strpos(rem,"+/-") ) { // then an error is present
         res(i).value_err = atof(strpart(rem,4:0));
         res(i).status = "active";
      } else if( strpos(rem,"frozen") ) { // parameter is frozen
         res(i).value_err = 0.0;
         res(i).status = "frozen";
      } else { // unknown status
         res(i).value_err = 0.0;
         res(i).status = "indetermined";
      }
      if( am_subroutine() ) {
         if( res(i).status == "active" ) {
            if(!silent)write,format="%6i%6i%10s%10s%10s%14.6f%14.6f\n", i, res(i).model, \
               res(i).component, res(i).name, res(i).unit, res(i).value, res(i).value_err;
            if( flag ) {
               write,lun,format="%6i%6i%10s%10s%10s%14.6f%14.6f\n", i, res(i).model, \
                  res(i).component, res(i).name, res(i).unit, res(i).value, res(i).value_err;
            }
         } else {
            if(!silent)write,format="%6i%6i%10s%10s%10s%14.6f%10s\n", i, res(i).model, \
               res(i).component, res(i).name, res(i).unit, res(i).value, res(i).status;
            if( flag ) {
               write,lun,format="%6i%6i%10s%10s%10s%14.6f%10s\n", i, res(i).model, \
                  res(i).component, res(i).name, res(i).unit, res(i).value, res(i).status;
            }
         }
      }
   }
   if( flag ) close, lun;
   return res;
}

gx = get_xspec_fit_params;
write,"Now you have shorthand: gx  for get_xspec_fit_params";
%FILE% gfoldmat.i
/* Function gfoldmat */

func gfoldmat( e, sigma )
/* DOCUMENT matrix = gfoldmat( e, sigma )

  Returns a folding matrix so that
       g = matrix(,+)*f(+)
   of - if 'f' has three dimensions and the folding is for the
   middle dimension
       g = matrix(,+)*f(,+,)

   Call -  e : energy array
         sigma  : scalar with standard deviation,
                  or array with same size as 'e'

       2011-03-18/NJW   Allow scalar sigma
*/

{
   n = numberof(e);
   ee = double( e );
   ns = numberof(sigma);
   if( ns != 1 && ns != n ) {
      write,"'sigma' has illegal dimension\n";
      return -1;
   }
   sigma2 = sigma * sqrt(2.);
   if( ns == 1 ) sigma2 = sigma2(-:1:n);

   // Define channel boundaries

   eb = 0.5*(ee + shift(ee,-1));
   eb(1) = (3*ee(1) - ee(2))/2;
   grow,eb,(3*ee(0) - ee(-1))/2;
   g = array(double,n,n);
   for( i = 1; i <= n; i++ ) {
      j = where((e > ee(i)-3.5*sigma2(i)) & (e < ee(i)+3.5*sigma2(i)) );
      if( numberof(j) ) {
         x2 = (eb(j+1) - ee(i))/sigma2(i);
         x1 = (eb(j) - ee(i))/sigma2(i);
         w = erf(x2) - erf(x1);
         //+ zum = f(j) * w;
         g(i,j) = w / sum(w); // normalize
      }
   }

   return g;

}

%FILE% ghat.i
extern ghatdoc;
/* DOCUMENT *****************************
 *
 *   A system of functions that can approximate a
 *   given function provided the scale size
 *   (_GHAT_SCALE) is of the same size as the scale
 *  of the function variations.
 *
 *   Functions:
 *
 *    ghat            - ghat(x,beta) returns the value of the ghat single
 *    ghats           - ghats(x,coefs)
 *    ghat_info       - ghat_info   prints to the terminal
 *    ghat_adapt      - define required externals for an interval
 *    ghat_fit        - fit a set of coefficients to a function
 *    set_ghat_num    - set external _GHAT_NUM
 *    set_ghat_scale  - set external _GHAT_SCALE
 *    set_ghat_max    - set external _GHAT_MAX
 *    set_ghat_min    - set external _GHAT_MIN
 *    ghat_oplot      - overplot individual contributions
 */
func ghat(x,beta)
/* DOCUMENT res = ghat(x,beta)
*/
{
   x = double(x)/_GHAT_SCALE;
   if( is_scalar(x) ) {
      if( abs(x) >= 1.0 ) {
         return 0.0;
      } else {
         return 0.5*(1.0 + cos(pi*x))*exp(beta*x);
      }
   } else {
      res = x;
      w = where( abs(x) >= 1.0 );
      m = where( abs(x) <  1.0 );
      if( numberof(w) ) res(w) = 0.0;
      if( numberof(m) ) res(m) = 0.5*(1.0 + cos(pi*x(m)))*exp(beta*x(m));
      return res;
   }
}
func set_ghat_num( nhat )
/* DOCUMENT set_ghat_num, nhat
*/
{
   extern _GHAT_SCALE, _GHAT_NUM;

   if( nhat < 2 ) error,"nhat must be larger than 1";

   _GHAT_NUM = long(nhat);
   if( !is_void(_GHAT_MIN) && !is_void(_GHAT_MAX) ) {
      _GHAT_SCALE = (_GHAT_MAX - _GHAT_MIN)/(_GHAT_NUM-1);
   }
}
func set_ghat_scale( scale )
/* DOCUMENT set_ghat_scale, scale
*/
{
   extern _GHAT_SCALE;

   _GHAT_SCALE = double(scale);
}
func set_ghat_max( value )
/* DOCUMENT set_ghat_max, value
*/
{
   extern _GHAT_MAX;

   _GHAT_MAX = double(value);
}
func set_ghat_min( value )
/* DOCUMENT set_ghat_min, value
*/
{
   extern _GHAT_MIN;

   _GHAT_MIN = double(value);
}
func ghats( x, coefs )
/* DOCUMENT res = ghats(x,coefs)

   'coefs' is of dimension n x 2 where beta = coefs(i,2)
*/
{
   n = numberof(coefs(,1));
   y = coefs(1,1)*ghat(x-_GHAT_MIN,coefs(1,2));
   for(i=2;i<=n;i++) y += coefs(i,1)*ghat(x-_GHAT_MIN-(i-1)*_GHAT_SCALE,coefs(i,2));
   return y;
}
func ghat_info
/* DOCUMENT ghat_info
*/
{
   write,format=" Num elems : %5i\n", _GHAT_NUM;
   write,format="Scale size : %12.6f\n", _GHAT_SCALE;
   write,format="   Start x : %12.6f\n", _GHAT_MIN;
   write,format="    Stop x : %12.6f\n", _GHAT_MAX;
}

func ghat_adapt( x, nhat)
/* DOCUMENT ghat_adapt, x, nhat
*/
{
   extern _GHAT_MIN, _GHAT_MAX, _GHAT_SCALE, _GHAT_NUM;

   if( nhat < 2 ) error,"nhat cannot be less than 2";

   _GHAT_MIN = double(min(x));
   _GHAT_MAX = double(max(x));
   _GHAT_SCALE = (_GHAT_MAX - _GHAT_MIN)/(nhat-1);
   _GHAT_NUM = nhat;
}

func ghat_fit( x, y, nhat )
/* DOCUMENT coefs = ghat_fit( x, y[, nhat] )

   The argument 'nhat' will, if present, define externals
   for the range defined by 'x'.
*/
{
   if( !is_void(nhat) ) ghat_adapt, x, nhat;
   coefs = array(double, _GHAT_NUM, 2);
   // make initial guess
   coefs(1,1) = y(1);
   for(i = 2; i <= _GHAT_NUM; i++ ) {
      xh = _GHAT_MIN + (i-1)*_GHAT_SCALE;
      w = where(abs(x-xh) == min(abs(x-xh)))(1);
      coefs(i,1) = y(w);
   }
   result = lmfit(ghats, x, coefs, y );
   write,format="%i iterations by lmfit\n", result.niter;

   return coefs;
}
func ghat_oplot( x, coefs, color=, li= )
/* DOCUMENT ghat_oplot, x, coefs, color=, li=
*/
{
   n = numberof(coefs(,1));
   for( i = 1; i <= n; i++ ) {
      c = array(double,n,2);
      c(i,) = coefs(i,);
      oplot,x,ghats(x,c),color=color,li=li;
   }
}
func ghat_plot( x, y, n )
{
   ghat_adapt,x,n;
   c = ghat_fit( x, y );
   plot,x,y;
   oplot,x,ghats(x,c),color="red";
}

func _ghat_integ( beta, choice= )
/* DOCUMENT res = _ghat_integ( beta, choice= )

    Returns integral of core function (unscaled)

    choice   : absent or 0 - full range integral
               1           - right side i.e. at beginning of interval
               2           - left side i.e. at end of interval
*/
{
   if( choice ) { // A side has been chosen
      if( choice == 1 ) { // Right hand side i.e. at beginning
         t1 = abs(beta) < 1.e-4 ? 1. + 0.5*beta : (exp(beta)-1)/beta;
         t2 = beta*(exp(beta)+1)/(pi^2+beta^2);
         return 0.5*(t1 - t2);
      } else {            // Left hand side i.e. at end
         t1 = abs(beta) < 1.e-4 ? 1. - 0.5*beta : (1-exp(-beta))/beta;
         t2 = beta*(exp(-beta)+1)/(pi^2+beta^2);
         return 0.5*(t1 + t2);
      }
   } else {
      // Full range 
      fac = abs(beta) < 1.e-4 ? 2. + beta^2/3.: (exp(beta)-exp(-beta))/beta;
      fac *= (1.0 - beta^2/(pi^2 + beta^2));
      return 0.5*fac;
   }
}
func ghat_integ( coefs )
/* DOCUMENT res = ghat_integ( coefs )

   Returns complete integral
*/
{
   n = _GHAT_NUM;
   idel = coefs(1,1)*_ghat_integ(coefs(1,2),choice=1);
   isum = idel;
   write,format="%3i  %10.6f\n", 1, idel;
   for( i = 2; i < n; i++ ) {
      idel = coefs(i,1)*_ghat_integ(coefs(i,2));
      write,format="%3i  %10.6f\n", i, idel;
      isum += idel;
   }
   beta = coefs(n,2); idel = coefs(n,1)*_ghat_integ(coefs(n,2),choice=2);
   isum += idel;
   write,format="%3i  %10.6f\n", n, idel;
   write,"   ------"
   write,format="Sum  %10.6f\n", isum;

   return isum*_GHAT_SCALE;
}
%FILE% globe_mapping.i
/***********************************
   A package for the all-sky mapping
   in the Aitoff projection

   2008-08-25/NJW
*/

//+ #include "j_exposure_skymap.i"

/* Function map2fits */

func map2fits( filename, map )
/* DOCUMENT map2fits, filename, map

   2008-08-25/NJW
*/
{

   // Save the map

   kwds_init;
   kwds_set,"date",ndate(3),"Date of creation";
   kwds_set,"responsi","Niels J. Westergaard","Responsible";
   kwds_set,"extname","ORIG_MAP","Name of extension";

   fh = writefits( filename, map, clobber=1, cont=1 );

   // The mapping routine requires that the map has the dimension 360x180
   // so a rebinning or remapping may be required

   dms = dimsof(map);
   if( dms(2) != 360 || dms(3) != 180 ) {
      write,"A remapping is required";
      m1 = dms(2) >= 360 ? dms(2) % 360 : 360 % dms(2);
      m2 = dms(3) >= 180 ? dms(3) % 180 : 180 % dms(3);
      xmap = m1 == 0 && m2 == 0 ? rebin( map, 360, 180 ) : remap( map, 360, 180 );
      kwds_set, "extname","REMAPPED","Name of extension";
      fh = writefits( fh, xmap, cont=1 );
   } else xmap = map;

   local ix, iy;

   N = 180;
   Nh = N/2;
   pa = array(double,2*N,N);
   delt = 180.0/N;
   substep = 0.2*delt;
   substeph = substep/2;

   for( i = 1; i <= 2*N; i++ ) {
      write,format="%3i,",i;
      if( i%20 == 0 ) write,"";
      x1 = (i - N - 1) * delt;
      x2 = (i - N    ) * delt;
      for( j = 1; j <= N; j++ ) {
         y1 = (j - Nh - 1) * delt;
         y2 = (j - Nh    ) * delt;

         nvals = 0;
         valsuma = 0.0;
         for(eps=substeph; eps < delt; eps += substep ) {
            for(eta=substeph; eta < delt; eta += substep ) {
               x = x1 + eps;
               y = y1 + eta;
               coords = rever_aitoff(x,y);
               if( is_void(coords) ) continue;
               // conversion from position to map indices
               conv_lonlat2map, coords(1), coords(2), ii, jj;
               nvals++;
               valsuma += xmap(ii,jj);
            }
         }
         if(nvals) {
            pa(i,j) = valsuma/nvals;
         }
      }
   }



   kwds_set,"extname","GLOBEMAP","name of extension";
   kwds_set,"maptype","PROJECTMAP","Map subjected to Aitoff projection";
   kwds_set,"ctype1","GLON-AIT","Hammer-Aitoff projection";
   kwds_set,"ctype2","GLAT-AIT","Hammer-Aitoff projection";
   kwds_set,"crpix1", 180.5,"reference pixel";
   kwds_set,"crpix2",  90.5,"reference pixel";
   kwds_set,"crval1",   0.0,"reference pixel value";
   kwds_set,"crval2",   0.0,"reference pixel value";
   kwds_set,"cdelt1",  -0.9,"degrees/pixel";
   kwds_set,"cdelt2",   0.9,"degrees/pixel";

   fh = writefits( fh, pa );

   write,"Job is done";

}

/* Function conv_lonlat2map */

func conv_lonlat2map( a1, a2, &r1, &r2 )
/* DOCUMENT conv_lonlat2map, a1, a2, >r1, >r2

   (a1,a2) can be (longitude, latitude) given as 'double'
   or 'float' and then (r1,r2) is the corresponding map
   position.

   (a1,a2) can be map position given as 'int' or 'long'
   and then (r1,r2) is the corresponding cell center
   in longitude and latitude.

   Around 2008-03-05/NJW
*/
{
   // determine from typeof a1
   if( typeof(a1) == "double" || typeof(a1) == "float" ) {
      //+ write,"Convert from position to indices in map";
      p = long(floor(a1 + 180.0)) + 1;
      while( p > 360 ) p -= 360;
      while( p <= 0  ) p += 360;
      //+ r1 = 361 - p;
      r1 = p;
      //+ r1 = long(floor(180. - a1)) + 1;
      r2 = long(floor( 90. + a2 )) + 1;
   } else {
      //+ write,"Convert from map indices to central positions";
      p = 361 - a1;
      r1 = p - 180.5;
      while( r1 > 360.0 ) r1 -= 360.0;
      while( r1 <= 0.0  ) r1 += 360.0;
      r2 = a2 - 90.5;
   }

}
%FILE% graph.i
/*
 * $Id: graph.i,v 1.2 2006/02/15 03:57:07 dhmunro Exp $
 * Declarations of Yorick graphics functions.
 */
/* Copyright (c) 2005, The Regents of the University of California.
 * All rights reserved.
 * This file is part of yorick (http://yorick.sourceforge.net).
 * Read the accompanying LICENSE file for details.
 */

/*--------------------------------------------------------------------------*/
/* Control functions */

extern window;
/* DOCUMENT window, n, display="host:server.screen", dpi=100/75, wait=0/1,
                       private=0/1, hcp="hcp_filename", dump=0/1,
                       legends=1/0, style="style_sheet_filename",
                       width=wpixels,height=hpixels,rgb=1

     select window N as the current graphics output window.  N may
     range from 0 to 7, inclusive.  Each graphics window corresponds to
     an X window, and optionally has its own associated hardcopy file.
     If N is omitted, it defaults to the current coordinate system.

     The X window will appear on your default display at 75 dpi, unless
     you specify the display and/or dpi keywords.  A dpi=100 X window
     is larger than a dpi=75 X window; both represent the same thing
     on paper.  Use display="" to create a graphics window which has
     no associated X window (you should do this if you want to make
     plots in a non-interactive batch mode).

     By default, if the X window needs to be created, the graphics area
     will be 450x450 pixels if dpi=75, or 600x600 pixels if dpi=100,
     representing a 6x6 inch square on hardcopy paper.  You can override
     this default initial size using the width and height keywords.
     These settings remain in force indefinitely; use width=0,height=0
     to return to the default dpi-dependent behavior.  For a dpi=75,
     landscape=0 window, width=638,height=825 displays the entire sheet
     of hardcopy paper.  Supplying these keywords will not change the
     size of an existing window; only newly created windows.

     By default, an X window will attempt to use shared colors, which
     permits several Yorick graphics windows (including windows from
     multiple instances of Yorick) to use a common palette.  You can
     force an X window to post its own colormap (set its colormap
     attribute) with the private=1 keyword.  You will most likely have
     to fiddle with your window manager to understand how it handles
     colormap focus if you do this.  Use private=0 to return to shared
     colors.

     By default, Yorick will not wait for the X window to become visible;
     code which creates a new window, then plots a series of frames to
     that window should use wait=1 to assure that all frames are actually
     plotted.

     By default, a graphics window does NOT have a hardcopy file
     of its own -- any request for hardcopy are directed to the
     default hardcopy file, so hardcopy output from any window goes
     to a single file.  By specifying the hcp keyword, however, a
     hardcopy file unique to this window will be created.  If the
     "hcp_filename" ends in ".cgm", the hardcopy file is a binary CGM
     file; otherwise, hardcopy files are in Postscript format.  Use
     hcp="" to revert to the default hardcopy file (closing the window
     specific file, if any).  The legends keyword, if present, controls
     whether the curve legends are (legends=1, the default) or are not
     (legends=0) dumped to the hardcopy file.  The dump keyword, if
     present, controls whether all colors are converted to a gray scale,
     (dump=0), or the current palette is dumped at the beginning of each
     page of hardcopy output (dump=1, the default).  (The legends keyword
     applies to all pictures dumped to hardcopy from this graphics
     window.  The dump keyword applies only to the specific hardcopy
     file defined using the hcp keyword -- use the dump keyword in the
     hcp_file command to get the same effect in the default hardcopy
     file.)

     Use rgb=1 to set the rgb color model when you are creating a
     window on an 8-bit display on which you intend to use three
     component rgb colors (see color).  This installs the 5x9x5
     colorcube and avoids having to issue the palette command
     after the first true color object has been drawn.

     If both display="" and hcp="", the graphics window will be
     entirely eliminated.

     The style keyword, if present, specifies the name of a Gist style
     sheet file; the default is "work.gs".  The style sheet determines
     the number and location of coordinate systems, tick and label styles,
     and the like.  Other choices include "axes.gs", "boxed.gs",
     "work2.gs", and "boxed2.gs".

     If invoked as a function, window(...) returns the current
     window number.
   SEE ALSO: plsys, hcp_file, fma, hcp, redraw, palette, animate, plg,
             winkill, gridxy
 */

func winkill(n)
/* DOCUMENT winkill
         or winkill, n
     deletes the current graphics window, or graphics window N (0-7).
   SEE ALSO: window
 */
{
  window, n, display="", hcp="";
}

extern current_window;
/* DOCUMENT n= current_window()
     returns the number of the current graphics window, or -1 if none.
 */

extern hcp_file;
/* DOCUMENT hcp_file, filename, dump=0/1, ps=0/1
     sets the default hardcopy file to FILENAME.  If FILENAME ends with
     ".cgm", the file will be a binary CGM, otherwise it will be a
     Postscript file.  By default, the hardcopy file name will be
     "Aa00.ps", or "Ab00.ps" if that exists, or "Ac00.ps" if both
     exist, and so on.  The default hardcopy file gets hardcopy from all
     graphics windows which do not have their own specific hardcopy file
     (see the window command).  If the dump keyword is present and non-zero,
     the current palette will be dumped at the beginning of each frame
     of the default hardcopy file (default behavior).  With dump=0,
     all colors are converted to a gray scale, and the output files are
     smaller because no palette information is included.
     Use ps=0 to make "Aa00.cgm", "Ab00.cgm", etc by default instead of
     Postscript.
     The dump= and ps= settings persist until explicitly changed by a
     second call to hcp_file; the dump=1 setting becomes the default for
     the window command as well.
   SEE ALSO: window, fma, hcp, plg
 */

extern hcp_finish;
/* DOCUMENT filename= hcp_finish()
         or filename= hcp_finish(n)
     closes the current hardcopy file and returns the filename.
     If N is specified, closes the hcp file associated with window N
     and returns its name; use hcp_finish(-1) to close the default
     hardcopy file.
   SEE ALSO: window, fma, hcp, hcp_out, plg
 */

func hcp_out(n,keep=)
/* DOCUMENT hcp_out
         or hcp_out, n
     finishes the current hardcopy file and sends it to the printer.
     If N is specified, prints the hcp file associated with window N;
     use hcp_out,-1 to print the default hardcopy file.
     Unless the KEEP keyword is supplied and non-zero, the file will
     be deleted after it is processed by gist and sent to lpr.
   SEE ALSO: window, fma, hcp, hcp_finish, plg
 */
{
  filename= hcp_finish();
  if (filename) {
    if (strpart(filename,-2:0)==".ps")
      system, swrite(format=LPR_FORMAT, filename);
    else
      system, swrite(format=GIST_FORMAT, filename);
    if (!keep) remove, filename;
  }
}

func hcps(name)
/* DOCUMENT hcps, name
     writes the picture in the current graphics window to the
     PostScript file NAME+".ps" (i.e.- the suffix .ps is added to NAME).
     Legends are not written, but the palette is always dumped.
   SEE ALSO: hcps, window, fma, hcp, hcp_finish, plg
 */
{
  if (strpart(name,-2:0)!=".ps") name+= ".ps";
  window, hcp=name, dump=1, legends=0;
  hcp;
  window, hcp="";
  return name;
}

func epsi(name)
/* DOCUMENT eps, name
     writes the picture in the current graphics window to the Encapsulated
     PostScript file NAME+".epsi" (i.e.- the suffix .epsi is added to NAME).
     The eps function requires the ps2epsi utility which comes with the
     project GNU Ghostscript program.  Any hardcopy file associated with
     the current window is first closed, but the default hardcopy file is
     unaffected.  As a side effect, legends are turned off and color table
     dumping is turned on for the current window.
     The external variable PS2EPSI_FORMAT contains the format for the
     command to start the ps2epsi program.
   SEE ALSO: eps, hcps, window, fma, hcp, hcp_finish, plg
 */
{
  name= hcps(name);
  system, swrite(format=PS2EPSI_FORMAT, name);
  remove, name;
}
if (is_void(PS2EPSI_FORMAT)) PS2EPSI_FORMAT= "ps2epsi %s";

func eps(name, pdf=)
/* DOCUMENT eps, name
     writes the picture in the current graphics window to the Encapsulated
     PostScript file NAME+".eps" (i.e.- the suffix .eps is added to NAME).
     This function requires ghostscript.  Any hardcopy file associated with
     the current window is first closed, but the default hardcopy file is
     unaffected.  As a side effect, legends are turned off and color table
     dumping is turned on for the current window.
     The external variable EPSGS_CMD contains the command to start
     ghostscript.
   SEE ALSO: pdf, epsi, hcps, window, fma, hcp, hcp_finish, plg
 */
{
  if (strpart(name, -3:0) == ".eps") name = strpart(name,1:-4);
  /* dump the postscript file */
  psname = hcps(name+".pseps");

  /* begin copying to the eps file */
  f = create(name+".eps");
  g = open(psname);
  write, f, format="%s\n", "%!PS-Adobe-2.0 EPSF-1.2";
  rdline, g;
  line = rdline(g);
  if (strmatch(line,"% EPSF-3.0")) line = rdline(g); /* old ps.ps bug */
  for (i=1 ; i<=4 ; i++) {  /* Title For CreationDate Creator */
    write, f, format="%s\n", line;
    line = rdline(g);
  }

  /* use ghostscript to compute true bounding box */
  bbname = name+".bbeps";
  gscmd = EPSGS_CMD+" -sDEVICE=bbox -sOutputFile=- \"%s\" >>\"%s\" 2>&1";
  system, swrite(format=gscmd, psname, bbname);
  bb = rdline(open(bbname), 20);
  bb = bb(where(bb));
  remove, bbname;

  if (!pdf) {
    write, f, format="%s\n", bb;
    write, f, format="%s\n", "save countdictstack mark newpath "+
      "/showpage {} def /setpagedevice {pop} def";
  } else {
    /* concept from epstopdf perl script
     * by Sebastian Rahtz and Heiko Oberdiek,
     * distributed as part of the TeTeX package, see http://www.tug.org
     */
    tok = strtok(bb);
    list = where(tok(1,) == "%%HiResBoundingBox:");
    if (!numberof(list)) {
      list = where(tok(1,) == "%%BoundingBox:");
      if (!numberof(list))
        error, "ghostscript bounding box not found";
    }
    xmn = ymn = xmx = ymx = 0.;
    if (sread(tok(2,list(1)), xmn, ymn, xmx, ymx) != 4)
      error, "ghostscript bounding box format bug";
    write, f, format="%%BoundingBox: 0 0 %f %f\n", xmx-xmn, ymx-ymn;
    write, f, format="<< /PageSize [ %f %f ] >> setpagedevice\n",
      xmx-xmn, ymx-ymn;
    write, f, format="gsave %f %f translate\n",
      -xmn, -ymn;
  }
  write, f, format="%s\n", "%%EndProlog";
  while (line) {
    if (strpart(line,1:2)!="%%")
      write, f, format="%s\n", line;
    line = rdline(g);
  }

  close, g;
  remove, psname;

  write, f, format="%s\n", "%%Trailer";
  if (!pdf) {
    write, f, format="%s\n", "cleartomark "+
      "countdictstack exch sub { end } repeat restore";
  } else {
    write, f, format="%s\n", "grestore";
  }
  write, f, format="%s\n", "%%EOF";
  close, f;
  return name+".eps";
}
if (is_void(EPSGS_CMD)) EPSGS_CMD= "gs -q -dNOPAUSE -dSAFER -dBATCH";

func pdf(name)
/* DOCUMENT pdf, name
     writes the picture in the current graphics window to the Adobe PDF
     file NAME+".pdf" (i.e.- the suffix .pdf is added to NAME).  The
     pdf file is intended to be imported into MS PowerPoint or other
     commercial presentation software, or into in pdftex or pdflatex
     documents; it is cropped.  The result should be equivalent to
     running the epstopdf utility (which comes with TeX, see www.tug.org)
     on the eps file produced by the eps command.
     This function requires ghostscript.  Any hardcopy file associated with
     the current window is first closed, but the default hardcopy file is
     unaffected.  As a side effect, legends are turned off and color table
     dumping is turned on for the current window.
     The external variable EPSGS_CMD contains the command to start
     ghostscript.
   SEE ALSO: eps, hcps, window, fma, hcp, hcp_finish, plg
 */
{
  if (strpart(name, -3:0) == ".pdf") name = strpart(name,1:-4);
  /* first run ghostscript to produce an eps translated to (0,0) */
  psname = eps(name+".pdf", pdf=1);
  /* second run ghostscript to produce the cropped pdf */
  gscmd = EPSGS_CMD+" -sDEVICE=pdfwrite -sOutputFile=\"%s\" \"%s\"";
  system, swrite(format=gscmd, name+".pdf", psname);
  remove, psname;
}

extern fma;
/* DOCUMENT fma
     frame advance the current graphics window.  The current picture
     remains displayed in the associated X window until the next element
     is actually plotted.
   SEE ALSO: window, hcp, animate, plg
 */

extern hcp;
extern hcpon;
extern hcpoff;
/* DOCUMENT hcp
            hcpon
            hcpoff
     The hcp command sends the picture displayed in the current graphics
     window to the hardcopy file.  (The name of the default hardcopy file
     can be specified using hcp_file; each individual graphics window may
     have its own hardcopy file as specified by the window command.)
     The hcpon command causes every fma (frame advance) command to do
     and implicit hcp, so that every frame is sent to the hardcopy file.
     The hcpoff command reverts to the default "demand only" mode.
   SEE ALSO: window, fma, plg, pdf, eps, hcps
 */

extern redraw;
/* DOCUMENT redraw
     redraws the X window associated with the current graphics window.
   SEE ALSO: window, fma, hcp, plg
 */

extern palette;
/* DOCUMENT palette, filename
         or palette, source_window_number
         or palette, red, green, blue, ntsc=1/0
         or palette, red, green, blue, gray
         or palette, red, green, blue, query=1
         or palette, red, green, blue, gray, query=1
     sets (or retrieves with query=1) the palette for the current
     graphics window.  The FILENAME is the name of a Gist palette file;
     the standard palettes are "earth.gp", "stern.gp", "rainbow.gp",
     "heat.gp", "gray.gp", and "yarg.gp".  Use the maxcolors keyword
     in the pldefault command to put an upper limit on the number of
     colors which will be read from the palette in FILENAME.

     In the second form, the palette for the current window is copied
     from the SOURCE_WINDOW_NUMBER.  If the X colormap for the window is
     private, there will still be two separate X colormaps for the two
     windows, but they will have the same color values.

     In the third form, RED, GREEN, and BLUE are 1-D arrays of the same
     length specifying the palette you wish to install; the values
     should vary between 0 and 255, and your palette should have no
     more than 240 colors.  If ntsc=0, monochrome devices (such as most
     laser printers) will use the average brightness to translate your
     colors into gray; otherwise, the NTSC (television) averaging will
     be used (.30*RED+.59*GREEN+.11*BLUE).  Alternatively, you can specify
     GRAY explicitly.

     Ordinarily, the palette is not dumped to a hardcopy file
     (color hardcopy is still rare and expensive), but you can
     force the palette to dump using the window or hcp_file commands.

     See the dump= keyword for the hcp_file and window commands if you
     are having trouble getting color in your hardcopy files.

   SEE ALSO: window, fma, hcp, pldefault, plg
 */

extern animate;
/* DOCUMENT animate
         or animate, 0/1
     without any arguments, toggles animation mode; with argument 0,
     turns off animation mode, with argument 1 turns on animation mode.
     In animation mode, the X window associated with a graphics window
     is actually an offscreen pixmap which is bit-blitted onscreen
     when an fma command is issued.  This is confusing unless you are
     actually trying to make a movie, but results in smoother animation
     if you are.  Generally, you should turn animation on, run your movie,
     then turn it off.
   SEE ALSO: window, fma, plg
 */

extern plsys;
/* DOCUMENT plsys, n
         or plsys(n)   or   plsys()
     sets the current coordinate system to number N in the current
     graphics window.  If N equals 0, subsequent elements will be
     plotted in absolute NDC coordinates outside of any coordinate
     system.  The default style sheet "work.gs" defines only a single
     coordinate system, so the only other choice is N equal 1.  You
     can make up your own style sheet (using a text editor) which
     defines mulitple coordinate systems.  You need to do this if
     you want to display four plots side by side on a single page,
     for example.  The standard style sheets "work2.gs" and "boxed2.gs"
     define two overlayed coordinate systems with the first labeled
     to the right of the plot and the second labeled to the left of
     the plot.  When using overlayed coordinate systems, it is your
     responsibility to ensure that the x-axis limits in the two
     systems are identical.
     Return value is coordinate system setting before this call;
     input n may be nil to retrieve this without changing it.  Return
     value can be <0 if the information is unavailable for some reason.
   SEE ALSO: window, limits, plg
 */

/*--------------------------------------------------------------------------*/
/* Plotting functions (output primitives) */

extern plg;
/* DOCUMENT plg, y, x
         or plg, y
     plots a graph of Y versus X.  Y and X must be 1-D arrays of equal
     length; if X is omitted, it defaults to [1, 2, ..., numberof(Y)].
     A keyword n=[n1,n2,n3,...nN] can be used to add N curves.  In this
     case, sum(n) must be numberof(y).
     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide
             type, width, color, closed, smooth
             marks, marker, mspace, mphase
             rays, arrowl, arroww, rspace, rphase
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp, plmk
             limits, logxy, range, fma, hcp
 */

extern plm;
/* DOCUMENT plm, y, x, boundary=0/1, inhibit=0/1/2
         or plm, y, x, ireg, boundary=0/1, inhibit=0/1/2
         or plm, boundary=0/1, inhibit=0/1/2
     plots a mesh of Y versus X.  Y and X must be 2-D arrays with equal
     dimensions.  If present, IREG must be a 2-D region number array
     for the mesh, with the same dimensions as X and Y.  The values of
     IREG should be positive region numbers, and zero for zones which do
     not exist.  The first row and column of IREG never correspond to any
     zone, and should always be zero.  The default IREG is 1 everywhere
     else.  If present, the BOUNDARY keyword determines whether the
     entire mesh is to be plotted (boundary=0, the default), or just the
     boundary of the selected region (boundary=1).  If present, the
     INHIBIT keyword causes the (X(,j),Y(,j)) lines to not be plotted
     (inhibit=1), or the (X(i,),Y(i,)) lines to not be plotted (inhibit=2).
     By default (inhibit=0), mesh lines in both logical directions are
     plotted.
     The Y, X, and IREG arguments may all be omitted to default to the
     mesh set by the most recent plmesh call.
     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide
             type, width, color
             region
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp, plmesh
             limits, logxy, range, fma, hcp
 */

extern plmesh;
/* DOCUMENT plmesh, y, x, ireg, triangle=tri_array
         or plmesh
     sets the default mesh for subsequent plm, plc, plv, and plf calls.
     In the second form, deletes the default mesh (until you do this,
     or switch to a new default mesh, the default mesh arrays persist and
     take up space in memory).  The Y, X, and IREG arrays should all be
     the same shape; Y and X will be converted to double, and IREG will
     be converted to int.  If IREG is omitted, it defaults to IREG(1,)=
     IREG(,1)= 0, IREG(2:,2:)=1; that is, region number 1 is the whole
     mesh.  The triangulation array TRI_ARRAY is used by plc; the
     correspondence between TRI_ARRAY indices and zone indices is the
     same as for IREG, and its default value is all zero.
     The IREG or TRI_ARRAY arguments may be supplied without Y and X
     to change the region numbering or triangulation for a given set of
     mesh coordinates.  However, a default Y and X must already have been
     defined if you do this.
     If Y is supplied, X must be supplied, and vice-versa.
   SEE ALSO: plm, plc, plv, plf, plfp
 */

extern plc;
/* DOCUMENT plc, z, y, x, levs=z_values
         or plc, z, y, x, ireg, levs=z_values
         or plc, z, levs=z_values
     plots a contours of Z on the mesh Y versus X.  Y, X, and IREG are
     as for plm.  The Z array must have the same shape as Y and X.
     The function being contoured takes the value Z at each point
     (X,Y) -- that is, the Z array is presumed to be point-centered.
     The Y, X, and IREG arguments may all be omitted to default to the
     mesh set by the most recent plmesh call.
     The LEVS keyword is a list of the values of Z at which you want
     contour curves.  The default is eight contours spanning the
     range of Z.
     See plfc if you want to color the regions between contours.
     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide
             type, width, color, smooth
             marks, marker, mspace, mphase
             smooth, triangle, region
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp, plmesh, plfc
             contour, spann, limits, logxy, range, fma, hcp
 */

extern contour;
/* DOCUMENT nc= contour(yc,xc, level, z, y,x)
         or nc= contour(yc,xc, level, z, y,x,ireg)

     returns the points on the contour curve that would have been
     plotted by plc.  Z, Y, X, and IREG are as for plc, and the
     triangle= and region= keywords are accepted and have the same
     meaning as for plc.  Unlike plc, the triangle array is an output
     as well as an input to contour; if supplied it may be modified
     to reflect any triangulations which were performed by contour.

     LEVEL is a scalar z value to return the points at that contour
     level.  All such points lie on edges of the mesh.  If a contour
     curve closes, the final point is the same as the initial point
     (i.e.- that point is included twice in the returned list).

     LEVEL is a pair of z values [z0,z1] to return the points of
     a set of polygons which outline the regions between the two
     contour levels.  These will include points on the mesh boundary
     which lie between the levels, in addition to the edge points
     for both levels.  The polygons are closed, simply connected,
     and will not contain more than about 4000 points (larger polygons
     are split into pieces with a few points repeated where the pieces
     join).

     YC and XC are the output points on the curve(s), or nil if there
     are no points.  On input, they must be simple variable references,
     not expressions.  The return value NC is a list of the lengths of
     the polygons/polylines returned in (XC,YC), or nil if there are
     none.  numberof(XC)==numberof(YC)==sum(NC).  For the level pair
     case, YC, XC, and NC are ready to be used as inputs to plfp.

   KEYWORDS: triangle, region
   SEE ALSO: plc, plfp
 */

extern plv;
/* DOCUMENT plv, vy, vx, y, x, scale=dt
         or plv, vy, vx, y, x, ireg, scale=dt
         or plv, vy, vx, scale=dt
     plots a vector field (VX,VY) on the mesh (X,Y).  Y, X, and IREG are
     as for plm.  The VY and VX arrays must have the same shape as Y and X.
     The Y, X, and IREG arguments may all be omitted to default to the
     mesh set by the most recent plmesh call.
     The SCALE keyword is the conversion factor from the units of
     (VX,VY) to the units of (X,Y) -- a time interval if (VX,VY) is a velocity
     and (X,Y) is a position -- which determines the length of the
     vector "darts" plotted at the (X,Y) points.  If omitted, SCALE is
     chosen so that the longest ray arrows have a length comparable
     to a "typical" zone size.
     You can use the scalem keyword in pledit to make adjustments to the
     SCALE factor computed by default.
     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide
             type, width, color, smooth
             marks, marker, mspace, mphase
             triangle, region
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp, plmesh, pledit,
             limits, logxy, range, fma, hcp
 */

extern plf;
/* DOCUMENT plf, z, y, x
         or plf, z, y, x, ireg
         or plf, z
     plots a filled mesh Y versus X.  Y, X, and IREG are as for plm.
     The Z array must have the same shape as Y and X, or one smaller
     in both dimensions.  If Z is of type char, it is used "as is",
     otherwise it is linearly scaled to fill the current palette, as
     with the bytscl function.
     (See the bytscl function for explanation of top, cmin, cmax.)
     The mesh is drawn with each zone in the color derived from the Z
     function and the current palette; thus Z is interpreted as a
     zone-centered array.

     As for pli and plfp, Z may also be a 3x(NX-1)x(NY-1) array
     of char giving the [r,g,b] components of each color.  See the
     color keyword for cautions about using this if you do not have
     a true color display.

     The Y, X, and IREG arguments may all be omitted to default to the
     mesh set by the most recent plmesh call.
     A solid edge can optionally be drawn around each zone by setting
     the EDGES keyword non-zero.  ECOLOR and EWIDTH determine the edge
     color and width.  The mesh is drawn zone by zone in order from
     IREG(2+imax) to IREG(jmax*imax) (the latter is IREG(imax,jmax)),
     so you can achieve 3D effects by arranging for this order to
     coincide with back-to-front order.  If Z is nil, the mesh zones
     are filled with the background color, which you can use to
     produce 3D wire frames.
     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide
             region, top, cmin, cmax, edges, ecolor, ewidth
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp, plmesh,
             limits, logxy, range, fma, hcp, palette, bytscl, histeq_scale
 */

extern plfp;
/* DOCUMENT plfp, z, y, x, n
     plots a list of filled polygons Y versus X, with colors Z.
     The N array is a 1D list of lengths (number of corners) of the
     polygons; the 1D colors array Z has the same length as N.  The
     X and Y arrays have length sum(N).
     If Z is of type char, it is used "as is", otherwise it is linearly
     scaled to fill the current palette, as with the bytscl function.
     If Z is nil, the background color is used for every polygon.
     (See the bytscl function for explanation of top, cmin, cmax.)

     As for plf and pli, Z may also be a 3-by-numberof(N) array of
     char giving the [r,g,b] components of each color.  See the
     color keyword for cautions about using this if you do not have
     a true color display.

     As a special case, if n(2:)==1, the first polygon is assumed
     to have NDC coordinates, while the remaining individual X and Y
     values are in world coordinates.  The first polygon is drawn
     numberof(n)-1 times, with its (0,0) placed at each of the
     individual (X,Y) values in succession.  This is a hack to enable
     plotting of more elaborate data markers than plg,type=0 -- see
     the plmk function for details.

     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide, top, cmin, cmax, edges, ecolor, ewidth
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfc
             limits, logxy, range, fma, hcp
 */

extern pli;
/* DOCUMENT pli, z
         or pli, z, x1, y1
         or pli, z, x0, y0, x1, y1
     plots the image Z as a cell array -- an array of equal rectangular
     cells colored according to the 2-D array Z.  The first dimension
     of Z is plotted along x, the second dimension is along y.
     If Z is of type char, it is used "as is", otherwise it is linearly
     scaled to fill the current palette, as with the bytscl function.
     (See the bytscl function for explanation of top, cmin, cmax.)

     As for plf and plfp, Z may also be a 3D array with 1st dimension 3
     of char giving the [r,g,b] components of each color.  See the
     color keyword for cautions about using this if you do not have
     a true color display.

     If X1 and Y1 are given, they represent the coordinates of the
     upper right corner of the image.  If X0, and Y0 are given, they
     represent the coordinates of the lower left corner, which is at
     (0,0) by default.  If only the Z array is given, each cell will be
     a 1x1 unit square, with the lower left corner of the image at (0,0).
     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide, top, cmin, cmax
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp,
             limits, logxy, range, fma, hcp, palette, bytscl, histeq_scale
 */

extern pldj;
/* DOCUMENT pldj, x0, y0, x1, y1
     plots disjoint lines from (X0,Y0) to (X1,Y1).  X0, Y0, X1, and Y1
     may have any dimensionality, but all must have the same number of
     elements.
     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide
             type, width, color
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp
             limits, logxy, range, fma, hcp
 */

extern plt;
/* DOCUMENT plt, text, x, y, tosys=0/1
     plots TEXT (a string) at the point (X,Y).  The exact relationship
     between the point (X,Y) and the TEXT is determined by the
     justify keyword.  TEXT may contain newline ("\n") characters
     to output multiple lines of text with a single call.  The
     coordinates (X,Y) are NDC coordinates (outside of any coordinate
     system) unless the tosys keyword is present and non-zero, in
     which case the TEXT will be placed in the current coordinate
     system.  However, the character height is NEVER affected by the
     scale of the coordinate system to which the text belongs.
     Note that the pledit command takes dx and/or dy keywords to
     adjust the position of existing text elements.

     The characters ^, _, and ! are treated specially in TEXT.
     ^ begins a superscript, _ begins a subscript, and ! causes the
     following character to be rendered using the symbol font.  As
     special cases, !^, !_, and !! render the ^, _, and ! characters
     themselves.  However, if ! is the final character of TEXT
     (or immediately before a newline in multiline text), it
     loses its special meaning.  TEXT has just three modes: ordinary,
     superscript, and subscript.  A ^ character enters superscript
     mode from ordinary or subscript mode, and returns to ordinary
     mode from superscript mode.  A _ enters subscript mode, except
     from subscript mode it returns to ordinary mode.  For example,
     Euclid said, "!pr^2", and Einstein said, "G_!s!n_=8!pT_!s!n".
     One final special escape: !] produces the ^ character in the
     symbol font (it is a perpendicular sign, whereas ] is just ]).

     The following keywords are legal (each has a separate help entry):
   KEYWORDS: legend, hide
             color, font, height, opaque, orient, justify
   SEE ALSO: plt1, plg, plm, plc, plv, plf, pli, plt, pldj, plfp, pledit
             limits, range, fma, hcp, pltitle
 */

func plt1(text, x, y, tosys=, color=,font=,height=,opaque=,orient=,justify=)
/* DOCUMENT plt1, text, x, y
     same as plt, but TEXT, X, and Y may be arrays to plot multiple
     strings.  The tosys= keyword works as for plt.
   KEYWORDS: color, font, height, opaque, orient, justify
   SEE ALSO: plt
 */
{
  n= array(0.,dimsof(text,x,y));
  x+= n;
  y+= n;
  text+= array(string,dimsof(n));
  n= numberof(n);
  for (i=1 ; i<=n ; ++i)
    plt,text(i),x(i),y(i),tosys=tosys,color=color,font=font,height=height,
      opaque=opaque,orient=orient,justify=justify;
}

func pltitle(title)
/* DOCUMENT pltitle, title
     Plot TITLE centered above the coordinate system for any of the
     standard Gist styles.  You may want to customize this for other
     plot styles.
   SEE ALSO: plt, xytitles
 */
{
  port= viewport();
  plt, title, port(zcen:1:2)(1), port(4)+0.02,
    font=pltitle_font, justify="CB", height=pltitle_height;
}

func xytitles(xtitle, ytitle, adjust)
/* DOCUMENT xytitles, xtitle, ytitle
       -or- xytitles, xtitle, ytitle, [deltax,deltay]
     Plot XTITLE horizontally under the viewport and YTITLE vertically
     to the left of the viewport.  If the tick numbers interfere with
     the labels, you can specify the [DELTAX,DELTAY] in NDC units to
     displace the labels.  (Especially for the y title, the adjustment
     may depend on how many digits the numbers on your scale actually
     have.)  Note that DELTAX moves YTITLE and DELTAY moves XTITLE.
     WARNING: There is no easy way to ensure that this type of title
              will not interfere with the tick numbering.  Interference
              may make the numbers or the title or both illegible.
   SEE ALSO: plt, pltitle
 */
{
  if (is_void(adjust)) adjust= [0.,0.];
  port= viewport();
  if (xtitle && strlen(xtitle))
    plt, xtitle, port(zcen:1:2)(1), port(3)-0.050+adjust(2),
      font=pltitle_font, justify="CT", height=pltitle_height;
  if (ytitle && strlen(ytitle))
    plt, ytitle, port(1)-0.050+adjust(1), port(zcen:3:4)(1),
      font=pltitle_font, justify="CB", height=pltitle_height, orient=1;
}

pltitle_height= 14;
pltitle_font= "schoolbook";

/*--------------------------------------------------------------------------*/
/* Plot limits and log/linear scaling */

e= "e";         /* for use with limits and range functions */

extern limits;
/* DOCUMENT limits
         or limits, xmin, xmax, ymin, ymax,
                    square=0/1, nice=0/1, restrict=0/1
         or old_limits= limits()
         or limits, old_limits

     In the first form, restores all four plot limits to extreme values.

     In the second form, sets the plot limits in the current coordinate
     system to XMIN, XMAX, YMIN, YMAX, which may be nil or omitted to
     leave the corresponding limit unchanged, a number to fix the
     corresponding limit to a specified value, or the string "e" to
     make the corresponding limit take on the extreme value of the
     currently displayed data.

     If present, the square keyword determines whether limits marked
     as extreme values will be adjusted to force the x and y scales
     to be equal (square=1) or not (square=0, the default).
     If present, the nice keyword determines whether limits will be
     adjusted to nice values (nice=1) or not (nice=0, the default).
     There is a subtlety in the meaning of "extreme value" when one
     or both of the limits on the OPPOSITE axis have fixed values --
     does the "extreme value" of the data include points which
     will not be plotted because their other coordinate lies outside
     the fixed limit on the opposite axis (restrict=0, the default),
     or not (restrict=1)?

     If called as a function, limits returns an array of 5 doubles;
     OLD_LIMITS(1:4) are the current xmin, xmax, ymin, and ymax,
     and int(OLD_LIMITS(5)) is a set of flags indicating extreme
     values and the square, nice, restrict, and log flags.

     In the fourth form, OLD_LIMITS is as returned by a previous
     limits call, to restore the limits to a previous state.

     In an X window, the limits may also be adjusted interactively
     with the mouse.  Drag left to zoom in and pan (click left to zoom
     in on a point without moving it), drag middle to pan, and click
     (and drag) right to zoom out (and pan).  If you click just above
     or below the plot, these operations will be restricted to the
     x-axis; if you click just to the left or right, the operations
     are restricted to the y-axis.  A ctrl-left click, drag, and
     release will expand the box you dragged over to fill the plot
     (other popular software zooms with this paradigm).  If the
     rubber band box is not visible with ctrl-left zooming, try
     ctrl-middle or ctrl-right for alternate XOR masks.  Such
     mouse-set limits are equivalent to a limits command specifying
     all four limits EXCEPT that the unzoom command can revert to
     the limits before a series of mouse zooms and pans.

     Holding the shift key and pressing the left mouse button is
     equivalent to pressing the middle mouse button.  Similarly,
     pressing meta-left is equivalent to the right button.  This
     permits access to the middle and right button functions on
     machines (e.g.- most laptops) with two button or one button
     mice.

     The limits you set using the limits or range functions carry over
     to the next plot -- that is, an fma operation does NOT reset the
     limits to extreme values.

   SEE ALSO: plsys, range, logxy, zoom_factor, unzoom, plg, viewport
 */

func range(ymin, ymax) { limits,,, ymin, ymax; }
/* DOCUMENT range, ymin, ymax
     sets the y-axis plot limits in the current coordinate system to
     YMIN, YMAX, which may be nil or omitted to leave the corresponding
     limit unchanged, a number to fix the corresponding limit to a
     specified value, or the string "e" to make the corresponding limit
     take on the extreme value of the currently displayed data.
     Use    limits, xmin, xmin
     to accomplish the same function for the x-axis plot limits.
   SEE ALSO: plsys, limits, logxy, plg
 */

extern logxy;
/* DOCUMENT logxy, xflag, yflag
     sets the linear/log axis scaling flags for the current coordinate
     system.  XFLAG and YFLAG may be nil or omitted to leave the
     corresponding axis scaling unchanged, 0 to select linear scaling,
     or 1 to select log scaling.
   SEE ALSO: plsys, limits, range, plg, gridxy
 */

extern gridxy;
/* DOCUMENT gridxy, flag
         or gridxy, xflag, yflag
     Turns on or off grid lines according to FLAG.  In the first form, both
     the x and y axes are affected.  In the second form, XFLAG and YFLAG
     may differ to have different grid options for the two axes.  In either
     case, a FLAG value of 0 means no grid lines (the default), a value of
     1 means grid lines at all major ticks (the level of ticks which get
     grid lines can be set in the style sheet), and a FLAG value of 2 means
     that the coordinate origin only will get a grid line.  In styles with
     multiple coordinate systems, only the current coordinate system is
     affected.
     The keywords can be used to affect the style of the grid lines.

     You can also turn the ticks off entirely.  (You might want to do this
     to plot your own custom set of tick marks when the automatic tick
     generating machinery will never give the ticks you want.  For example
     a latitude axis in degrees might reasonably be labeled "0, 30, 60,
     90", but the automatic machinery considers 3 an "ugly" number - only
     1, 2, and 5 are "pretty" - and cannot make the required scale.  In
     this case, you can turn off the automatic ticks and labels, and use
     plsys, pldj, and plt to generate your own.)
     To fiddle with the tick flags in this general manner, set the
     0x200 bit of FLAG (or XFLAG or YFLAG), and "or-in" the 0x1ff bits
     however you wish.  The meaning of the various flags is described
     in the file Y_SITE/gist/work.gs.  Additionally, you can use the
     0x400 bit to turn on or off the frame drawn around the viewport.
     Here are some examples:
        gridxy,0x233        work.gs default setting
        gridxy,,0x200       like work.gs, but no y-axis ticks or labels
        gridxy,,0x231       like work.gs, but no y-axis ticks on right
        gridxy,0x62b        boxed.gs default setting

     The three keywords base60=, degrees=, and hhmm= can be used to get
     alternative tick intervals for base 60 systems instead of the
     usual base 10 systems.  The keyword values are 0 to restore the
     default behavior, 1 to set the feature for the x axis, 2 to set it
     for the y axis, and 3 to set it for both axes.  The base60 feature
     allows ticks and labels at multiples of 30 (up to +-3600).  The
     degrees feature causes labels to be printed modulo 360 (so that a
     scale which runs from, say, 90 to 270 will be printed as 90 to 180
     then -180 to -90, mostly for longitude scales).  The hhmm feature
     causes labels to be printed in the form hh:mm (so that, for example,
     150 will be printed as 02:30, mostly for time of day scales).

   KEYWORDS: color, type, width, base60, degrees, hhmm
   SEE ALSO: window, plsys, limits, range, logxy, viewport
 */

extern zoom_factor;
/* DOCUMENT zoom_factor, factor
     sets the zoom factor for mouse-click zoom in and zoom out operations.
     The default FACTOR is 1.5; FACTOR should always be greater than 1.0.
   SEE ALSO: limits, range, unzoom, plg
 */

extern unzoom;
/* DOCUMENT unzoom
     restores limits to their values before zoom and pan operations
     performed interactively using the mouse.
     Use    old_limits=  limits()
            ...
            limits, old_limits
     to save and restore plot limits generally.
   SEE ALSO: limits, range, zoom_factor, plg
 */

/*--------------------------------------------------------------------------*/
/* Keywords for plotting functions */

local legend;
/* DOCUMENT legend=   plotting keyword
     sets the legend for a plot.  The default legend is a concatentation
     of the strings used in the original plotting command (plg, plm, etc.),
     except for the plt command, which has no default legend.
     Legends are never plotted to the X window; use the plq command to
     see them interactively.  Legends will appear in hardcopy output
     unless they have been explicitly turned off.
   PLOTTING COMMANDS: plg, plm, plc, plv, plf, pli, plt, pldj
   SEE ALSO: hide
 */

local hide;
/* DOCUMENT hide=   plotting keyword
     sets the visibility of a plotted element.  The default is hide=0,
     which means that the element will be visible.  Use hide=1 to remove
     the element from the plot (but not from the display list).
   PLOTTING COMMANDS: plg, plm, plc, plv, plf, pli, plt, pldj
   SEE ALSO: legend
 */

local type;
/* DOCUMENT type=   plotting keyword
     selects line type.  Valid values are the strings "solid", "dash",
     "dot", "dashdot", "dashdotdot", and "none".  The "none" value
     causes the line to be plotted as a polymarker.  You should also
     check the plmk function if you need polymarkers.
     The type value may also be a number; 0 is "none", 1 is "solid",
     2 is "dash", 3 is "dot", 4 is "dashdot", and 5 is "dashdotdot".
   PLOTTING COMMANDS: plg, plm, plc, pldj
   SEE ALSO: width, color, marks, marker, rays, closed, smooth, plmk
 */

local width;
/* DOCUMENT width=   plotting keyword
     selects line width.  Valid values are positive floating point numbers
     giving the line thickness relative to the default line width of one
     half point, width= 1.0.
   PLOTTING COMMANDS: plg, plm, plc, pldj, plv (only if hollow=1)
   SEE ALSO: type, color, marks, marker, rays, closed, smooth
 */

local color;
/* DOCUMENT color=   plotting keyword
     selects line or text color.  Valid values are the strings "bg", "fg",
     "black", "white", "red", "green", "blue", "cyan", "magenta", "yellow",
     or a 0-origin index into the current palette.  The default is "fg".
     Negative numbers may be used instead of the strings: -1 is bg
     (background), -2 is fg (foreground), -3 is black, -4 is white,
     -5 is red, -6 is green, -7 is blue, -8 is cyan, -9 is magenta, and
     -10 is yellow.  (The negative numbers are actually taken modulo
     256, so -1 is also 255, -2 is 254, and so on.)

     A color can also be a triple [r, g, b], with values running from
     0 for dark to 255 for full intensity.  Beware, however, of
     specifying an rgb color (either as a color keyword or to the
     plf, pli, or plfp commands) if your display is not a true color
     display (for example, if it is 8 bits deep or less).  In that
     case, it may switch to a 5x9x5 color cube, which causes a
     significant degradation in quality of rendering with smooth
     color palettes.  Furthermore, the hcp command will not work
     properly for rgb colors if the file is a CGM.  Use the rgb=1
     keyword in the window command to avoid having to re-issue a
     palette command after the first rgb object is drawn (this is
     unnecessary on true color screens).

   PLOTTING COMMANDS: plg, plm, plc, pldj, plt
   SEE ALSO: type, width, marks, marker, mcolor, rays, closed, smooth
 */

local marks;
/* DOCUMENT marks=   plotting keyword
     selects unadorned lines (marks=0), or lines with occasional markers
     (marks=1).  Ignored if type is "none" (indicating polymarkers instead
     of occasional markers).  The spacing and phase of the occasional
     markers can be altered using the mspace and mphase keywords; the
     character used to make the mark can be altered using the marker
     keyword.
   PLOTTING COMMANDS: plg, plc
   SEE ALSO: type, width, color, marker, rays, mspace, mphase, msize, mcolor
 */

local marker;
/* DOCUMENT marker=   plotting keyword
     selects the character used for occasional markers along a polyline,
     or for the polymarker if type is "none".  The special values
     '\1', '\2', '\3', '\4', and '\5' stand for point, plus, asterisk,
     circle, and cross, which are prettier than text characters on output
     to some devices.  The default marker is the next available capital
     letter, 'A', 'B', ..., 'Z'.
   PLOTTING COMMANDS: plg, plc
   SEE ALSO: type, width, color, marks, rays, mspace, mphase, msize, mcolor
 */

local mspace, mphase, msize, mcolor;
/* DOCUMENT mspace=   plotting keyword
         or mphase=   plotting keyword
         or msize=    plotting keyword
         or mcolor=   plotting keyword
     selects the spacing, phase, and size of occasional markers placed
     along polylines.  The msize also selects polymarker size if type
     is "none".  The spacing and phase are in NDC units (0.0013 NDC
     equals 1.0 point); the default mspace is 0.16, and the default
     mphase is 0.14, but mphase is automatically incremented for
     successive curves on a single plot.  The msize is in relative
     units, with the default msize of 1.0 representing 10 points.
     The mcolor keyword is the same as the color keyword, but controls
     the marker color instead of the line color.  Setting the color
     automatically sets the mcolor to the same value, so you only
     need to use mcolor if you want the markers for a curve to be a
     different color than the curve itself.
   PLOTTING COMMANDS: plg, plc
   SEE ALSO: type, width, color, marks, marker, rays
 */

local rays;
/* DOCUMENT rays=   plotting keyword
     selects unadorned lines (rays=0), or lines with occasional ray
     arrows (rays=1).  Ignored if type is "none".  The spacing and phase
     of the occasional arrows can be altered using the rspace and rphase
     keywords; the shape of the arrowhead can be modified using the
     arroww and arrowl keywords.
   PLOTTING COMMANDS: plg, plc
   SEE ALSO: type, width, color, marker, marks, rspace, rphase
             arroww, arrowl
 */

local rspace, rphase, arroww, arrowl;
/* DOCUMENT rspace=   plotting keyword
         or rphase=   plotting keyword
         or arroww=   plotting keyword
         or arrowl=   plotting keyword
     selects the spacing, phase, and size of occasional ray arrows
     placed along polylines.  The spacing and phase are in NDC units
     (0.0013 NDC equals 1.0 point); the default rspace is 0.13, and
     the default rphase is 0.11375, but rphase is automatically
     incremented for successive curves on a single plot.
     The arrowhead width, arroww, and arrowhead length, arrowl are
     in relative units, defaulting to 1.0, which translates to an
     arrowhead 10 points long and 4 points in half-width.
   PLOTTING COMMANDS: plg
   SEE ALSO: type, width, color, marks, marker, rays
 */

local closed, smooth;
/* DOCUMENT closed=   plotting keyword
         or smooth=   plotting keyword
     selects closed curves (closed=1) or default open curves (closed=0),
     or Bezier smoothing (smooth>0) or default piecewise linear curves
     (smooth=0).  The value of smooth can be 1, 2, 3, or 4 to get
     successively more smoothing.  Only the Bezier control points are
     plotted to an X window; the actual Bezier curves will show up in
     PostScript hardcopy files.  Closed curves join correctly, which
     becomes more noticeable for wide lines; non-solid closed curves
     may look bad because the dashing pattern may be incommensurate
     with the length of the curve.
   PLOTTING COMMANDS: plg, plc (smooth only)
   SEE ALSO: type, width, color, marks, marker, rays
 */

local font, height, opaque, orient, justify;
/* DOCUMENT font=     plotting keyword
         or height=   plotting keyword
         or opaque=   plotting keyword
         or orient=   plotting keyword
         or justify=  plotting keyword
     selects text properties.  The font can be any of the strings
     "courier", "times", "helvetica" (the default), "symbol", or
     "schoolbook".  Append "B" for boldface and "I" for italic, so
     "courierB" is boldface Courier, "timesI" is Times italic, and
     "helveticaBI" is bold italic (oblique) Helvetica.  Your X server
     should have the Adobe fonts (available free from the MIT X
     distribution tapes) for all these fonts, preferably at both 75
     and 100 dpi.  Occasionally, a PostScript printer will not be
     equipped for some fonts; often New Century Schoolbook is missing.
     The font keyword may also be an integer: 0 is Courier, 4 is Times,
     8 is Helvetica, 12 is Symbol, 16 is New Century Schoolbook, and
     you add 1 to get boldface and/or 2 to get italic (or oblique).

     The height is the font size in points; 14.0 is the default.
     X windows only has 8, 10, 12, 14, 18, and 24 point fonts, so
     don't stray from these sizes if you want what you see on the
     screen to be a reasonably close match to what will be printed.

     By default, opaque=0 and text is transparent.  Set opaque=1 to
     white-out a box before drawing the text.  The default orient
     (orient=0) is left-to-right text; set orient=1 for text rotated 90
     degrees so it reads upward, orient=2 for 180 degree rotation so
     it is upside down, and orient=3 for 270 degree rotation so it
     reads downward.

     The default text justification, justify="NN" is normal is both
     the horizontal and vertical directions.  Other possibilities
     are "L", "C", or "R" for the first character, meaning left,
     center, and right horizontal justification, and "T", "C", "H",
     "A", or "B", meaning top, capline, half, baseline, and bottom
     vertical justification.  The normal justification "NN" is equivalent
     to "LA".  Common values are "LA", "CA", and "RA" for garden variety
     left, center, and right justified text, with the y coordinate at the
     baseline of the last line in the string presented to plt.  The
     characters labeling the right axis of a plot are "RH", so that the
     y value of the text will match the y value of the corresponding
     tick.  Similarly, the characters labeling the bottom axis of a plot
     are "CT".  The justify= may also be a number, horizontal+vertical,
     where horizontal is 0 for "N", 1 for "L", 2 for "C", or 3 for "R",
     and vertical is 0 for "N", 4 for "T", 8 for "C", 12 for "H",
     16 for "A", or 20 for "B".

   PLOTTING COMMANDS: plt
   SEE ALSO: color
 */

local region;
/* DOCUMENT region=   plotting keyword
     selects the part of mesh to consider.  The region should match one
     of the numbers in the IREG array.  Putting region=0 (the default)
     means to plot the entire mesh, that is, everything EXCEPT region
     zero (non-existent zones).  Any other number means to plot only
     the specified region number; region=3 would plot region 3 only.
   PLOTTING COMMANDS: plm, plc, plv, plf
 */

local triangle;
/* DOCUMENT triangle=   plotting keyword
     sets the triangulation array for a contour plot.  The triangulation
     array must be the same shape as the IREG (region number) array, and
     the correspondence between mesh zones and indices is the same as
     for IREG.  The triangulation array is used to resolve the ambiguity
     in saddle zones, in which the function Z being contoured has two
     diagonally opposite corners high, and the other two corners low.
     The triangulation array element for a zone is 0 if the algorithm is
     to choose a triangulation, based on the curvature of the first
     contour to enter the zone.  If zone (i,j) is to be triangulated
     from point (i-1,j-1) to point (i,j), then TRIANGLE(i,j)=1,
     while if it is to be triangulated from (i-1,j) to (i,j-1), then
     TRIANGLE(i,j)=-1.  Contours will never cross this "triangulation
     line".
     You should rarely need to fiddle with the traingulation array;
     it is a hedge for dealing with pathological cases.
   PLOTTING COMMANDS: plc
 */

local hollow, aspect;
/* DOCUMENT hollow=   plotting keyword
         or aspect=   plotting keyword
     set the appearance of the "darts" of a vector field plot.  The
     default darts, hollow=0, are filled; use hollow=1 to get just the
     dart outlines.  The default is aspect=0.125; aspect is the ratio
     of the half-width to the length of the darts.  Use the color
     keyword to control the color of the darts.
   PLOTTING COMMANDS: plv
   SEE ALSO: color
 */

local edges, ecolor, ewidth;
/* DOCUMENT edges=   plotting keyword
         or ecolor=   plotting keyword
         or ewidth=   plotting keyword
     set the appearance of zone edges in a filled mesh plot (plf or plfp).
     By default, edges=0, and the zone edges are not plotted.  If
     edges=1, a solid line is drawn around each zone after it is
     filled; the edge color and width are given by ecolor and ewidth,
     which are "fg" and 1.0 by default.
   PLOTTING COMMANDS: plf
   SEE ALSO: color, width
 */

/*--------------------------------------------------------------------------*/
/* Inquiry and editing functions */

extern plq;
/* DOCUMENT plq
         or plq, n_element
         or plq, n_element, n_contour
         or legend_list= plq()
         or properties= plq(n_element, n_contour)
     Called as a subroutine, prints the list of legends for the current
     coordinate system (with an "(H)" to mark hidden elements), or prints
     a list of current properties of element N_ELEMENT (such as line type,
     width, font, etc.), or of contour number N_CONTOUR of element number
     N_ELEMENT (which must be contours generated using the plc command).
     Called as a function, returns either the list of legend strings, or a
     list of pointers to the values of the various element properties.
     Elements and contours are both numbered starting with one; hidden
     elements or contours are included in this numbering.

     The PROPERTIES list returned by plq is a list of pointers to the
     relevent properties for the specified graphical element.  Each
     possible property has a particular index in the returned PROPERTIES
     list as follows:
     *PROPERTIES(1)   int([element type (0 for none, 1 for plg, 2 for pldj,
                                         3 for plt, 4 for plm, 5 for plf,
                                         6 for plv, 7 for plc, 8 for pli,
                                         9 for plfp),
                           hide flag])
     *PROPERTIES(2)   string(legend)
     *PROPERTIES(3)   int array, depends on type (names match keywords):
       1 plg:  [color, type, marks, mcolor, marker, rays, closed, smooth]
       2 pldj: [color, type]
       3 plt:  [color, font, path, justify, opaque]
       4 plm:  [color, type, region, boundary, inhibit]
       5 plf:  [region, edges, ecolor, rgb_flag]
       6 plv:  [region, color, hollow]
       7 plc:  [region, color, type, marks, mcolor, marker, smooth]
       8 pli:  nil
       9 plfp: [edges, ecolor, rgb_flag]
     *PROPERTIES(4)   double array, depends on type (names match keywords):
       1 plg:  [width, msize, mspace, mphase, rspace, rphase, arrowl, arroww]
       2 pldj: [width]
       3 plt:  [height, x, y]
       4 plm:  [width]
       5 plf:  [ewidth]
       6 plv:  [width, aspect, scale]
       7 plc:  [width, msize, mspace, mphase]
       8 pli:  [x0, x1, y0, y1]
     *PROPERTIES(5)   long array, depends on type (names match arguments):
       1 plg:  [npoints, &x, &y]
       2 pldj: [npoints, &x0, &y0, &x1, &y1]
       3 plt:  [nchars, &text]
       4 plm:  [imax, jmax, &x, &y, &ireg]
       5 plf:  [imax, jmax, &x, &y, &ireg, &colors]
       6 plv:  [imax, jmax, &x, &y, &ireg, &vx, &vy]
       7 plc:  [imax, jmax, &x, &y, &ireg, &z, &triangle, nlevs, &levs]
       8 pli:  [imax, jmax, &colors]
       9 plfp: [n, &x, &y, &colors, &pn]
     You can use the reshape function to peek at the data at the addresses
     returned in PROPERTIES(5) as longs.  The appropriate data types are:
     char for text, int for ireg, short for triangle, char for colors, and
     double for everything else.  In a plf, colors is (imax-1)-by-(jmax-1).
     Although PROPERTIES(5) returns pointers to the data plotted, attempting
     to poke new values into this data will not produce immediate changes
     to your plot, since the graphics package does not realize that anything
     has changed.  Use pledit to make changes to plotted elements.

     The plq function always operates on the current coordinate system
     in the current graphics window; use window and plsys to change these.
   SEE ALSO: window, plsys, pledit, pldefault, plg
 */

extern pledit;
/* DOCUMENT pledit, key1=value1, key2=value2, ...
         or pledit, n_element, key1=value1, key2=value2, ...
         or pledit, n_element, n_contour, key1=value1, key2=value2, ...
     changes some property of element number N_ELEMENT (and contour
     number N_CONTOUR of that element).  If N_ELEMENT and N_CONTOUR are
     omitted, the default is the most recently added element, or the
     element specified in the most recent plq query command.

     The keywords can be any of the keywords that apply to the current
     element.  These are:
       plg:  color, type, width,
             marks, mcolor, marker, msize, mspace, mphase,
             rays, rspace, rphase, arrowl, arroww,
             closed, smooth
       pldj: color, type, width
       plt:  color, font, height, path, justify, opaque
       plm:  region, boundary, inhibit, color, type, width
       plf:  region
       plv:  region, color, hollow, width, aspect, scale
       plc:  region, color, type, width,
             marks, mcolor, marker, msize, mspace, mphase
             smooth, levs
     (For contours, if you aren't talking about a particular N_CONTOUR,
      any changes will affect ALL the contours.)

     A plv (vector field) element can also take the scalem
     keyword to multiply all vector lengths by a specified factor.

     A plt (text) element can also take the dx and/or dy
     keywords to adjust the text position by (dx,dy).

   SEE ALSO: window, plsys, plq, pldefault, plg
 */

extern pldefault;
/* DOCUMENT pldefault, key1=value1, key2=value2, ...
     sets default values for the various properties of graphical elements.

     The keywords can be most of the keywords that can be passed to the
     plotting commands:
       plg:  color, type, width,
             marks, mcolor, msize, mspace, mphase,
             rays, rspace, rphase, arrowl, arroww
       pldj: color, type, width
       plt:  color, font, height, path, justify, opaque
       plm:  color, type, width
       plv:  color, hollow, width, aspect
       plc:  color, type, width,
             marks, mcolor, marker, msize, mspace, mphase
       plf:  edges, ecolor, ewidth

     The initial default values are:
       color="fg", type="solid", width=1.0 (1/2 point),
       marks=1, mcolor="fg", msize=1.0 (10 points),
          mspace=0.16, mphase=0.14,
       rays=0, arrowl=1.0 (10 points), arroww=1.0 (4 points),
          rspace=0.13, rphase=0.11375,
       font="helvetica", height=12.0, justify="NN", opaque=0,
       hollow= 0, aspect=0.125,
       edges=0, ecolor="fg", ewidth=1.0 (1/2 point)

     Additional default keywords are:
       dpi, style, legends  (see window command)
       palette              (to set default filename as in palette command)
       maxcolors            (default 200)

   SEE ALSO: window, plsys, plq, pledit, plg
 */

/*--------------------------------------------------------------------------*/
/* Miscellany */

extern bytscl;
/* DOCUMENT bytscl(z)
         or bytscl(z, top=max_byte, cmin=lower_cutoff, cmax=upper_cutoff)
     returns a char array of the same shape as Z, with values linearly
     scaled to the range 0 to one less than the current palette size.
     If MAX_BYTE is specified, the scaled values will run from 0 to
     MAX_BYTE instead.
     If LOWER_CUTOFF and/or UPPER_CUTOFF are specified, Z values outside
     this range are mapped to the cutoff value; otherwise the linear
     scaling maps the extreme values of Z to 0 and MAX_BYTE.
   SEE ALSO: plf, pli, histeq_scale
 */

extern mesh_loc;
/* DOCUMENT mesh_loc(y0, x0)
         or mesh_loc(y0, x0, y, x)
         or mesh_loc(y0, x0, y, x, ireg)
     returns the zone index (=i+imax*(j-1)) of the zone of the mesh
     (X,Y) (with optional region number array IREG) containing the
     point (X0,Y0).  If (X0,Y0) lies outside the mesh, returns 0.
     Thus, eg- ireg(mesh_loc(x0, y0, y, x, ireg)) is the region number of
     the region containing (x0,y0).  If no mesh specified, uses default.
     X0 and Y0 may be arrays as long as they are conformable.

     For mesh_loc wrappers to duplicate the functionality of the
     digitize and interp functions in 2D, see the library file digit2.i.
     After #include "digit2.i", type:  help,digit2

   SEE ALSO: plmesh, moush, mouse
 */

extern mouse;
/* DOCUMENT result= mouse(system, style, prompt)
     displays a PROMPT, then waits for a mouse button to be pressed,
     then released.  Returns array of eleven doubles:
       result= [x_pressed, y_pressed, x_released, y_released,
                xndc_pressed, yndc_pressed, xndc_released, yndc_released,
                system, button, modifiers]

     If SYSTEM>=0, the first four coordinate values will be relative to
     that coordinate system.
     For SYSTEM<0, the first four coordinate values will be relative to
     the coordinate system under the mouse when the button was pressed.
     The second four coordinates are always normalized device coordinates,
     which start at (0,0) in the lower left corner of the 8.5x11 sheet of
     paper the picture will be printed on, with 0.0013 NDC unit being
     1/72.27 inch (1.0 point).  Look in the style sheet for the location
     of the viewport in NDC coordinates (see the style keyword).

     If STYLE is 0, there will be no visual cues that the mouse
     command has been called; this is intended for a simple click.
     If STYLE is 1, a rubber band box will be drawn; if STYLE is 2,
     a rubber band line will be drawn.  These disappear when the
     button is released.

     Clicking a second button before releasing the first cancels the
     mouse function, which will then return nil.
     Ordinary text input also cancels the mouse function, which again
     returns nil.

     The left button reverses forground for background (by XOR) in
     order to draw the rubber band (if any).  The middle and right
     buttons use other masks, in case the rubber band is not visible
     with the left button.

     long(result(9)) is the coordinate system in which the first four
     coordinates are to be interpreted.
     long(result(10)) is the button which was pressed, 1 for left, 2
     for middle, and 3 for right (4 and 5 are also possible).
     long(result(11)) is a mask representing the modifier keys which
     were pressed during the operation: 1 for shift, 2 for shift lock,
     4 for control, 8 for mod1 (alt or meta), 16 for mod2, 32 for mod3,
     64 for mod4, and 128 for mod5.

     Holding the shift key and pressing the left mouse button is
     equivalent to pressing the middle mouse button.  Similarly,
     pressing meta-left is equivalent to the right button.  This
     permits access to the middle and right button functions on
     machines (e.g.- most laptops) with two button or one button
     mice.  The long(result(10)) value returned by mouse() reflects
     this convention, returning 2 or 3 for those cases, even though
     it is button 1 that is actually being pressed.  Therefore, there
     is no way to distinguish shift-left from shift-middle, because the
     long(result(11)) mask indicates tht the shift button is pressed
     in either case.  (And on a machine without a middle button,
     there would be no way to emulate shift-middle anyway.)

   SEE ALSO: moush
 */

func moush(y, x, ireg)
/* DOCUMENT moush()
         or moush(y, x, ireg)
     returns the 1-origin zone index for the point clicked in
     for the default mesh, or for the mesh (X,Y) (region array IREG).
 */
{
  xy= mouse(-1, 0, "<Click mouse in mesh>");
  if (is_void(xy)) return [];
  else return mesh_loc(xy(2), xy(1), y, x, ireg);
}

extern pause;
/* DOCUMENT pause, milliseconds
         or pause(milliseconds)
     pause for the specified number of milliseconds of wall clock
     time, or until input arrives from the keyboard.
     If you call pause as a function, the return value is 1
     if the specified number of milliseconds elapsed, or 0 if
     keyboard input caused the pause to abort.
     This is intended for use in creating animated sequences.
 */

extern rgb_read;
/* DOCUMENT rgb = rgb_read()
         or rgb = rgb_read(n)
     Read contents of current graphics window, or of graphics window N.
     RGB is a 3xNXxNY array of char where NXxNY is the current shape of
     the window in pixels.  RGB(1,,) is the red component, RGB(2,,) is
     the green component, and RGB(3,,) is the blue component, with 0
     black and 255 full intensity.  RGB(,,1) is the top row of the
     window, RGB(,,2) the second row, and so on to RGB(,,0), which is
     the bottom row.  (So RGB(,,::-1) to pli redraws a copy.)
 */

/*--------------------------------------------------------------------------*/

func histeq_scale(z, top=, cmin=, cmax=)
/* DOCUMENT histeq_scale(z, top=top_value, cmin=cmin, cmax=cmax)
     returns a byte-scaled version of the array Z having the property
     that each byte occurs with equal frequency (Z is histogram
     equalized).  The result bytes range from 0 to TOP_VALUE, which
     defaults to one less than the size of the current palette (or
     255 if no pli, plf, or palette command has yet been issued).

     If non-nil CMIN and/or CMAX is supplied, values of Z beyond these
     cutoffs are not included in the frequency counts.

   SEE ALSO: bytscl, plf, pli
 */
{
  if (is_void(top)) top= bytscl([0.,1.])(2);  /* palette size - 1 */
  top= long(top);
  if (top<0 | top>255) error, "top value out of range 0-255";
  y= z(*);
  if (!is_void(cmin)) y= y(where(y>=cmin));
  if (!is_void(cmax)) y= y(where(y<=cmax));
  y= y(sort(y));
  x= span(0.,1., numberof(y));
  xp= span(0.,1., top+2);
  bins= interp(y, x, xp);
  list= where(bins(dif)<=0.0);
  if (numberof(list)) {
    /* some value (or values) of z are repeated many times --
       try to handle this by adding a small slope to the sorted y */
    dy= y(0)-y(1);
    if (!dy) dy= 1.0;
    for (eps=1.e-10 ; eps<1000.1 ; eps*=10.) {
      bins= interp(y+eps*dy*x, x, xp);
      list= where(bins(dif)<=0.0);
      if (!numberof(list)) break;
    }
    if (eps>1000.) error, "impossible error??";
  }
  return char(max(min(digitize(z,bins)-2,top),0));
}

/*--------------------------------------------------------------------------*/

extern viewport;
/* DOCUMENT port= viewport();
     returns [xmin,xmax,ymin,ymax] of the current viewport (or 0,0,0,0
     if currently plotting to system 0) in NDC coordinates.
   SEE ALSO: limits, gridxy
 */

extern raw_style;
/* DOCUMENT raw_style: get_style, set_style, read_style, write_style
            #include "style.i"
     alternatives to the style= keyword of the window command which
     allow the interpreter to set or get all the details of the
     window style.  Include "style.i" and read the help for get_style.
 */

/*--------------------------------------------------------------------------*/

extern _pl_init;
/* xxDOCUMENT _pl_init
     initializes the Gist graphics package -- DON'T EVER CALL THIS.
 */
_pl_init, GISTPATH; /* ...except right here (see paths.i) */

extern keybd_focus;
/* DOCUMENT keybd_focus, on_off
     By default, graphics windows set a window manager hint which
     allows them to accept keyboard focus.  With ON_OFF zero, that
     hint will not be set when a new graphics window is created.
     This causes the window manager to refuse to offer keyboard
     focus to the graphics window -- very desirable, since it can't
     accept keyboard input anyway.  With fvwm, for example, this
     means keyboard focus can stay in the terminal window even when
     you are mouse zooming the graphics window.  However, many
     window managers confuse colormap focus with keyboard focus, so
     if you set the private=1 colormap in the window function, you
     may not be able to convince the window manager to give the
     graphics window colormap focus since it won't give it keyboard
     focus.  Weird.
 */

/*--------------------------------------------------------------------------*/
/* functions which call plg, plf, or other automatic legend generating
 * functions must be defined after _pl_init, since that function turns
 * on argument "quining" which changes the way things are parsed (yuck) */

func plmk(y,x,marker=,width=,color=,msize=)
/* DOCUMENT plmk, y,x

     Make a scatter plot of the points Y versus X.  If X is nil,
     it defaults to indgen(numberof(Y)).  By default, the marker
     cycles through 7 predefined marker shapes.  You may specify a shape
     using the marker= keyword, line width using the width= keyword (you
     get solid fills for width>=10), color using the color= keyword.
     You can also use the msize= keyword to scale the marker (default
     msize=1.0).  You can change the default width, color, or msize
     using the plmk_default function.

     The predefined marker= values are:

     marker=
       1        square
       2        cross
       3        triangle
       4        circle
       5        diamond
       6        cross (rotated 45 degrees)
       7        triangle (upside down)

     You may also put marker=[xm,ym] where xm and ym are vectors
     of NDC coordinates to design your own custom marker shapes.

   SEE ALSO: plmk_default, plg (type=0 keyword), pleb
 */
{
  if (is_void(marker)) {
    marker= (_plmk_count-1)%7 + 1;
    _plmk_count++;
  }
  if (numberof(marker)==1) {
    marker= *_plmk_markers(marker);
  } else if (dimsof(marker)(1)!=2 || dimsof(marker)(3)!=2 ||
             dimsof(marker)(2)<=2) {
    error, "illegal marker= keyword value";
  }
  xm= marker(,1);
  ym= marker(,2);
  if (is_void(msize)) msize= _plmk_msize;
  if (!is_void(msize)) {
    xm*= msize;
    ym*= msize;
  }
  if (is_void(color)) color= _plmk_color;
  if (structof(color)==string) {
    n= where(color==["bg","fg","black","white",
                     "red","green","blue","cyan","magenta","yellow"]);
    if (numberof(n)!=1) error, "unrecognized color name: "+color;
    color= char(-n(1));
  }
  ecolor= color;
  if (is_void(width)) width= _plmk_width;
  if (!is_void(width)) {
    if (width>=10) {
      solid= 1;
      if (is_void(color)) color= ecolor= char(-2);
      z= array(char(color), 1+numberof(y));
      width= [];
    }
  }
  n= array(1,1+numberof(y));
  n(1)= numberof(ym);
  if (is_void(x)) x= indgen(numberof(y));
  plfp, z,grow(ym,y),grow(xm,x),n,edges=1,ewidth=width,ecolor=ecolor;
}

func plmk_default(color=, msize=, width=)
/* DOCUMENT plmk_default, color=color, msize=msize, width=width

     sets default color, msize, and width values for plmk.  Use
     width=10 to get solid fills.  With no parameters, plmk_default
     restores the initial default values.

   SEE ALSO: plmk
 */
{
  { extern _plmk_color, _plmk_width, _plmk_msize; }
  i= 0;
  if (!is_void(color)) _plmk_color= color;
  else i++;
  if (!is_void(width)) _plmk_width= width;
  else i++;
  if (!is_void(msize)) _plmk_msize= msize;
  else i++;
  if (i==3) _plmk_msize= _plmk_color= _plmk_width= [];
}

_plmk_count= 1;
_plmk_msize= _plmk_color= _plmk_width= [];
/* predefined markers: square, +, delta, circle, diamond, x, grad */
_plmk_markers= span(-pi,pi,37)(zcen);
_plmk_markers= [&([[-1,1,1,-1],[-1,-1,1,1]]*.007),
                &([[-4,-1,-1,1,1,4,4,1,1,-1,-1,-4],
                   [-1,-1,-4,-4,-1,-1,1,1,4,4,1,1]]*.007/sqrt(7)),
                &([[-sqrt(3),sqrt(3),0],[-1,-1,2]]*.007/sqrt(.75*sqrt(3))),
                &([cos(_plmk_markers),sin(_plmk_markers)]*.007/(pi/4.)),
                &([[-1,0,1,0],[0,-1,0,1]]*.007*sqrt(2)),
                &([[-1,-2.5,-1.5,0,1.5,2.5,1,2.5,1.5,0,-1.5,-2.5],
                   [0,-1.5,-2.5,-1,-2.5,-1.5,0,1.5,2.5,1,2.5,1.5]]*.007*
                  sqrt(2)/sqrt(7)),
                &([[0,sqrt(3),-sqrt(3)],[-2,1,1]]*.007/sqrt(.75*sqrt(3)))];

func plfc(z, y, x, ireg, levs=, colors=, region=, triangle=)
/* DOCUMENT plfc, z, y, x, levs=z_values
         or plfc, z, y, x, ireg, levs=z_values

     fills contours of Z on the mesh Y versus X.  Y, X, and IREG are
     as for plm.  The Z array must have the same shape as Y and X.
     The function being contoured takes the value Z at each point
     (X,Y) -- that is, the Z array is presumed to be point-centered.

     The LEVS keyword is a list of the values of Z at which you want
     contour curves.  These curves divide the mesh into numberof(LEVS)+1
     regions, each of which is filled with a solid color.  If LEVS is
     nil, up to 19 "nice" equally spaced level values spanning the
     range of Z are selected.  The level values actually used are
     always output to the external variable plfc_levs.

     If you specify levs=, you may also specify colors= a list of
     colors of length numberof(LEVS)+1.  The colors should be indices
     into the current palette.  If you do not specify them, equally
     spaced colors are chosen.

     The following keywords are legal (each has a separate help entry):
   KEYWORDS: triangle, region
   SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp, plmesh
             color_bar, spann, contour, limits, logxy, range, fma, hcp
 */
{
  zmin= min(z);
  zmax= max(z);
  if (is_void(levs)) {
    levs= spann(zmin, zmax, 20, fudge=-0.05);
  } else if (numberof(levs)>1) {
    levs = double(levs);
    dz= levs(dif); /* blows up if <2 or not numeric */
    reverse= max(dz);
    if (numberof(dz)!=numberof(levs)-1 ||
        anyof((dz>0.)!=(reverse>0.)) || !reverse)
      error, "levs= values must be monotone 1D";
    reverse= reverse<0.;
    if (reverse) levs= levs(0:1:-1);
    else levs= levs(1:0);
  } else {
    levs= [double(levs(1))];
  }
  { extern plfc_levs, plfc_colors; }
  plfc_levs= levs;
  n= numberof(levs);

  pairs= [grow([min(-1.e30,1.1*zmin)],levs),
          grow(levs,[max( 1.e30,1.1*zmax)])];
  if (reverse) pairs= pairs(0:1:-1,);

  /* make sure some kind of reasonable palette is installed */
  { local nc, yc, xc; }
  palette, query=1, nc, yc, xc;
  nc= numberof(nc);
  if (nc<3) {
    palette, "earth.gp";
    palette, query=1, nc, yc, xc;
    nc= numberof(nc);
  }

  if (is_void(colors)) {
    colors= char(span(0,nc-1,n+2)(zcen));
  } else {
    if (numberof(colors)!=n+1)
      error, "colors= must specify one more color than levs=";
    if (structof(colors)!=char) {
      cmin= min(colors);
      cmax= max(colors);
      dz= 0.5*(cmax-cmin)/double(n+1);
      colors= bytscl(colors,cmin=cmin-dz,cmax=cmax+dz);
    }
  }
  plfc_colors= colors;

  if (is_void(triangle)) triangle= array(short,dimsof(z));

  for (i=1 ; i<=n+1 ; ++i) {
    pair= pairs(i,);
    if (pair(2)<zmin || pair(1)>zmax) continue;
    nc= contour(yc,xc, pair,z,y,x,ireg,triangle=triangle);
    if (!numberof(nc)) continue;
    plfp,array(colors(i),numberof(nc)),yc,xc,nc,edges=0;
  }
}

func spann(zmin, zmax, n, fudge=)
/* DOCUMENT spann(zmin, zmax, n)
     return no more than N equally spaced "nice" numbers between
     ZMIN and ZMAX.
   SEE ALSO: span, spanl, plc, plfc
 */
{
  if (is_void(fudge)) fudge= 
  reverse= zmin>zmax;
  if (reverse) { dz=zmin; zmin=zmax; zmax=dz; }
  dz= (zmax-zmin)/max(double(n),0.);
  if (!dz) dz= abs(zmin);
  if (dz) {
    power= floor(log10(dz)+0.00001);
    base= dz/10.^power;
    if (base>5.00001) { base= 1.0; power+= 1.0; }
    else if (base>2.00001) base= 5.0;
    else base= 2.0;
    /* round dz up to the nearest "nice" number */
    dz= base*10.^power;
    zmin= ceil(zmin/dz - fudge);
    zmax= floor(zmax/dz + fudge);
    nz= long(zmax-zmin+1.0);
    if (nz>1) {
      levs= span(zmin*dz, zmax*dz, nz);
    } else {
      if (nz<1) {   /* find any nice number in interval */
        if (base<1.5) { base= 5.0; power-= 1.0; }
        else if (base<2.5) base= 1.0;
        else base= 2.0;
        dz= base*10.^power;
        zmin= ceil(zmin/dz + 0.001);
      }
      levs= [zmin*dz];
    }
  } else {
    levs= [-1.0,1.0];
  }
  if (reverse) levs= levs(0:1:-1);
  return levs;
}

func color_bar(levs, colors, vert=, labs=, adjust=, ecolor=)
/* DOCUMENT color_bar
         or color_bar, levs, colors
     Draw a color bar below the current coordinate system.  If LEVS is
     not specified uses plfc_levs (set by previous call to plfc).  If
     COLORS is specified, it should have one more value than LEVS,
     otherwise equally spaced colors are chosen, or plfc_colors if
     plfc_levs was used.  With the vert=1 keyword the color bar appears
     to the left of the current coordinate system (vert=0 is default).
     By default, color_bar will attempt to label some of the color
     interfaces.  With the labs= keyword, you can force the labelling
     algorithm as follows: labs=0 supresses all labels, labs=n forces
     a label at every nth interface, labs=[i,n] forces a label at every
     nth interface starting from interface i (0<=i<=numberof(LEVS)).
     You can use the adjust= keyword to move the bar closer to (adjust<0)
     or further from (adjust>0) the viewport, and the height= keyword to
     set the height of any labels (default 14 points).
   SEE ALSO: plfc
 */
{
  if (is_void(levs)) {
    if (is_void(plfc_levs)) error, "no levels specified";
    levs= plfc_levs;
    n= numberof(levs)+1;
    if (is_void(colors)) colors= plfc_colors;
  } else {
    n= numberof(levs)+1;
    if (is_void(colors)) colors= bytscl(span(1,n,n),cmin=0.5,cmax=n+0.5);
  }
  if (n != numberof(colors))
    error, "numberof(colors) must be one more than numberof(levs)";

  port= viewport();
  if (is_void(adjust)) adjust= 0.;
  dx= dy= 0.;
  if (vert) {
    x= (port(2)+adjust+[0.022,0.042])(-:1:n+1,);
    dx= 0.005;
    y= span(port(3),port(4),n+1)(,-:1:2);
  } else {
    y= (port(3)-adjust-[0.045,0.065])(-:1:n+1,);
    dy= -0.005;
    x= span(port(1),port(2),n+1)(,-:1:2);
  }
  sys= plsys(0);
  plf,[colors],y,x,edges=1,ecolor=ecolor, legend="";
  plsys, sys;

  if (is_void(labs) || labs(0)>0) {
    if (numberof(levs)>1) {
      dz= levs(dif);
      if (numberof(dz)!=numberof(levs)-1 ||
          anyof((dz>0.)!=(dz(1)>0.)) || !dz(1))
        error, "levs must be monotone 1D";
      levs= levs(1:0);
      levs= grow([2*levs(1)-levs(2)],levs,[2*levs(0)-levs(-1)]);
    } else {
      levs= double(levs(1));
      if (!levs) levs= [-1.,levs,1.];
      else levs= [0.,levs,2*levs];
    }
    if (numberof(labs)<2) {
      if (is_void(labs)) labs= (n-1)/4 + 1;
      orig= where(levs<1.e-9*max(levs(dif)));
      if (numberof(orig)==1) labs= [orig(1)%labs,labs];
      else labs= [(n%labs)/2,labs];
    }
    list= where(indgen(0:n)%labs(2)==labs(1));
    x= x(list,);
    y= y(list,);
    labs= swrite(format="%g",levs(list));
    plsys, 0;
    pldj, x(,2),y(,2),x(,2)+dx,y(,2)+dy, legend="";
    plsys, sys;
    plt1, labs,x(,2)+dx,y(,2)+dy, justify=(vert?"LH":"CT"), height=height,
      font="helvetica";
  }
}

/* pleb from Regis Lachaume 2003 */
func pleb (y, x, dx=, dy=, mfill=, color=, width=, marker=, msize=) 
/* DOCUMENT pleb, y, x, dx=dx, dy=dy
     plots Y vs. X with error bars.

     Uncertainty on X and/or Y are specified with the dx= and dy= keywords.
     X and Y must have same dimensions, dx= and dy= must be conformable
     with X (or Y).  Either dx or dy may be nil for no error bar in that
     direction.  Scalar dx or dy gives equal error bars at all points,
     dimsof(dx)==dimsof(X), etc., gives different error bar at each point.
     dx= and dy= may also have a trailing dimension of length 2 in order
     to get asymmetric error bars; dx(..,1) is the lower error bar length,
     and dx(..,2) is the upper error bar length in that case, etc.

     If marker=, msize=, or width= is specified, markers are positioned
     at X, Y using plmk.  Use the mfill=1 keyword to get filled markers
     (width>=10. in plmk; width= refers to error bar width in pleb).

   EXAMPLE:
      x = [0, 1, 2, 3];
      y = [0, 2, 4, 7];
      pleb, y, x, dx=0.2, dy=[0.3, 0.4, 0.5, 0.3], mfill=1;
         Uncertainties on dx are the same for all X, and those
         on Y are different for each value of Y.  Filled markers
         will be displayed at (X, Y).

   KEYWORDS: color, width, marker, msize
      dx     uncertainty on X
      dy     uncertainty on Y

   SEE ALSO: plmk, pldj
 */
{
  if (is_void(dx)) dx = 0.;
  if (is_void(dy)) dy = 0.;

  xmin = x-dx;
  xmax = x+dx;
  if (numberof(x) != numberof(xmin)) {
    xmin = xmin(..,1);
    xmax = xmax(..,2);
  }

  ymin = y-dy;
  ymax = y+dy;
  if (numberof(y) != numberof(ymin)) {
    ymin = ymin(..,1);
    ymax = ymax(..,2);
  }

  pldj, x, ymin, x, ymax, color=color, width=width, legend="";
  pldj, xmin, y, xmax, y, color=color, width=width, legend="";
  if (!is_void(marker) || !is_void(msize) || !is_void(mfill))
    plmk, y, x, color=color, msize=msize, marker=marker,
      width=(mfill? 20.: width);
}

/*--------------------------------------------------------------------------*/
%FILE% haender.i
/********************************************************************
 *
 *  Haender i bridge
 *
 *  Vaerdi:
 *  1-13 Spar, 14-26 Hjerter, 27-39 Ruder, 40-52 Kloer
 *  1: Es, 4 points, 11,12,13: Bonde, Dame, Konge, 1,2,3 points
 *
 *  Fordeling:
 *  1-13 Syd, 14-26 Ost, 27-39 Nord, 40-52 Vest
 *
 *    fordel     Blander kortene og returnerer et 'bord'
 *    mfordel    Blander antal gange som angivet og opdaterer 'Borde'
 *    vis        Viser et 'bord' paa terminalen (gemmer evt. i en fil)
 *    udvalg     Vaelger et antal fordelinger fra 'Borde', der opfylder
 *               at NS og OV faar lige mange HP.
 *    
 ********************************************************************/

Farver = ["Spar   ", "Hjerter", "Ruder  ", "Klor   "];
Placering = ["Syd ", "Vest", "Nord", "Ost "];
Borde = [];
randomize;

struct s_Fordeling {
   int kort(52);
   int points(4);
   int ns;
   int ov;
}

func mfordel( n, init= )
/* DOCUMENT mfordel, n, init=

    Producerer n fordelinger og lagrer i 'Borde', som opdateres,
    hvis den allerede eksisterer. Keyword 'init' vil slette
    Borde for at starte forfra.

*/
{
   extern Borde;
   if( init ) Borde = [];
   ekstra = array(s_Fordeling,n);
   for(i=1;i<=n;i++) ekstra(i) = fordel();
   grow, Borde, ekstra;
}

func fordel( void )
{
   bord = s_Fordeling();
   r = random(52);
   kort = int(sort(r));
   bord.kort = kort;
   points = array(int,4);
   ns = ov = 0;
   for(plads=1;plads<=4;plads++) {
      pstart = (plads-1)*13+1;
      pkort = kort(pstart:pstart+12);
      pkort = pkort(sort(pkort));
      points(plads) += 4*numberof(where(pkort%13==1));
      points(plads) += 3*numberof(where(pkort%13==0));
      points(plads) += 2*numberof(where(pkort%13==12));
      points(plads) +=   numberof(where(pkort%13==11));
   }
   bord.points = points;
   bord.ns = sum(points(1:4:2));
   bord.ov = sum(points(2:4:2));

   return bord;
}

func vis( bord, fil= )
/* DOCUMENT vis, bord, fil=

   Hvis 'fil' ogsaa er givet, skrives der til denne
   i fortsaettelse
*/
{
   if( typeof(fil) == "string" ) {
      out = open(fil,"a");
   } else {
      out = [];
   }
   kort = bord.kort;
   points = array(int,4);

   for( plads = 1; plads <= 4; plads++ ) {
      pstart = (plads-1)*13+1;
      pkort = kort(pstart:pstart+12);
      pkort = pkort(sort(pkort));
      plsum  = 4*numberof(where(pkort%13==1)); // Esser
      plsum += 3*numberof(where(pkort%13==0)); // Konger
      plsum += 2*numberof(where(pkort%13==12)); // Damer
      plsum +=   numberof(where(pkort%13==11)); // knaegte
      points(plads) = plsum;
   }
   write,out,format="\n ********   NS : %i HP,  OV : %i HP ********\n\n", \
         sum(points(1:3:2)),sum(points(2:4:2));
   for( plads = 1; plads <= 4; plads++ ) {
      write,out,format="%s -------------- %i HP\n", \
                               Placering(plads),points(plads);
      pstart = (plads-1)*13+1;
      pkort = kort(pstart:pstart+12);
      pkort = pkort(sort(pkort));
      for( farve = 1; farve <= 4; farve++ ) {
         str = Farver(farve)+"  ";
         fstart = (farve-1)*13+1;
         w = where(pkort >= fstart & pkort <= fstart+12);
         nfkort = numberof(w);
         if( nfkort ) {
            fkort = pkort(w)-fstart+1;
            // Er der et es?
            if(fkort(1)==1) {
               str += "A ";
               nfkort--;
               if(nfkort) fkort = fkort(2:0);
            }
         } else {
            str += "-";
         }
         if( nfkort ) {
            fkort = fkort(indgen(nfkort:1:-1));
            while( nfkort >= 1 ) {
               if( fkort(1) == 13 ) {
                  str += "K ";
               } else if( fkort(1) == 12 ) {
                  str += "D ";
               } else if( fkort(1) == 11 ) {
                  str += "B ";
               } else if( fkort(1) == 10 ) {
                  str += "T ";
               } else {
                  str += swrite(format="%i ",fkort(1));
               }
               nfkort--;
               if(nfkort)fkort = fkort(2:0);
            }
         }
         write,out,format="    %s\n", str;
      }
   }
   if(!is_void(out)) close, out;
}

func udvalg( n, hp_fra, hp_til )
/* DOCUMENT udv = udvalg( n, hp_fra, hp_til )

   udvaelger n spil (n maa vaere lige) med samme antal hp
   til N-S og O-V fra eksisterende array 'Borde'
*/
{
   extern Borde;

   if( numberof(Borde) < n ) {
      write,"Der for faa fordelinger i 'Borde', koer mfordel ...";
      return [];
   }

   n /= 2;
   hp = long(span(hp_fra,hp_til,n)+0.5);

   udv = numberof(Borde)+1; // pick an impossible one
   for( i = 1; i <= n; i++ ) {
      w = where(Borde.ns == hp(i));
      nw = numberof(w);
      if( nw ) {
         for( j = 1; j <= nw; j++ ) {
            if( allof(w(j)-udv) ) {
               grow,udv,w(j);
               break;
            }
         }
         if( j > nw ) write,format="Ikke flere fordelinger med %i hp\n", hp(i);
      } else {
         write,format="Ups, mangler NS fordeling med %i hp\n", hp(i);
      }
      w = where(Borde.ov == hp(i));
      nw = numberof(w);
      if( nw ) {
         for( j = 1; j <= nw; j++ ) {
            if( allof(w(j)-udv) ) {
               grow,udv,w(j);
               break;
            }
         }
         if( j > nw ) write,format="Ikke flere fordelinger med %i hp\n", hp(i);
      } else {
         write,format="Ups, mangler OV fordeling med %i hp\n", hp(i);
      }
   }
   udv = udv(2:0);

   // bland raekkefoelgen
   nudv = numberof(udv);
   return udv(sort(random(nudv)));
}
%FILE% healpix.i
/* -----------------------------------------------------------------------------
 *
 *  Copyright (C) 1997-2010 Krzysztof M. Gorski, Eric Hivon,
 *                          Benjamin D. Wandelt, Anthony J. Banday,
 *                          Matthias Bartelmann,
 *                          Reza Ansari & Kenneth M. Ganga
 *
 *
 *  This file is part of HEALPix.
 *
 *  HEALPix is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  HEALPix 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.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with HEALPix; if not, write to the Free Software
 *  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 *
 *  For more information about HEALPix see http://healpix.jpl.nasa.gov
 *
 *----------------------------------------------------------------------------- */

extern healpixdoc;
/* DOCUMENT  HELPix package
 *
 *    pix2ang_nest
 *    ang2pix_nest
 *    mk_pix2xy
 *
 *    Translated to Yorick from C 2010-12-08/NJW
 *
 */

/* Function pix2ang_nest */

func pix2ang_nest( nside, ipix, &theta, &phi)
/* DOCUMENT pix2ang_nest, nside, ipix, >theta, >phi

    subroutine pix2ang_nest(nside, ipix, theta, phi)

    'ipix' numbering from zero

    c     gives theta and phi corresponding to pixel ipix (NESTED)
    c     for a parameter nside
    c=======================================================================
*/
{
      // int npix, npface, face_num;
      // int  ipf, ip_low, ip_trunc, ip_med, ip_hi;
      // int     ix, iy, jrt, jr, nr, jpt, jp, kshift, nl4;
      // double z, fn, fact1, fact2;
      // double piover2=0.5*M_PI;
      // int ns_max=8192;

      piover2 = 0.5*pi;
      ns_max = int(8192);

      extern pix2x, pix2y;
      //      common /pix2xy/ pix2x, pix2y

      pix2x = pix2y = array(int, 1024);
      jrll = jpll = array(int, 12);

      //int jrll(12), jpll(12);// ! coordinate of the lowest corner of each face
      //      data jrll/2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4/ ! in unit of nside
      //      data jpll/1, 3, 5, 7, 0, 2, 4, 6, 1, 3, 5, 7/ ! in unit of nside/2
      jrll(1)=2;
      jrll(2)=2;
      jrll(3)=2;
      jrll(4)=2;
      jrll(5)=3;
      jrll(6)=3;
      jrll(7)=3;
      jrll(8)=3;
      jrll(9)=4;
      jrll(10)=4;
      jrll(11)=4;
      jrll(12)=4;
      jpll(1)=1;
      jpll(2)=3;
      jpll(3)=5;
      jpll(4)=7;
      jpll(5)=0;
      jpll(6)=2;
      jpll(7)=4;
      jpll(8)=6;
      jpll(9)=1;
      jpll(10)=3;
      jpll(11)=5;
      jpll(12)=7;


      if( nside<1 || nside>ns_max ) error,"nside out of range";
      npix = 12 * nside*nside;
      if( ipix<0 || ipix>npix-1 ) error,"ipix out of range";

      /* initiates the array for the pixel number -> (x,y) mapping */
      //if( pix2x(1023)<=0 ) mk_pix2xy(pix2x,pix2y);
      if( pix2x(1023)<=0 ) mk_pix2xy; // Operates on pix2x and pix2y as externals

      fn = 1.*nside;
      fact1 = 1./(3.*fn*fn);
      fact2 = 2./(3.*fn);
      nl4   = 4*nside;

      //c     finds the face, and the number in the face
      npface = nside*nside;

      face_num = ipix/npface;//  ! face number in {0,11}
      ipf = ipix%npface;//  ! pixel number in the face {0,npface-1}

      //c     finds the x,y on the face (starting from the lowest corner)
      //c     from the pixel number
      ip_low = ipf%1024;//       ! content of the last 10 bits
      ip_trunc =   ipf/1024 ;//       ! truncation of the last 10 bits
      ip_med = ip_trunc%1024;//  ! content of the next 10 bits
      ip_hi  =     ip_trunc/1024;//! content of the high weight 10 bits

      ix = 1024*pix2x(ip_hi+1) + 32*pix2x(ip_med+1) + pix2x(ip_low+1);
      iy = 1024*pix2y(ip_hi+1) + 32*pix2y(ip_med+1) + pix2y(ip_low+1);

      //c     transforms this in (horizontal, vertical) coordinates
      jrt = ix + iy;//  ! 'vertical' in {0,2*(nside-1)}
      jpt = ix - iy;//  ! 'horizontal' in {-nside+1,nside-1}

      //c     computes the z coordinate on the sphere
      //      jr =  jrll(face_num+1)*nside - jrt - 1;//   ! ring number in {1,4*nside-1}
      jr =  jrll(face_num+1)*nside - jrt - 1;
      //      cout << "face_num=" << face_num << endl;
      //      cout << "jr = " << jr << endl;
      //      cout << "jrll(face_num)=" << jrll(face_num) << endl;
      //      cout << "----------------------------------------------------" << endl;
      nr = nside;//                  ! equatorial region (the most frequent)
      z  = (2*nside-jr)*fact2;
      kshift = (jr - nside) % 2;
      if( jr<nside ) { //then     ! north pole region
         nr = jr;
         z = 1. - nr*nr*fact1;
         kshift = 0;
      }
      else {
	if( jr>3*nside ) {// then ! south pole region
         nr = nl4 - jr;
         z = - 1. + nr*nr*fact1;
         kshift = 0;
	}
      }
      theta = acos(z);

      //c     computes the phi coordinate on the sphere, in (0,2Pi)
      //      jp = (jpll(face_num+1)*nr + jpt + 1 + kshift)/2;//  ! 'phi' number in the ring in {1,4*nr}
      jp = (jpll(face_num+1)*nr + jpt + 1 + kshift)/2;
      if( jp>nl4 ) jp = jp - nl4;
      if( jp<1 )   jp = jp + nl4;

      phi = (jp - (kshift+1)*0.5) * (piover2 / nr);

}

/* Function mk_pix2xy */

func mk_pix2xy( void )
/* DOCUMENT mk_pix2xy, >pix2x, >pix2y
   * subroutine mk_pix2xy
   * =======================================================================
   * constructs the array giving x and y in the face from pixel number
   * for the nested (quad-cube like) ordering of pixels
   *
   * the bits corresponding to x and y are interleaved in the pixel number
   * one breaks up the pixel number by even and odd bits
   * =======================================================================
   */
{
  //int i, kpix, jpix, IX, IY, IP, ID;
  //for (i = 0; i < 1023; i++) pix2x[i]=0;
   extern pix2x, pix2y;

   pix2x(*) = 0;

  for( kpix=0;kpix<1024;kpix++ ) {
    jpix = kpix;
    IX = 0;
    IY = 0;
    IP = 1 ;//              ! bit position (in x and y)
    while( jpix!=0 ){// ! go through all the bits
      ID = jpix%2;//  ! bit value (in kpix), goes in ix
      jpix = jpix/2;
      IX = ID*IP+IX;

      // ID = (int)fmod(jpix,2);//  ! bit value (in kpix), goes in iy
      ID = jpix%2;
      jpix = jpix/2;
      IY = ID*IP+IY;

      IP = 2*IP;//         ! next bit (in x and y)
    }

    pix2x(kpix+1) = IX;//     ! in 0,31
    pix2y(kpix+1) = IY;//     ! in 0,31
  }

  /* Later */
  return;
}


/* Function ang2pix_nest */

func ang2pix_nest( nside, theta, phi, &ipix)
/* DOCUMENT ang2pix_nest

   * subroutine ang2pix_nest(nside, theta, phi, >ipix)
   * =======================================================================
   * gives the pixel number ipix (NESTED) corresponding to angles theta and phi
   *
   * the computation is made to the highest resolution available (nside=8192)
   * and then degraded to that required (by integer division)
   * this doesn't cost more, and it makes sure that the treatement of round-off
   * will be consistent for every resolution
   * =======================================================================
*/
{
  /*
   * double z, za, z0, tt, tp, tmp;
   * int    face_num,jp,jm;
   * long   ifp, ifm;
   * int    ix, iy, ix_low, ix_hi, iy_low, iy_hi, ipf, ntt;
   * double piover2 = 0.5*M_PI, pi = M_PI, twopi = 2.0*M_PI;
   * int    ns_max = 8192;
   * static int x2pix[128], y2pix[128];
   * static char setup_done = 0;
   */

   extern x2pix, y2pix;
   extern setup_done;

   ns_max = int(8192);
   piover2 = 0.5 * pi;
   twopi   = 2.0 * pi;

   if( nside<1 || nside>ns_max ) error,"nside is out of range";
   if( theta<0. || theta>pi ) error,"theta out of range";
   if( !setup_done ) {
     mk_xy2pix; // Creating x2pix and y2pix as externals
     setup_done = 1;
   }

   z  = cos(theta);
   za = abs(z);
   z0 = 2./3.;
   if( phi>=twopi ) phi = phi - twopi;
   if( phi<0. )    phi = phi + twopi;
   tt = phi / piover2; /* in [0,4[ */

   if( za<=z0 ) { /* equatorial region */

     /* (the index of edge lines increase when the longitude=phi goes up) */
     jp = int(floor(ns_max*(0.5 + tt - z*0.75))); /* ascending edge line index */
     jm = int(floor(ns_max*(0.5 + tt + z*0.75))); /* descending edge line index */

     /* finds the face */
     ifp = jp / ns_max; /* in {0,4} */
     ifm = jm / ns_max;

     if( ifp==ifm ) face_num = int(ifp%4 + 4); /* faces 4 to 7 */
     else if( ifp<ifm ) face_num = int(ifp%4); /* (half-)faces 0 to 3 */
     else face_num = int(ifm%4) + 8;           /* (half-)faces 8 to 11 */

     ix = int(jm%ns_max);
     iy = ns_max - int(jp%ns_max) - 1;
   }
   else { /* polar region, za > 2/3 */

     ntt = int(floor(tt));
     if( ntt>=4 ) ntt = 3;
     tp = tt - ntt;
     tmp = sqrt( 3.*(1. - za) ); /* in ]0,1] */

     /* (the index of edge lines increase when distance from the closest pole
      * goes up)
      */
     /* line going toward the pole as phi increases */
     jp = int(floor( ns_max * tp          * tmp ));

     /* that one goes away of the closest pole */
     jm = int(floor( ns_max * (1. - tp) * tmp ));
     jp = int((jp < ns_max-1 ? jp : ns_max-1));
     jm = int((jm < ns_max-1 ? jm : ns_max-1));

     /* finds the face and pixel's (x,y) */
     if( z>=0 ) {
       face_num = ntt; /* in {0,3} */
       ix = ns_max - jm - 1;
       iy = ns_max - jp - 1;
     }
     else {
       face_num = ntt + 8; /* in {8,11} */
       ix =  jp;
       iy =  jm;
     }
   }

   ix_low = int(ix%128);
   ix_hi  =     ix/128;
   iy_low = int(iy%128);
   iy_hi  =     iy/128;

   ipf = (x2pix(ix_hi+1)+y2pix(iy_hi+1)) * (128 * 128)+ (x2pix(ix_low+1)+y2pix(iy_low+1));
   ipf = long(ipf / ((ns_max/nside)^2));     /* in {0, nside**2 - 1} */
   ipix =long(( ipf + face_num*(nside^2))); /* in {0, 12*nside**2 - 1} */
}

/* Function mk_xy2pix */

func mk_xy2pix( void )
  /* =======================================================================
   * subroutine mk_xy2pix
   * =======================================================================
   * sets the array giving the number of the pixel lying in (x,y)
   * x and y are in {1,128}
   * the pixel number is in {0,128**2-1}
   *
   * if  i-1 = sum_p=0  b_p * 2^p
   * then ix = sum_p=0  b_p * 4^p
   * iy = 2*ix
   * ix + iy in {0, 128**2 -1}
   * =======================================================================
   */
{
   /* int i, K,IP,I,J,ID; */

   extern x2pix, y2pix;

   x2pix = y2pix = array( int(0), 128);

   for( I=1;I<=128;I++ ) {
     J  = I-1;//            !pixel numbers
     K  = 0;//
     IP = 1;//
     truc : if( J==0 ) {
       x2pix(I-1+1) = K;
       y2pix(I-1+1) = 2*K;
     }
     else {
       ID = J%2;
       J  = J/2;
       K  = IP*ID+K;
       IP = IP*4;
       goto truc;
     }
   }

}

/* Function healpix2aitoffmap */

func healpix2aitoffmap( hp_fits_file, map_file_name, mapdim )
/* DOCUMENT healpix2aitoffmap( hp_fits_file, map_file_name, mapdim )

*/
{
   d2r = pi/180.0;

   dol = hp_fits_file+"+1";
   hdr = headfits( dol );
   nside = fxpar( hdr, "nside" );
   hpix = rdfitscol( dol, 1 );
   mapdim2 = 2 * mapdim;
   mapdimh = mapdim / 2;
   map = array(float,mapdim2,mapdim);

   // Loop over map to fill out with HEALPix signal

   step = 360./mapdim2;
   for( i = 1; i <= mapdim2; i++ ) {
      x = (i - mapdim - 0.5) * step;
      for( j = 1; j <= mapdim; j++ ) {
         y = (j - mapdimh - 0.5) * step;
         // Get WCS coordinates for map position
         r = rever_aitoff( x, y );
         if( is_void(r) ) continue;
         // Get HEALPIX number for position
         theta = (90. - r(2))*d2r;
         phi = zero2pi(-r(1)*d2r);
         ang2pix_nest, nside, theta, phi, ipix;
         map(i,j) = hpix(ipix+1); // ipix counts from zero
      }
   }
   kwds_init;
   kwds_set,"extname","GLOBEMAP","name of extension";
   kwds_set,"maptype","PROJECTMAP","Map subjected to Aitoff projection";
   kwds_set,"ctype1","GLON-AIT","Hammer-Aitoff projection";
   kwds_set,"ctype2","GLAT-AIT","Hammer-Aitoff projection";
   kwds_set,"crpix1", mapdim+0.5,"reference pixel";
   kwds_set,"crpix2", mapdimh+0.5,"reference pixel";
   kwds_set,"crval1",   0.0,"reference pixel value";
   kwds_set,"crval2",   0.0,"reference pixel value";
   kwds_set,"cdelt1",  -step*0.9,"degrees/pixel";
   kwds_set,"cdelt2",   step*0.9,"degrees/pixel";

   writefits, map_file_name, map;

   write,"Job is done";

}
%FILE% i2y.i
/*****************************************
    Translate IDL code to Yorick code
    as far as practical

   Method: Read next line
               if just a comment the replace ; with // and continue
                else remove comment and save where ';' has been replaced by '//'
               replace all quoted strings with qqq... (save, but replace
                                       single quotes with double quotes)
               Analyze what is left
                   - start of 'for' loop, raise for-level
                   - single line 'for' loop
                   - start of 'while' loop, raise while-level
                   - single line 'while' loop
                   - start of 'if' block, raise if-level
                   - single line 'if' statement
                   - end of 'for' loop, lower for-level
                   - end of 'while' loop, lower while-level
                   - end of 'if' block, lower if-level
                          --->  change to yorick syntax
                   - ordinary statement
                          ---> append ';'
                Reinstate saved quoted string
                Reinstate saved comment
   2006-02-11/NJW

   exwords
   unquote
*****************************************/
func exwords( line )
{
   len = strlen( line );
   if( len == 0 ) return [];
   res = array(string, 1);
   t = strtok( line, " ,\t\n");
   res(1) = t(1);
   while( t(2) ) {
      t = strtok( t(2), " ,\t\n");
      grow, res, t(1);
   }
   return res;
}
func unquote( line_in, &quotes )
{
   line = line_in;
   p = 0;
   k = 1;
   quotes = array(string,1);
   while( (p = strpos( line, "'", p+1 ) ) ) {
      q = strpos( line, "'", p+1 );
      if( q == 0 ) {
         write,"Missing quote\n";
         quotes = [];
         return line;
      }
      if( k == 1 ) {
         quotes = strpart( line, p:q);
      } else {
         grow, quotes, strpart( line, p:q );
      }
      k++;
      for( i=p, s=""; i <= q; ++i ) s += "q";
      streplace, line, [p-1,q], s;
   }
   return line;
}
%FILE% ia_file_selection.i
/************************************************************
 *
 *  A visual or graphical selection of a file
 *
 *  Package with functions:
 *        ia_file_selection
 *        directory_selection
 *        file_selection
 *
 **************************************************************/

/* Function ia_file_selection */

func ia_file_selection( start_dir, &res_dir, sel= )
/* DOCUMENT file = ia_file_selection( start_dir, >res_dir, sel= )

    Argument: start_dir tells where to start the search
                if omitted the current directory will be used.
              res_dir is returned as the last directory searched.
    Keyword: 'sel' is used as an argument for 'strglob' to present
             only a selection of files.

    2011-12-16/NJW
*/
{
   cwind = window();
   cwd = get_cwd();
   if( !is_void(start_dir) ) cd, start_dir;

   do {
      status = directory_selection(sel=sel);
      if( status ) {
         window,cwind;
         return [];
      }
      res_dir = get_cwd();
      file = file_selection(sel=sel);
   } while ( structof(file) == int );

   cd,cwd;
   write,"Now back in "+get_cwd();
   window,cwind;
   write,"  - and using window "+itoa(cwind);
   return file;
}

func directory_selection( sel= )
{
   local subdirs;

   // List directories

   window,7,style="nobox.gs";
   files = lsdir(".",subdirs);
   files = files(sort(files));
   nfiles = numberof(files);
   cwd = get_cwd();
   if( cwd != "/" ) grow,subdirs,"..";

   nsubdirs = numberof(subdirs);

   if( nsubdirs ) {
      subdirs = subdirs(sort(subdirs));
      nbatches = (nsubdirs-1)/60 + 1;
      ibatch = 1;

      showbatch:

      //+ write,"Showing batch#"+itoa(ibatch)+" of "+itoa(nbatches);
      nbstart = (ibatch - 1)*60 + 1;
      nbstop  = ibatch == nbatches ? nsubdirs : ibatch*60;

      plot,[0,0,1,1,0],[0,1,1,0,0];
      xyouts,0.16,0.894,esc_underscore(get_cwd()),charsize=0.7,font="schoolbook",ndc=1;
      y = 0.95;
      x = 0.1;
      xarr = yarr = [];
      for( i = nbstart; i <= nbstop; i++ ) {
         oplot,[x-0.05],[y+0.010],ps=19,symsize=0.35,color="blue";
         xyouts,x,y,esc_underscore(subdirs(i)),charsize=0.7,font="schoolbook",color="blue";
         grow, xarr, x - 0.05;
         grow, yarr, y + 0.01;
         y -= 0.031;
         if( y < 0.02 ) {
            x = 0.6;
            y = 0.95;
         }
      }
      // Draw box for shift to plain files but only if there are some
      if( nfiles ) {
         xyouts,0.5,0.015,"Go to files",charsize=0.8,font="schoolbook",color="green",align=0.5;
         oplot,0.3*([0,0,1,1,0]-0.5)+0.5,0.04*([0,1,1,0,0]-0.5)+0.025,color="green";
         grow, xarr, 0.5;
         grow, yarr, 0.025;
      } else {
         grow, xarr, 10.; // make values that can never be selected
         grow, yarr, 10.;
      }
      // When more directories exist then show arrow
      if( ibatch < nbatches ) {
         oplot,[0.98],[0.02],ps=21,fill=1,symsize=0.8,color="red";
         grow, xarr, 0.98;
         grow, yarr, 0.02;
         flagforw = 1;
      } else flagforw = 0;
      // When less directories exist then show arrow
      if( ibatch > 1 ) {
         oplot,[0.02],[0.98],ps=20,fill=1,symsize=0.8,color="red";
         grow, xarr, 0.02;
         grow, yarr, 0.98;
         flagbackw = 1;
      } else flagbackw = 0;

      r = curmark1(prompt="Select the directory ...",nomark=1);
      d = (xarr - r(1))^2 + (yarr - r(2))^2;
      idx = d(mnx);
      //+ write,"Min d = "+ftoa(d(idx),ndec=5);
      if( d(idx) > 0.02 ) return 1; // stop when too far from selection
      if( idx < numberof(xarr)-flagforw-flagbackw ) {
         //+ write,"You chose a subdirectory: "+subdirs(idx+nbstart-1)+", confirm ...";
         oplot,[xarr(idx)],[yarr(idx)],ps=19,symsize=0.35,color="red";
         r = curmark1(prompt="Confirm the selection ...",nomark=1);
         d = (xarr - r(1))^2 + (yarr - r(2))^2;
         idx2 = d(mnx);
         //+ write,"Min d = "+ftoa(d(idx2),ndec=5);
         if( d(idx2) > 0.02 ) return 1; // stop when too far from selection
         if( idx == idx2 ) {
            //+ write,"Yes, confirmed!";
            cd, subdirs(idx+nbstart-1);
         } //+ else write,"Try again!";
         status = directory_selection(sel=sel);
      } else {
         if( idx == numberof(xarr) - flagforw - flagbackw ) {
            //+ write,"You'll move to file selection.";
         } else {
            if( idx == numberof(xarr) - flagbackw ) {
               // move forwards
               //+ write," - forward move";
               ibatch++;
               goto showbatch;
            } else {
               // move backwards
               //+ write," - backward move";
               ibatch--;
               goto showbatch;
            }
         }
      }
   }
   return 0; // flag status OK at return
}


/* Function file_selection */


func file_selection( sel= )
{
   extern Previous_selections;

   local subdirs;

   // List files

   window,7,style="nobox.gs";
   files = lsdir(".",subdirs);
   if( !is_void(sel) ) {
      w = where(strglob(sel,files));
      files = numberof(w) ? files(w) : [];
   }

   nfiles = numberof(files);

   if( nfiles ) {
      files = files(sort(files));
      nbatches = (nfiles-1)/60 + 1;
      ibatch = 1;

      showbatch:

      //+ write,"Showing batch#"+itoa(ibatch)+" of "+itoa(nbatches);
      nbstart = (ibatch - 1)*60 + 1;
      nbstop  = ibatch == nbatches ? nfiles : ibatch*60;

      plot,[0,0,1,1,0],[0,1,1,0,0];
      xyouts,0.16,0.894,esc_underscore(get_cwd()),charsize=0.7,font="schoolbook",ndc=1;
      y = 0.95;
      x = 0.1;
      xarr = yarr = [];
      for( i = nbstart; i <= nbstop; i++ ) {
         // Check for previous selections
         if( numberof(Previous_selections) ) {
            if( numberof(where(Previous_selections == fullpath(files(i)))) ) {
               oplot,[x-0.05],[y+0.010],ps=19,symsize=0.3,color="yellow",fill=1;
            }
         }
         oplot,[x-0.05],[y+0.010],ps=19,symsize=0.35,color="green";
         xyouts,x,y,esc_underscore(files(i)),charsize=0.7,font="schoolbook",color="green";
         grow, xarr, x - 0.05;
         grow, yarr, y + 0.01;
         y -= 0.031;
         if( y < 0.02 ) {
            x = 0.6;
            y = 0.95;
         }
      }

      // Draw box for shifting back to directory
      xyouts,0.5,0.015,"Go back to directory",charsize=0.8,font="schoolbook",color="blue",align=0.5;
      oplot,0.3*([0,0,1,1,0]-0.5)+0.5,0.04*([0,1,1,0,0]-0.5)+0.025,color="blue";
      grow, xarr, 0.5;
      grow, yarr, 0.025;

      // When more files exist then show arrow
      if( ibatch < nbatches ) {
         oplot,[0.98],[0.02],ps=21,fill=1,symsize=0.8,color="red";
         grow, xarr, 0.98;
         grow, yarr, 0.02;
         flagforw = 1;
      } else flagforw = 0;
      // When less directories exist then show arrow
      if( ibatch > 1 ) {
         oplot,[0.02],[0.98],ps=20,fill=1,symsize=0.8,color="red";
         grow, xarr, 0.02;
         grow, yarr, 0.98;
         flagbackw = 1;
      } else flagbackw = 0;

      r = curmark1(prompt="Select a file ...",nomark=1);
      d = (xarr - r(1))^2 + (yarr - r(2))^2;
      idx = d(mnx);
      //+ write,"Min d = "+ftoa(d(idx),ndec=5);
      if( d(idx) > 0.02 ) return []; // stop when too far from selection
      if( idx == numberof(xarr)-flagforw-flagbackw ) return int(1);
      if( idx < numberof(xarr)-flagforw-flagbackw ) {
         //+ write,"You chose a file: "+files(idx+nbstart-1)+", confirm ...";
         oplot,[xarr(idx)],[yarr(idx)],ps=19,symsize=0.35,color="red";
         r = curmark1(prompt="Confirm selection ...",nomark=1);
         d = (xarr - r(1))^2 + (yarr - r(2))^2;
         idx2 = d(mnx);
         //+ write,"Min d = "+ftoa(d(idx2),ndec=5);
         if( d(idx2) > 0.02 ) return []; // stop when too far from selection
         if( idx == idx2 ) {
            //+ write,"Yes, confirmed!";
            grow, Previous_selections, fullpath(files(idx+nbstart-1));
            return fullpath(files(idx+nbstart-1));
         } else {
            //+ write,"Try again:";
            return file_selection(sel=sel);
         }
      } else {
         if( idx == numberof(xarr) - flagforw - flagbackw ) {
            //+ write,"You'll move to file selection.";
         } else {
            if( idx == numberof(xarr) - flagbackw ) {
               // move forwards
               //+ write," - forward move";
               ibatch++;
               goto showbatch;
            } else {
               // move backwards
               //+ write," - backward move";
               ibatch--;
               goto showbatch;
            }
         }
      }
   }
}

ifs = ia_file_selection;
//+ write,"Shorthand: ifs for ia_file_selection.";
%FILE% icons_dat.i
/* Function icons_dat */

func icons_dat( rev )
/* DOCUMENT  icons_dat, rev

   will compare the old pointing files (pointings_RRRRp.dat)
   with the ones retrieved from ISDC consolidated data
   (pointings_RRRRp.icons)

   Argument 'rev' is the revolution number

   2006-10-04/NJW
*/
{
   require, "idlx.i";
   require, "scom.i";
   require, "plot.i";
   require, "image.i";
   require, "fits.i";
   require, "mfits.i";

   revstr = swrite(format="%04i", rev);

   if( "/nfs/r6/jemx/pointings/icons/" != get_cwd() ) {
      write,"Must be run from /r6/jemx/pointings/icons !";
      return;
   }

   ysav = openb("../ysav/pointings_"+revstr+"p.ysav");
   restore, ysav;
   close, ysav;

   iswid = rscol("pointings_"+revstr+"p.icons",1,str=1,silent=1);
   ira = rscol("pointings_"+revstr+"p.icons",2,silent=1);
   idec = rscol("pointings_"+revstr+"p.icons",3,silent=1);

   write,format="%i SWIDs in ysav, revol %s\n", numberof(swid), revstr;
   write,format="%i SWIDs in icons\n", numberof(iswid);

// check what SWIDs in ysav are missing in icons

   disagree = 0;
   common_swids = [];
   n_swid = numberof(swid);
   for( i = 1; i <= n_swid; i++ ) {
      w = where( swid(i) == iswid );
      nw = numberof(w);
      if( nw != 1 ) {
         write,format="The ysav SWID %s is found %i times in icons\n", \
                   swid(i), nw;
         disagree++;
      } else {
         grow, common_swids, swid(i);
      }
   }

// check what SWIDs in icons are missing in ysav

   n_iswid = numberof(iswid);
   for( i = 1; i <= n_iswid; i++ ) {
      w = where( iswid(i) == swid );
      nw = numberof(w);
      if( nw != 1 ) {
         write,format="The icons SWID %s is found %i times in ysav\n", \
                   iswid(i), nw;
         disagree++;
      }
   }



   if( !disagree ) {
      write,"The SWIDs are in perfect agreement";
   }

   n_com = numberof(common_swids);
   write,format="%i common swids\n", n_com;

//  Extract angular deviations for the common swids

   r = array( double, n_com);
   x = indgen(n_com);
   for( i = 1; i <= n_com; i++ ) {
      v = where( common_swids(i) == iswid );
      u = where( common_swids(i) == swid );
      right = ra(u(1));
      decli = dec(u(1));
      iright = ira(v(1));
      idecli = idec(v(1));
      r(i) = arcdist( right, decli, iright, idecli ) * 3600.0;
   }

   mxr = max(r);
   if( mxr > 1.0 && mxr <= 15. ) {
      write,format="Warning! Max deviation is %5.2f arcsec. Revol %s\n", mxr, revstr;
   }
   if( mxr > 15. ) {
      write,format="****  Serious Warning! *******  Max deviation is %8.2f arcmin. Revol %s\n",\
             mxr/60.0, revstr;
   }
   plot, x, r, ps=2,title=revstr, ytitle="arcsec";
}
%FILE% idlx.i
extern idlxdoc;
/* DOCUMENT idlx package
 *
 *  Additional IDL type functions
 *
 *  Coming: file_test where type (dir or file) can be specified
 *          Also return value will indicate if gzipped version of
 *          file exists.
 *
 *  2004-08-23/Niels J. Westergaard
 *  2008-05-16/NJW, updated with get_boundaries
 *
       _arr_integral       get_par             shift
       _is_digit           histo               sigdig
       app_slash           histos              sost
       arcdist             hpd                 str2arr
       arr_accum           icoef_polyn         str_erase_between_symbols
       arr_fill_in         interp2             str_get_words
       arr_info            is_digit            strcharrepl
       arr_integral        is_fnumber          strcompare
       array_gauss         is_number           strcompress
       array_igauss        linscale            strdelcom
       arrcat              local_rms           itoa
       atof                makeimageu          strip_curly_br
                           makeimagez          message_board
       atoi                maxarr              strjoin
       cent2bds            maxim               strlowcase
       chi2                monincr             strpadd
       circ_area1          most_freq_elem      strpos
       construct_matrix    ndate               strput
       construct_rhs       outlier             strsplit
       dcoef_polyn         parpath             strstrrepl
       ddpolyn             pick_swid_str       strupcase
       dpolyn              poly_fit            systime
       draw_from_dist      polyn               toint
       esc_underscore      qmcompare           tolong
       extract_box         qmstrpos1           wavg
       file_rsearch        qmstrpos2           write_slist
       file_search         read_slist          wrms
       file_test           rem_slash           wvar
       fold_gaussx         rm_slashcom         xjour
       get_boundaries      set_par             zero2pi
       get_next_filename   shd_upd             zero360
       f2scienota          ranstr              datagroups
       fold_gaussy         strinsert
*/

/* Function arr_integral */

func arr_integral( x, y, a, b )
/* DOCUMENT arr_integral( x, y, a, b )

   Integrate the array 'y' : sum(y*dx) over the interval
   where a < x < b

*/
{
   nx = numberof(x);
   ny = numberof(y);
   if( nx < 1 ) error,"ARR_INTEGRAL ##1## too few array elements";
   if( nx != ny ) error,"ARR_INTEGRAL ##2## mismatching array sizes";
/*
 * Use the array elements with a < x < b (index range w)
 *  and expand arrays : x -> [a, x(w), b]
 *                      y -> [ya, y(w), yb]
 *  where ya and yb are adequately interpolated values
 */

   if( is_void(a) ) a = x(1);
   if( is_void(b) ) b = x(0);
   a = double(a);
   b = double(b);

   w = where( x >= a & x <= b );
   nw = numberof(w);
   yy = interp( y, x, a);
   yb = interp( y, x, b);
   xx = a;

   if( nw ) {

      grow, xx, x(w), b;
      grow, yy, y(w), yb;

   } else {

      grow, xx, b;
      grow, yy, yb;

   }

   return _arr_integral( xx, yy );

}

/* Function _arr_integral */

func _arr_integral( x, y )
/* DOCUMENT _arr_integral( x, y )

   Integrate the array 'y' : sum(y*dx) over all elements
   x limits are x(1) and x(0)

*/
{
   nx = numberof(x);
   ny = numberof(y);
   if( nx < 1 ) error,"_ARR_INTEGRAL ##1## too few array elements";
   if( nx != ny ) error,"_ARR_INTEGRAL ##2## mismatching array sizes";

   d = double(x(2:0) - x(1:-1));
   z = 0.5*(y(1:-1) + y(2:0));
   return sum(d*z);
}

/* Function get_boundaries */

func get_boundaries( x_arr, &x1_arr, &x2_arr, gol= )
/* DOCUMENT get_boundaries, x_arr, >x1_arr, >x2_arr, gol=

   Assume x_arr has increasing values,
   Keyword gol: If set produce boundaries in log(x_arr)

   x1_arr(i) < x_arr(i) < x2_arr(i)

*/
{
   if( gol ) {
      lx_arr = log(x_arr);
      d = lx_arr(dif);
      xcen = exp(lx_arr(1:-1) + 0.5*d);
      x1_arr = exp(lx_arr(1) - 0.5*d(1)); grow, x1_arr, xcen;
      x2_arr = xcen; grow, x2_arr, exp(lx_arr(0) + 0.5*d(0));
   } else {
      d = x_arr(dif);
      xcen = x_arr(1:-1) + 0.5*d;
      x1_arr = x_arr(1) - 0.5*d(1); grow, x1_arr, xcen;
      x2_arr = xcen; grow, x2_arr, x_arr(0) + 0.5*d(0);
   }
}

/* Function arr_accum */

func arr_accum( arr, norm= )
/* DOCUMENT accumulated_array = arr_accum( arr, norm= )

   Accumulate value of array 'arr'. Keyword 'norm' for
   normalization to 1. (largest value).

   2007-05-03/NJW
   2010-04-16/NJW Updated to use 'psum'
*/
{
   new_arr = arr(psum);
   if( norm ) {
      new_arr = double(new_arr)/new_arr(max);
   }

   return new_arr;

}

/* Function histos */

func histos( y, &h, &x, bmin=, bmax=, binsize= )
/* DOCUMENT histos, y, >h, >x, bmin=, bmax=, binsize=

   returns the histogram of the y (array) values in 'h'
   and the bin centers in 'x'. Optional keywords for
   bin-min, bin-max, and bin-size.

   SEE ALSO: histo - extended functionality but somewhat slower

   2007-04-25/NJW updated with test for number of bins

*/

{

   n_y = numberof(y);
   ymin = min(y);
   ymax = max(y);
   binmin = is_void(bmin) ? ymin - 0.01*(ymax - ymin) : bmin;
   binmax = is_void(bmax) ? ymax + 0.01*(ymax - ymin) : bmax;
   binsiz = is_void(binsize) ? 1.0 : binsize;
   nbins = long( (binmax - binmin) / binsiz - 1.e-5 ) + 1;
   if( nbins <= 1 ) {
      write,"HISTOS error: Number of bins less than 2!";
      return;
   }
   spanx = nbins * binsiz;
   overshoot = spanx - (binmax - binmin);
   binmin -= (overshoot/2);
   binmax += (overshoot/2);
   boundaries = span(binmin, binmax, nbins+1);
   x = span(binmin+0.5*binsiz, binmax-0.5*binsiz, nbins );
   h = array(double,nbins);
   idx = long((y(where(y>=binmin))-binmin)/binsiz) + 1;
   w = where( idx <= nbins );
   idx = idx(w);
   n_idx = numberof(idx);
   for( i = 1; i<= n_idx; i++ ) {
      h(idx(i))++;
   }
}

/* Function histo */

func histo( y, &h, &x, bmin=, bmax=, binsize=, bds=, weight= )
/* DOCUMENT histo, y, >h, >x, bmin=, bmax=, binsize=, bds=, weight=

   returns the histogram of the y (array) values in 'h'
   and the bin centers in 'x'. Optional keywords for
   bin-min, bin-max, and bin-size.
   Keyword 'bds' gives bin boundaries as an array. The
        number of bins is one less than the number of elements
        in this array.

   Keyword 'weight' can be an array conformable with 'y'.

   SEE ALSO: histos - faster but does not have the bds keyword

*/

{

   n_y = numberof(y);
   if( numberof(weight) == 0 ) {
      weight = array(1.,n_y);
   } else {
      if( numberof(weight) != n_y ) error,"weight not conformable with y";
   }

   if( is_void(bds) ) {

      ymin = min(y);
      ymax = max(y);
      binmin = is_void(bmin) ? ymin - 0.01*(ymax - ymin) : bmin;
      binmax = is_void(bmax) ? ymax + 0.01*(ymax - ymin) : bmax;
      binsiz = is_void(binsize) ? 1.0 : binsize;
      nbins = long( (binmax - binmin) / binsiz - 1.e-5 ) + 1;
      if( nbins <= 1 ) {
         write,"HISTO error: Number of bins less than 2!";
         return;
      }
      spanx = nbins * binsiz;
      overshoot = spanx - (binmax - binmin);
      binmin -= (overshoot/2);
      binmax += (overshoot/2);
      boundaries = span(binmin, binmax, nbins+1);
      x = span(binmin+0.5*binsiz, binmax-0.5*binsiz, nbins );

   } else {

      binmin = bds(1);
      binmax = bds(0);
      nbins = numberof(bds)-1;
      if( nbins <= 1 ) {
         write,"HISTO error: Number of bins less than 2!";
         return;
      }
      boundaries = bds;
      x = 0.5*(bds(2:0) + bds(1:-1));

   }
   h = array(double,nbins);
   for( i = 1; i<= n_y; i++ ) {
      w = where( boundaries < y(i) );
      if( numberof(w) > 0 ) if( w(0) <= nbins ) h(w(0)) += weight(i);
   }
}

/* Function maxim */

func maxim( image, &maxval, &xc, &yc, chat= )
/* DOCUMENT maxim, image, >maxval, >xc, >yc, chat=

   returns the maximum on an image as well as the
   coordinates (pixel numbers) in the arguments.
   Keyword 'chat' will cause a display on the screen.
*/

{

   dms = dimsof(image);
   maxval = max(image);
   idx = where(image == maxval)(1) - 1;
   yc = idx / dms(2);
   xc = idx - yc*dms(2) + 1;
   yc++;
   if( chat ) \
   write,format="Max: %11.3g, pos: (%i,%i)\n", double(maxval), xc, yc;

}

/* Function maxarr */

func maxarr( arr, &maxval, &idxvec )
/* DOCUMENT maxarr, arr, >maxval, >idxvector

   returns the maximum of an array as well as the
   vector with indices.
*/
{
   maxval = max(arr);
   idx = where(arr == maxval)(1);
   idxvec = indices(arr,idx);
}

/* Function strcharrepl */

func strcharrepl( str, oldchar, newchar, all= )
/* DOCUMENT res = strcharrepl( str, oldchar, newchar, all= )

   Replaces every occurrence of character or string 'oldchar' in
   string or string array 'str' with character or string 'newchar'.
   Default operation will eliminate leading, trailing, and
   duplicated occurrences.

   The keyword 'all' will ensure that ALL occurrences are replaced.

*/
{
   n = numberof(str);
   if( n == 0 ) return [];
   if( n == 1 ) {
      tok = strsplit( str, oldchar, nocompress=all );
      return strjoin( tok, newchar );
   } else {
      res = array(string,n);
      for(i=1;i<=n;i++) {
         tok = strsplit( str(i), oldchar, nocompress=all );
         res(i) = strjoin( tok, newchar );
      }
      return res;
   }
}

/* Function strpadd */

func strpadd( str, length, paddchar, rj=, truncate= )
/* DOCUMENT res = strpadd( str, length, paddchar, rj=, truncate= )

   Return string 'str' (may be scalar or array) padded to length 'length' with
      character 'paddchar' (may be given as a string or a char).
   It not given 'paddchar' defaults to space.
   If keyword 'rj' is set then it is right justified (padding to the left).
   If keyword 'truncate' is set then the string is truncated if its length
       exceeds 'length'
*/
{
   if( is_void(paddchar) ) paddchar = ' ';

   if( is_scalar(str) ) {
      return _strpadd( str, length, paddchar,rj=rj,truncate=truncate);
   } else {
      n = numberof(str);
      res = array(string,n);
      for(i=1;i<=n;i++) res(i) = _strpadd( str(i), length, paddchar,rj=rj,truncate=truncate);
      return res;
   }
}

/* Function _strpadd */

func _strpadd( str, length, paddchar, rj=, truncate= )
/* DOCUMENT res = _strpadd( str, length, paddchar, rj=, truncate= )

   Work function for 'strpadd'.

   Return string 'str' (must be scalar) padded to length 'length' with
      character 'paddchar' (may be given as a string or a char).
   If keyword 'rj' is set then it is right justified (padding to the left).
   If keyword 'truncate' is set then the string is truncated if its length
       exceeds 'length'
*/
{
   // change to char representation if required (only first character)
   if( structof(paddchar) == string ) paddchar = (*pointer(paddchar))(1);
   if( numberof(paddchar) != 1 ) error,"STRPADD error, illegal paddchar";
   cstr = *pointer(str);
   len = numberof(cstr);
   if(len>1){
      cstr = cstr(1:-1); // get rid of trailing end-character
   }else{
      cstr = []; // if empty string input then remove completely
   }
   len--;
   if( length == len ) return str; // a perfect match
   if( length < len ) {
      if( truncate ) {
         l = len - length; // number of characters to remove
         if( rj ) {
            return strpart(str,l+1:0);
         } else {
            return strpart(str,1:length);
         }
      } else {
         return str;
      }
   }
   a = array(paddchar,length-len);
   res = [];
   if( rj ) {
      grow, res, a, cstr, '\0';
   } else {
      if( is_void(cstr) ) {
         grow, res, a, '\0';
      } else {
         grow, res, cstr, a, '\0';
      }
   }

   return string(&res);

}

/* Function strstrrepl */

func strstrrepl( str, oldstr, newstr )
/* DOCUMENT res = strstrrepl( str, oldstr, newstr )

   Replaces every occurrence of string 'oldstr' in 'str' with
   'newstr'.
   'str' can be an array of strings.

*/
{
   n = numberof( str );

   len_oldstr = strlen(oldstr);
   len_newstr = strlen(newstr);
   outstr = str;

   for( i = 1; i <= n; i++ ) {

      p1 = 1;
      wstr = str(i);

      while(1) {
         pos = strpos( wstr, oldstr, p1 );
         if( !pos ) break;
         len_str = strlen(wstr);

         part1 = pos > 1 ? strpart( wstr, 1:pos-1 ) : "";
         part2 = pos+len_oldstr <= len_str ? strpart( wstr, pos+len_oldstr:0) : "";
         wstr = part1 + newstr + part2;
         p1 = pos+len_newstr;
      }
      outstr(i) = wstr;

   }
   return outstr;
}

/* Function strjoin */

func strjoin( str, sep )
/* DOCUMENT res = strjoin( str, sep )

   The string array 'str' is returned as a single
   string glued together with the string 'sep'

*/
{
   n = numberof(str);
   if( n == 1 ) return str(1);
   newstr = str(1);
   for( i = 2; i <= n; i++ ) {
      newstr += sep + str(i);
   }
   return newstr;
}

/* Function toint */

func toint( argu )
/* DOCUMENT res = toint( argu )

   Returns an integer value of 'argu' that can be
   a string, a float, or a double

*/
{
   if( "string" == typeof(argu) ) {
      return int(atoi(argu));
   } else {
      return int(argu);
   }
}

/* Function tolong */

func tolong( argu )
/* DOCUMENT res = tolong( argu )

   Returns an long integer value of 'argu' that can be
   a string, a float, or a double

*/
{
   if( "string" == typeof(argu) ) {
      return atoi(argu);
   } else {
      return long(argu);
   }
}

/* Function atoi */

func atoi( str )
/* DOCUMENT res = atoi( str )

   Returns the decimal value of an array of
   strings as a long array

*/
{
   val = 1;
   n = numberof(str);
   narr = array( long, n );
   for(i=1;i<=n;i++) {
      m = sread( str(i), val );
      narr(i) = val;
   }
   return n == 1 ? narr(1) : narr;
}

/* Function atof */

func atof( str )
/* DOCUMENT res = atof( str )

   Returns the decimal value of an array of
   strings as a double array

*/
{
   val = 1.0;
   n = numberof( str );
   darr = array( double, n );
   for(i=1;i<=n;i++) {
      m = sread( str(i), val );
      darr(i) = val;
   }
   return n == 1 ? darr(1) : darr;
}

/* Function is_digit */

func is_digit( str, sgn= )
/* DOCUMENT res = is_digit( str, sgn= )

   Returns array of same dimension as 'str' indicating
   if only digits are present.
   With keyword 'sgn' initial signs (+-) will also be accepted.

   Argument str must be a string scalar or array.
*/
{
   n_str = numberof(str);
   if( n_str == 0 ) return [];
   if( structof(str) != string ) error,"IS_DIGIT bad argument";
   if( n_str > 1 ) {
      res = array(0,n_str);
      for( i = 1; i <= n_str; i++ ) {
         res(i) = _is_digit( str(i), sgn=sgn );
      }
      return res;
   } else return _is_digit( str(1), sgn=sgn );
}

func _is_digit( str, sgn= )
/* DOCUMENT res = _is_digit( str, sgn= )

   Returns 1 if string 'str' only contains digits
   zero otherwise.
   With keyword 'sgn' initial signs (+-) will also be accepted.

*/
{
   len = strlen(str);
   if( !len ) return 0;
   // check for initial + or - and remove if present
   // when keyword 'sgn' has been set
   if( sgn ) {
      c = strpart( str, 1:1 );
      if( c == "-" || c == "+" ) {
         str = strpart(str, 2:0);
         len--;
         if( !len ) return 0; // a "+" and "-" string is not accepted
      }
   }
   for( i = 1; i <= len; i++ ) {
      c = strpart( str, i:i );
      p = strpos( "0123456789", c, 1);
      if( p < 1 ) return 0;
   }
   return 1;
}

/* Function is_number */

func is_number( str )
/* DOCUMENT res = is_number( str )

   Returns 1 if string 'str' is a valid number,
   integer or floating point, zero otherwise.

*/
{
   if( is_digit(str) ) return 1; // simple integer
   // check for preceding sign
   c = strpart(str,1:1);
   if( c == "+" || c == "-" ) str = strpart( str,2:0);
   if( is_digit(str) ) return 1; // signed integer
   str = strupcase( str );
   pose = strpos( str, "E", 1 );
   if( pose < 1 ) { // 'E' was not found
      return is_fnumber( str, nosign=1 );
   } else {         // This is E-format number
      if( pose == strlen(str) ) return 0; // illegal to end with 'E'
      // check string before the 'E'
      sbefore = strpart(str,1:pose-1);
      if( !is_digit( sbefore ) ) {
         // if not an integer then it must be an f-number
         if( !is_fnumber( sbefore, nosign=1 ) ) return 0;
      }

      // check string after

      safter = strpart(str, pose+1:0 );
      // check for preceding sign
      c = strpart(safter,1:1);
      if( c == "+" || c == "-" ) safter = strpart( safter,2:0);
      return is_digit( safter );
   }
}


/* Function is_fnumber */

func is_fnumber( str, nosign= )
/* DOCUMENT res = is_fnumber( str, nosign= )

   Returns 1 if string 'str' is a valid f-format number,
   i.e. floating point, zero otherwise.
   If keyword 'nosign' is set then no sign can be present.

*/
{
   // check for preceding sign and remove if present
   if( !nosign ) {
      c = strpart(str,1:1);
      if( c == "+" || c == "-" ) str = strpart( str,2:0);
   }

   // check for decimal point
   posd = strpos( str, ".", 1 );
   if( posd < 1 ) return 0; // Must be present
   len = strlen( str );
   if( len == 1 ) return 0; // Only decimal point is present
   if( posd > 1 ) {
      if( !is_digit(strpart(str,1:posd-1)) ) return 0;
                        // only digits are accepted before the decimal point
   }
   if( posd < len ) {
      if( !is_digit(strpart(str,posd+1:len)) ) return 0;
                        // only digits are accepted after the decimal point
   }
   return 1; // Passed all tests

}


/* Function itoa */

func itoa( n, ndig, plus= )
/* DOCUMENT res = itoa( n, ndig, plus= )

   Returns a string with neither leading nor trailing
   blanks. The optional second argument gives the number of
   digits e.g.
     > itoa(25,4)
    "0025"

   Keyword 'plus' causes a '+' sign when the number is positive.

*/
{
   ss = "";
   if( plus && n > 0 ) ss = "+";
   if( is_void(ndig) ) {
      return swrite(long(n),format=ss+"%i");
   } else {
      return swrite(long(n),format=ss+"%0"+itoa(ndig)+"i");
   }
}

/* Function ftoa */

func ftoa( x, ndec=, plus=, sci= )
/* DOCUMENT res = ftoa( x, ndec=, plus=, sci= )

   Returns a string with neither leading not trailing blanks.
   The number of decimals (i.e. 'd' in %fw.d) can be defined by
   keyword 'ndec'.
   If keyword 'plus' has been set then a plus-sign (+) will precede
   the number if zero or positive.
   The keyword 'sci' forces e-format (scientific format).

*/
{
   dx = double(x);
   if( is_void(ndec) ) return swrite(dx,format="%g");
   adx = abs(dx);
   fmt = "%."+itoa(ndec);
   if( plus && dx >= 0.0 ) fmt = "+"+fmt;
   if( sci || (adx != 0.0 && (adx > 1.e6 || adx < 1.e-6)) ) {
      fmt += "e";
   } else fmt += "f";
   return swrite(dx,format=fmt);
}

/* Function sost */

func sost( x, x0, lambda )
/* DOCUMENT res = sost( x, x0, lambda )

      2003-04-07/NJW (IDL version)
      2006-08-23/NJW Yorick version

   Return exponential low value cutting function

*/
{
   sz = dimsof(x);
   if( sz(1) == 0 ) {
      if( x <= x0 ) {
         return 0.5*exp((x-x0)/lambda);
      } else {
        return 1.-0.5*exp((x0-x)/lambda);
      }
   } else {
      res = array( double, sz);
      w = where( x <= x0 );
      if( (nw = numberof(w)) > 0 ) res(w) = 0.5*exp((x(w)-x0)/lambda);
      w = where( x > x0 );
      if( (nw = numberof(w)) > 0 ) res(w) = 1. - 0.5*exp((x0 - x(w))/lambda);
   }
   return res;
}



/* Function strupcase */

func strupcase( str )
/* DOCUMENT res = strupcase( str )

   Returns a string converted to upper case

*/
{
   strup = str;
   strcase,1,strup;
   return strup;
}

/* Function strlowcase */

func strlowcase( str )
/* DOCUMENT res = strlowcase( str )

   Returns a string converted to lower case

*/
{
   strlow = str;
   strcase,0,strlow;
   return strlow;
}


/* Function write_slist */

func write_slist( filename, list, app= )
/* DOCUMENT write_slist, filename, list, app=

    Writes the string array 'list' to the file given by 'filename'
    Keyword 'app' causes the list to be appended.
    2007-02-16/NJW
*/

{
   if( app ) {
      f = open( filename, "a" );
   } else {
      f = open( filename, "w" );
   }
   n = numberof(list);
   for( i = 1; i <= n; i++ ) {
      nw = write(f, format="%s\n", list(i));
   }
   close,f;
}

/* Function read_slist */

func read_slist( filename )
/* DOCUMENT list = read_slist( filename )

   Reads the text file content of file 'filename' into a string array
   Same as 'rdfile', but returns a void if the file is not found.
*/
{
   if( file_test( filename ) ) {
      return rdfile( filename );
   }
   return [];
}

/* Function polyn */

func polyn( x, c )
/* DOCUMENT res = polyn( x, c )

    Evaluates the polynomium given by coefficients in array 'c'
    for all x values given by 'x'

    res = c(1) + x*c(2) + x^2*c(3) + ...
*/
{

   n = numberof(c);
   t = c(0);
   for( i = 1; i < n; i++ ) t = c(-i) + t*x;
   return t;

}


/* Function dpolyn */

func dpolyn( x, c )
/* DOCUMENT res = dpolyn( x, c )

    Evaluates the first derivative of the polynomium given
    by coefficients in array 'c' for all x values given by 'x'
*/
{

   n = numberof(c);
   if( n == 1 ) return x*0;
   if( n == 2 ) return array(c(2),numberof(x));
   a = indgen(n) - 1;
   return polyn( x, a(2:0)*c(2:0));
}

/* Function ddpolyn */

func ddpolyn( x, c )
/* DOCUMENT res = ddpolyn( x, c )

    Evaluates the second derivative of the polynomium given
    by coefficients in array 'c' for all x values given by 'x'
*/
{

   n = numberof(c);
   if( n <= 2 ) return x*0;
   if( n == 3 ) return array(2*c(3),numberof(x));
   a = indgen(n) - 1;
   b = shift(a,-1);
   return polyn( x, b(3:0)*a(3:0)*c(3:0));
}

/* Function dcoef_polyn */

func dcoef_polyn( c )
/* DOCUMENT new_coefs = dcoef_polyn( c )

   Returns coefficents for derivative of a polynomium
*/
{
   n = numberof(c);
   if( n == 1 ) return [0.];
   a = indgen(n) - 1;
   return a(2:0)*c(2:0);
}


/* Function icoef_polyn */

func icoef_polyn( c )
/* DOCUMENT new_coefs = icoef_polyn( c )

   Returns coefficents for integral of a polynomium
   (Constant is set to zero).
*/
{
   n = numberof(c);
   cc = c/indgen(n);
   grow,cc,0.;
   cc = shift(cc,-1);
   return cc;
}


/* Function systime */

func systime(a) {
/* DOCUMENT systime
    Returns current time as YYYY-MM-DDTHH:MM:SS
 */

   getdate, date;
   gettime, time;
   s = "20"+strpart(date,7:8)+"-"+strpart(date,4:5)+"-"+strpart(date,1:2);
   s = s + "T"+time;
   return s;
}

/* Function ndate */

func ndate(n) {
/* DOCUMENT s = ndate(n)
    If n is not defined or n == 1 then
          returns today's date as YYMMDD
    If n == 2 then returns today's date as YYYY-MM-DD
    If n == 3 then returns today's date/time as YYYY-MM-DDThh:mm:ss
    If n == 4 then returns today's date as 3 element array [YY,MM,DD]
    If n == 5 then returns today's date/time as YYYY-MM-DD (hh:mm)
       or higher
*/

   require,"string.i";
   local date;

   getdate, date;
   if( numberof(n) ) {
      if( n <= 1 ) {
         return strpart(date,7:8)+strpart(date,4:5)+strpart(date,1:2);
      } else if ( n == 2 ) {
         return "20"+strpart(date,7:8)+"-"+strpart(date,4:5)+"-"+strpart(date,1:2);
      } else if ( n == 3 ) {
         return "20"+strpart(date,7:8)+"-"+strpart(date,4:5)+"-"+strpart(date,1:2) \
           +"T"+gettime();
      } else if ( n == 4 ) {
        return [atoi(strpart(date,7:8)), atoi(strpart(date,4:5)), atoi(strpart(date,1:2)) ];
      } else {
         return "20"+strpart(date,7:8)+"-"+strpart(date,4:5)+"-"+strpart(date,1:2) \
             +" ("+strpart(gettime(),1:5)+")";
      }
   } else {
      return strpart(date,7:8)+strpart(date,4:5)+strpart(date,1:2);
   }
}

/* Function wvar */

func wvar( arr )
/* DOCUMENT res = wvar(arr)
      Find Variance of array 'arr'
*/

{
   arr = double(arr);
   num = numberof(arr);
   aver = sum(arr)/num;
   return sum((arr-aver)^2)/num;
}

/* Function wrms */

func wrms( arr, weight )
/* DOCUMENT res = wrms(arr [, weight] )

      Find RMS of array 'arr'
      If weight is given it must have same dimensions as 'arr'
*/

{
   arr = double(arr);
   aver = wavg( arr, weight );
   if( is_void(weight) ) {
      return sqrt(sum((arr-aver)^2)/numberof(arr));
   } else {
      return sqrt(sum(weight*(arr-aver)^2)/sum(weight));
   }
}

/* Function wavg */

func wavg( arr, weight )
/* DOCUMENT res = wavg(arr [, weight])

      Find average of array 'arr'
      If weight is given it must have same dimensions as 'arr'
*/

{
   arr = double(arr);
   if( is_void( weight) ) {
      return sum(arr)/numberof(arr);
   } else {
      return sum(arr*weight)/sum(weight);
   }
}

/* Function strpos */

func strpos( string_in, str, start, rev= )
/* DOCUMENT pos = strpos(string_in, str, start[, rev=])
      Find position of 'str' in 'string_in' from position 'start'.
      Returns 0 if no match.
      Keyword 'rev' will change the direction of the search.
*/

{
   n_string_in = numberof(string_in);
   res = array(long, n_string_in);
   if( is_void(start) ) start = rev ? 0 : 1;

   for( j = 1; j <= n_string_in; j++ ) {

      cur_string = string_in(j);
      ll = strlen(cur_string);
      lstart = start == 0 ? ll : start;
      stringx = rev ? strpart(cur_string,1:lstart) : strpart(cur_string,lstart:ll);
      if( !strmatch( stringx, str ) ) {
         res(j) = 0;
         continue;
      }
      l = strlen(str);
      if( rev ) {
         ll = lstart;
         for(i=ll-l+1;i>=1;i--) {
            if( strpart(stringx,i:i+l-1) == str ) break;
         }
         res(j) = i;
      } else {
         ll -= (lstart-1);
         for(i=1;i<=ll-l+1;i++) {
            if( strpart(stringx,i:i+l-1) == str ) break;
         }
         res(j) = i+lstart-1;
      }
   }
   if( n_string_in == 1 ) {
      return res(1);
   } else {
      return res;
   }

}


/* Function strcompress */

func strcompress( string_in, all=, st= )
/* DOCUMENT str = strcompress(string_in, all=, st=)
     Reduce all series blanks to single blanks
     Keyword 'all' causes removal of all blanks
     Keyword 'st' is a 1 char string to replace 'blank (or space)'
*/

{
   if( st ) {
      sep = strpart(st,1:1);
      dsep = sep + sep;
   } else {
      sep = " ";
      dsep = "  ";
   }

   result = string_in;
   nres = numberof(result);

   for( i = 1; i <= nres; i++ ) {
      if( all ) {
         while( strmatch(result(i),sep) ) {
            p = strpos(result(i),sep,1);
            if( p == 1 ) {
               result(i) = strpart(result(i),2:0);
            } else if( p == len ) {
               result(i) = strpart(result(i),1:-1);
            } else {
               result(i) = strpart(result(i),1:p-1)+strpart(result(i),p+1:0);
            }
         }
      } else {
         while( strmatch(result(i),dsep) ) {
            len = strlen(result(i));
            p = strpos(result(i),dsep,1);
            result(i) = strpart(result(i),1:p)+strpart(result(i),p+2:0);
         }

      }
   }
   return( result);
}

/* Function arrcat */

func arrcat( arr, ..)
/* DOCUMENT arr = arrcat( arr1, arr2, ..)
     Concatenate two or more 1D arrays
*/

{
   d = dimsof(arr);
   n = numberof(arr);
   if( d(1) > 1 ) {
      print,"arrcat error, bad dimension arg# 1";
      return -1;
   }
   n_arg = 1;
   while( more_args() ) {
      n_arg++;
      arr2 = next_arg();
      d2 = dimsof(arr2);
      n2 = numberof(arr2);
      if( d2(1) > 1 ) {
         print,"arrcat error, bad dimension arg#", n_arg;
         return -1;
      }
      if( typeof(arr) != typeof(arr2) ) {
         print,"arrcat error, not the same type arg#", n_arg;
         return -1;
      }
      grow, arr, arr2;
   }

   return arr;
}

/* Function shift */

func shift(x,..)
/* DOCUMENT z = shift(x,nd1,nd2,..)
   Shift array x 'nd1' places first index
   'nd2'places second index etc.
   with wrap around
   nd positive: left shift
   nd negative: right shift
*/

{
   dms = dimsof(x);
   if( dms(1) == 0 ) {
      print,"shift of a scalar is not possible";
   } else if( dms(1) == 1 ) {
      nd = next_arg();
      n = dms(2);
      return x((indgen(n)-1+n+nd)%n+1);
   } else if( dms(1) == 2 ) {
      nd1 = next_arg();
      nd2 = next_arg();
      n1 = dms(2);
      n2 = dms(3);
      return x((indgen(n1)-1+n1+nd1)%n1+1,(indgen(n2)-1+n2+nd2)%n2+1);
   } else if( dms(1) == 3 ) {
      nd1 = next_arg();
      nd2 = next_arg();
      nd3 = next_arg();
      n1 = dms(2);
      n2 = dms(3);
      n3 = dms(4);
      return x((indgen(n1)-1+n1+nd1)%n1+1,(indgen(n2)-1+n2+nd2)%n2+1, \
                       (indgen(n3)-1+n3+nd3)%n3+1);
   } else {
      print,"shift: number of dimensions is too high";
   }
   return x;
}

/* Function strput */

func strput( line, piece, pos )
/* DOCUMENT line = strput(line, piece, pos)

   Replace part of 'line' with 'piece' starting at 'pos'
   If 'piece' does not fit in 'line' then 'piece' is truncated
   'line' will keep its length.

   2004-09-15/NJW

*/

{
   len_line = strlen(line);
   len_piece = strlen(piece);
   if( pos < 1 || pos > len_line ) return( line );

   len_possible = len_line - pos + 1;
   if( len_possible < len_piece ) {
      piece = strpart(piece,1:len_possible);
      len_piece = len_possible;
   }
   if( pos > 1 ) {
      newline = strpart(line,1:pos-1);
   } else {
      newline = "";
   }
   newline += piece;
   len_rest = len_line - pos - len_piece + 1;
   if( len_rest > 0 ) newline += strpart(line,pos+len_piece:len_line);

   return( newline );

}

/* Function strmsplit */

func strmsplit( string_in, str, nocompress= )
/* DOCUMENT str_array = strmsplit( string_in, str, nocompress= )

   Return string array with substrings separated by any of the
   characters in 'str' (must be a string) in the original string.
   Normal operation is done with string compression to avoid
   duplicated, leading and trailing search characters.
   This can be overridden by keyword 'nocompress'

   2011-06-16/NJW

*/
{
   len = strlen(str);
   sstr = strpart(str,1:1);
   outstr = [];
   if( len > 1 ) {
      for( i = 2; i <= len; i++ ) {
         string_in = strcharrepl( string_in, strpart(str,i:i), sstr, all=1 );
      }
   }
   return strsplit( string_in, sstr, nocompress=nocompress );
}

/* Function strinsert */

func strinsert( string_in, piece, position )
/* DOCUMENT new_string = strinsert( string_in, piece, position )

    Returns a string (or string array) with 'piece' inserted
    immediately BEFORE the position 'position'.

    This function cannot be used to append the 'piece' to 'string_in'.

    2012-12-13/NJW
*/
{
   nstr = numberof(string_in);
   npos = numberof(position);
   if( npos != 1 && npos != nstr ) error,"Mismatch between argument dimensions.";
   res = array(string,nstr);
   if( nstr > 1 && npos == 1 ) position = array(position, nstr);
   for( i = 1; i <= nstr; i++ ) {
      if( position(i) > 1 ) {
         part1 = strpart( string_in(i), 1:position(i)-1 );
         part2 = strpart( string_in(i), position(i):0 );
         res(i) = part1+piece+part2;
      } else if( position(i) == 1 ) {
         res(i) = piece+string_in(i);
      } else { // 'position' is zero or negative
         pos = strlen(string_in(i)) + position(i);
         part1 = strpart( string_in(i), 1:pos-1 );
         part2 = strpart( string_in(i), pos:0 );
         res(i) = part1+piece+part2;
      }
   }
   return is_scalar(string_in) ? res(1) : res;
}

/* Function strsplit */

func strsplit( string_in, str, nocompress= )
/* DOCUMENT str_array = strsplit( string_in, str, nocompress= )

   Return string array with substrings separated by 'str' (must be a
   single character string) in the original string. Normal operation
   is done with string compression to avoid duplicated, leading and
   trailing search characters.
   This can be overridden by keyword 'nocompress'

   2004-09-16/NJW

*/

{
   if( !nocompress ) string_in = strcompress( strtrim(string_in,blank=str), st=str);
   result = [];
   prev = 1;
   n = 0;
   while( pos = strpos(string_in,str,prev) ) {
      n++;
      if( n == 1 ) {
         if( 1 == pos ) {
            result = "";
         } else {
            result = strpart(string_in,prev:pos-1);
         }
      } else {
         grow, result, strpart(string_in,prev:pos-1);
      }
      prev = pos + 1;
   }
   if( numberof(result) ) {
      grow, result, strpart(string_in,prev:0);
   } else {
      result = string_in;
   }

   return( result );

}

/* Function arcdist */

func arcdist( ra1, dc1, ra2, dc2, deg=, rad= )
/* DOCUMENT res = arcdist( ra1, dc1, ra2, dc2, deg=, rad=)

  Return distance along great circle from one point to another
  Unit must be supplied if not degrees (default)

*/

{
   require, "string.i"; // where 'is_scalar' resides

   iu = 0;
   if( deg ) iu++;
   if( rad ) iu += 2;
   if( iu == 3 ) {
      print,"ARCDIST: only one unit can be defined deg xor rad"
      return -1;
   }
   if( iu < 2 ) iu = 1; // choose degrees as default

   // Avoid singularity when coordinates are very close to
   // being identical
   factor = double(1);
   if( iu == 1 ) factor = pi/double(180);
   r1 = ra1 * factor;
   d1 = dc1 * factor;
   r2 = ra2 * factor;
   d2 = dc2 * factor;
   arg = (sin(d1)*sin(d2) + cos(d1)*cos(d2)*cos(r2-r1));
   if( is_scalar(arg) ) {
      if( arg > 1.0 ) arg = 1.0;
      if( arg < -1.0 ) arg = -1.0;
   } else {
      w = where( arg > 1.0 );
      if( numberof(w) > 0 ) arg(w) = 1.0;
      w = where( arg < -1.0 );
      if( numberof(w) > 0 ) arg(w) = -1.0;
   }
   return acos(arg)/factor;
}

/* Function file_search */

func file_search( name, directory, dir=, silent= )
/* DOCUMENT list = file_search(name, directory, dir=, silent=)

   Returns a list of regular files (i.e. not directories)
   by name of 'name' which may contain wild cards: * and ?.
   The directory must be given by 'directory'. If 'directory' is omitted
   then the search will be in the current directory.

   Keyword dir: When set only directories under the
   named one will be returned.

   SEE ALSO: file_rsearch

*/

{
   if( is_void(directory) ) directory = ".";
   // remove trailing '/' if found:
   if( strpart(directory,0:0) == "/" ) directory = strpart(directory,1:-1);
   if( !file_test(directory) ) {
      write,format="FILE_SEARCH: No such directory: %s\n", directory;
      return [];
   }
   list = lsdir( directory, subdirs );
   if( dir ) list = subdirs;
   if( is_void(list) ) {
      if( !silent ) write,"There are no files in the directory";
      return [];
   }
   if( typeof(list) != "string" ) {
      if( !silent ) write,"There is no such directory";
      return [];
   }
   nlist = numberof(list);
   if( nlist == 0 ) return [];
   rlist = list;
   k = 0;
   nnames = numberof(name);
   for( j = 1; j <= nnames; j++ ) {
      for( i = 1; i <= nlist; i++ ) {
         if( strcompare( list(i), name(j) ) ) rlist(++k) = directory+"/"+list(i);
      }
   }
   if( k == 0 ) {
      return [];
   } else {
      rlist = rlist(1:k);
      return rlist(sort(rlist));
   }

}

/* Function strcompare */

func strcompare( obj, pattern ) {
/* DOCUMENT res = strcompare( obj, pattern)

   pattern may consist of wildcards such as * and ?
   Returns 1 if obj matches pattern else 0

*/

   if( obj == pattern ) return 1;
   if( pattern == "*" ) return 1;

   tok = strsplit(pattern,"*");
   ntok = numberof(tok);
   if( strpart(pattern,1:1) == "*" ) {ast1 = 1;} else {ast1 = 0;}
   if( strpart(pattern,0:0) == "*" ) {ast2 = 1;} else {ast2 = 0;}
   len = strlen(obj);
   len2 = strlen(tok(0));

   start = 1;
   for( i = 1; i <= ntok; i++ ) {
      p = qmstrpos2( obj, tok(i), start );
      if( p == 0 ) return 0;
      if( i == 1 && ast1 == 0 && p != 1 ) return 0;
     // if( i == ntok && ast2 == 0 && tok(i) != strpart( obj, -len2+1:0) ) return 0;
      if( i == ntok && ast2 == 0 &&
             qmcompare(strpart( obj, -len2+1:0),tok(i))==0 ) return 0;
      start = p + strlen(tok(i));
   }
   return 1;
}


/* Function qmcompare */

func qmcompare( obj, pattern ) {
/* DOCUMENT res = qmcompare( obj, pattern )

   pattern may contain ? wildcards

*/


   len = strlen(obj);
   if( len != strlen(pattern) ) return 0;
   // must have equal length

   for( i = 1; i <= len; i++ ) {
      c = strpart(pattern,i:i);
      if( c == "?" ) continue;
      if( strpart(obj,i:i) != c ) return 0;
   }
   return 1;
}

/* Function qmstrpos1 */

func qmstrpos1( str, piece, start ) {
/* DOCUMENT res = qmstrpos1( str, piece, start )

   Return position of 'piece' in 'str' considering
   that 'str' may contain ? wildcards

*/


   len = strlen(str);
   lenp = strlen(piece);
   if( lenp > len - start + 1 ) return 0;
   // must be room enough for 'piece'

   for( i = start; i <= len-lenp+1; i++ ) {
      c = strpart(str,i:i+lenp-1);
      if( qmcompare(piece,c) ) return i;
   }
   return 0;
}

/* Function qmstrpos2 */

func qmstrpos2( str, piece, start ) {
/* DOCUMENT res = qmstrpos2( str, piece, start )

   Return position of 'piece' in 'str' considering
   that 'piece' may contain ? wildcards

*/


   len = strlen(str);
   lenp = strlen(piece);
   if( lenp > len - start + 1 ) return 0;
   // must be room enough for 'piece'

   for( i = start; i <= len-lenp+1; i++ ) {
      c = strpart(str,i:i+lenp-1);
      if( qmcompare(c,piece) ) return i;
   }
   return 0;
}

/* Function get_next_filename */

func get_next_filename( pattern, &ser_str, dir=, latest= ) {
/* DOCUMENT name = get_next_filename( pattern, >ser_str, dir=, latest= )

    2003-02-05/NJW
    2006-06-15/NJW changed directory argument to keyword
    2007-08-15/NJW updated with argument 'ser_str'

   For a pattern abcNNNNdefg.hijk where NNNN is a serial number
   given as 'abc????defg.hijk' the name will be returned with
   NNNN+1. The string NNNN+1 by itself is returned in 'ser_str'.

   Keyword 'dir': If given search in that directory and return the
                  full path to it; else search local directory
           'latest': Returns latest rather than next
*/


   //  Special case of pattern: ./abcd?????efgh

   if( strpart(pattern,1:2) == "./") {
      patt = strpart(pattern,3:999);
   } else patt = pattern;

   if( numberof(dir) ) {
      //  Strip trailing '/' from dir
      if( strpart(dir,0:0) == "/" ) dir = strpart(dir,1:-1);
   } else dir = ".";

   //  Analyze the pattern

   qq = "?";
   // find first occurrence of '?'
   pos = strpos( patt, qq, 1);
   len = 0;
   p = pos;
   // count number of consequtive '?'s
   while( strpos( patt, qq, ++p ) );
   len = p - pos;

   lenstr = swrite(len,format="%i");
   fmt = "%"+lenstr+"."+lenstr+"i";
   sermax = 10^len - 1;


   lst = file_search(patt, dir);
   nlst = numberof(lst);

   if( nlst ) {
      // screen for non-digit patterns
      w = array(1,nlst);
      for( i = 1; i <= nlst; i++ ) {
         bname = basename(lst(i));
         check = strpart(bname,pos:pos+len-1);
         if( !is_digit(check) ) w(i) = 0;
      }
      lst = lst(where(w));
      nlst = numberof(lst);
   }

   if( nlst == 0 ) {
      ser_str = swrite(0,format=fmt);
      if( dir == "." ) {
         return strput(patt,ser_str,pos);
      } else {
         return dir+"/"+strput(patt,ser_str,pos);
      }
   }

   sh = strlen(dir) + 1;
   s = sort(lst); // sorting list of existing files
   high = lst(s(0));
   sernum = 1;
   // extract number of highest serial number file as a string
   numstr = strpart(high,sh+pos:sh+pos+len-1);
   n = sread(numstr,format="%d",sernum);
   if( sernum == sermax ) {
      print,"Warning from GET_NEXT_FILENAME, max serial number reached";
      --sernum;
   }
   if( latest ) --sernum;
   ser_str = swrite(++sernum,format=fmt);
   if( dir == "." ) {
      return strput(patt,ser_str,pos);
   } else {
      return dir+"/"+strput(patt,ser_str,pos);
   }

}


/* Function file_test */

func file_test( filename, gz=, nz= )
/* DOCUMENT flag = file_test(filename, gz=, nz= )

   Returns 1 if the file by name of 'filename' (including
   the path) is found. Else return 0.

   Keyword: gz   if set, accept filename.gz as well
                 If 'filename.gz' is found then 2 is returned
            nz   if set, accept only files of non-zero size

*/
{

   local dir, fname;

   if( typeof(filename) != "string" ) return 0;

   if( filename == "." ) return 1;
   if( filename == ".." ) return 1;
   if( filename == "./" ) return 1;
   if( filename == "../" ) return 1;

   if( strlen(get_env("HOST"))) {

      if( open(filename,"r",1) ) {
         if( nz ) if( filesize(filename)==0 ) return 0;
         return 1;
      } else {
         if( gz ) {
            if( open(filename+".gz","r",1) ) {
               if( nz ) if( filesize(filename+".gz")==0 ) return 0;
               return 2;
            }
         }
         return 0;
      }

   } else { // you are on a Windows(like) system where the 'open' trick
            // does not work for directories
      splitfname, filename, dir, fname;
      list = lsdir( dir );
      if( numberof(list) == 0 ) return 0;
      n = numberof( where( fname == list ) );
      if( n ) {
         if(nz) if( filesize(filename)==0 ) return 0;
         return 1;
      }
      if( gz ) {
         return 2*numberof( where( fname+".gz" == list ) );
      } else return 0;
   }

}

/* Function poly_fit */

func poly_fit( x, y, n_degree, xfit= )
/* DOCUMENT res = poly_fit( x, y, n_degree, xfit=)

   Performs a polynomial fit to the points given by (x,y).
   The polynomial degree is given by n_degree. The polynomial
   coefficients are returned as default, but the keyword 'xfit'
   may contain an array with x-values for which the fit is then
   returned.

   2004-11-15/NJW
*/
{
   m = construct_matrix( x, n_degree + 1 );
   r = construct_rhs( x, y, n_degree+ 1 );
   c = LUsolve(m,r);
   if( numberof(xfit) ) {
      return polyn( xfit, c );
   } else {
      return c;
   }
}

/* Function  construct_matrix */

func construct_matrix( x, n_coefs )
/* DOCUMENT matrix = construct_matrix( x, n_coefs )

   Auxiliary function for poly_fit.
   Returns the matrix for the linear system to solve for
   getting the polynomial fit coefficients.
   The polynomial order is n_coefs - 1

*/

{
   xx = x;
   nx = numberof(x);
   matrix = array(0.0, n_coefs, n_coefs );
   matrix(1,1) = nx;
   if( n_coefs == 1 ) return matrix;
   for( i = 2; i <= n_coefs; i++) {
      sm = sum(xx);
      for( j = 1; j <= i; j++ ) {
         matrix(j,i-j+1) = sm;
      }
      xx *= x;
   }
   for ( i = 2; i < n_coefs; i++) {
      sm = sum(xx);
      for( j = i; j <= n_coefs; j++ ) {
         matrix(j,n_coefs+i-j) = sm;
      }
      xx *= x;
   }
   matrix(n_coefs,n_coefs) = sum(xx);

   return matrix;

}

/* Function  construct_rhs */

func construct_rhs( x, y, n_coefs )
/* DOCUMENT rhs = construct_rhs( x, y, n_coefs )

   Auxiliary function for 'poly_fit'.
   Returns the RHS for the linear system to solve for
   getting the polynomial fit coefficients.
   The polynomial order is n_coefs - 1

*/

{
   xy = y;
   rhs = array(0.0, n_coefs );
   for( i = 1; i < n_coefs; i++) {
      rhs(i) = sum(xy);
      xy *= x;
   }
   rhs(n_coefs) = sum(xy);

   return rhs;

}

/* Function pick_swid_str */

func pick_swid_str( arr_in, &arr_out, plus= )
/* DOCUMENT n = pick_swid_str( arr_in, >arr_out[, plus= ] )

    Update arr_out as string array with only the 12 digit SWID strings.
    If keyword 'plus' (int) is larger than zero then this additional
    number of characters following the SWID will be returned.
    Return number of SWIDs actually found.

    2004-02-16/NJW
    2006-08-16/NJW Converted to Yorick
    2006-10-04/NJW Added keyword 'plus'
*/
{
   nlist = numberof(arr_in);

   arr_out = [];
   count = 0;
   if( is_void(plus) ) plus = 0;

   for( i = 1; i <= nlist; i++ ) {

      // locate string with 12 consequtive digits

      len = strlen(arr_in(i));
      if( len < 12 ) continue;

      for( j = 1; j <= len-11; j++ ) {
         piece = strpart(arr_in(i),j:j+11);
         piecep = strpart(arr_in(i),j:j+11+plus);
         if( is_digit(piece) ) {
            if( plus ) {
               grow, arr_out, piecep;
            } else {
               grow, arr_out, piece;
            }
            count++;
            break;
         }
      }
   }
   return count;
}

/* Function makeimageu */

func makeimageu( imdim, xval, yval, xr=, yr=, nt=, weight= )
/* DOCUMENT image = makeimageu( imdim, xval, yval, xr=, yr=, nt=, weight= )

  Make 2D image (a 2D histogram) from array of x values
   and one of y values with optional weights

   Keywords
     xr, yr  :  2-element arrays with minimum and maximum.
     nt      : When set it implies integer values in xval and yval that
               are interpreted as indices directly. Overrides xr and yr.
     weight  : If given it must be an array conformable with xval.

   2006-08-25/NJW Converted makeimageu.pro to Yorick
   2012-10-21/NJW Updated with keyword 'nt'

*/
{

   index = dimsof(imdim);
   if( index(1) != 1 && index(1) != 2 ) {
      write,"Incorrect number of dimensions for image";
      return -1.;
   }
   nx = numberof(xval);
   if( nx != numberof(yval) ) {
      print,"Not matching number of dimensions in call";
      return -1.;
   }

   if( is_void(weight) ) weight = xval*0. + 1.;
   if( numberof(weight) != nx ) {
        print,"Incorrect number of elements in weight factor array";
        return -1.;
   }

   im = array( float, imdim(1), imdim(2));

   if( nt ) {
      for( i = 1; i <= nx; i++ ) {
         ix = xval(i);
         if( ix >= 1 && ix <= imdim(1) ) {
            iy = yval(i);
            if( iy >= 1 && iy <= imdim(2) ) im(ix,iy) = im(ix,iy) + weight(i);
         }
      }
      return im;
   }

   // Definition of limits;

   if( numberof(xr) == 2 ) {
        xmin = xr(1)*1.0;
        xmax = xr(2)*1.0;
   } else {
        xmin = min(xval)*1.0;
        xmax = max(xval)*1.0;
   }
   if( numberof(yr) == 2 ) {
        ymin = yr(1)*1.0;
        ymax = yr(2)*1.0;
   } else {
        ymin = min(yval)*1.0;
        ymax = max(yval)*1.0;
   }
   dx = (xmax - xmin) / imdim(1);
   dy = (ymax - ymin) / imdim(2);

   for( i = 1; i <= nx; i++ ) {
      ix = long((xval(i) - xmin) / dx + 1);
      if( ix >= 1 && ix <= imdim(1) ) {
         iy = long((yval(i) - ymin) / dy + 1);
         if( iy >= 1 && iy <= imdim(2) ) im(ix,iy) = im(ix,iy) + weight(i);
      }
   }
   return im;
}

/* Function makeimagez */

func makeimagez( imdim, x, y, z, xr=, yr=, fill= )
/* DOCUMENT arr = makeimagez( imdim, x, y, z, xr=, yr=, fill= )

    Make an image with dimensions 'imdim' (two element array) of 'z' values.

    If more than one z-value falls in a pixel then the values are averaged.

    Keywords:
       xr      (two element array) xmin and xmax. Defaults to min(x) and max(x).
       yr      (two element array) ymin and ymax. Defaults to min(y) and max(y).
       fill    set, if empty pixels are to be filled with value from closest
               neighbor.

*/
{
   n = numberof(x);

   if( numberof(y) != n ) error,"##1##";
   if( numberof(z) != n ) error,"##2##";
   nx = imdim(1);
   ny = imdim(2);

   x = double(x);
   y = double(y);
   z = double(z);
   if( is_void(xr) ) {
      xmin = min(x);
      xmax = max(x);
      // adjust values to keep extreme points within range
      xmin -= 1.e-6*(xmax - xmin);
      xmax += 1.e-6*(xmax - xmin);
   } else {
      xmin = double(xr(1));
      xmax = double(xr(2));
   }
   if( is_void(yr) ) {
      ymin = min(y);
      ymax = max(y);
      // adjust values to keep extreme points within range
      ymin -= 1.e-6*(ymax - ymin);
      ymax += 1.e-6*(ymax - ymin);
   } else {
      ymin = double(yr(1));
      ymax = double(yr(2));
   }

   v_arr = array(double, nx, ny);
   i_arr = array(long, nx, ny);
   deltax = (xmax - xmin) / nx;
   deltay = (ymax - ymin) / ny;

   nrejected = 0;
   for( i = 1; i <= n; i++ ) {
      if( x(i) >= xmax ) { nrejected++; continue; }
      if( x(i) < xmin ) { nrejected++; continue; }
      if( y(i) >= ymax ) { nrejected++; continue; }
      if( y(i) < ymin ) { nrejected++; continue; }
      ix = long((x(i) - xmin)/deltax + 1);
      iy = long((y(i) - ymin)/deltay + 1);

      ia = i_arr(ix,iy);
      va = v_arr(ix,iy); // previous value, average of 'ia' values
      v = va * ia + z(i); // new sum of values
      v /= (++ia); // new average
      i_arr(ix,iy) = ia;
      v_arr(ix,iy) = v;
   }
   write,"Rejected "+itoa(nrejected)+" points";

   if( fill ) {

      // Now 'i_arr' is searched for holes; they must be covered by looking for
      // filled-out neighbors

      w = where(i_arr == 0);
      nw = numberof(w);

      for( i = 1; i <= nw; i++ ) {
         iy = (w(i) - 1) / nx;
         ix = w(i) - (iy++)*nx;
         iasum = 0;
         vasum = 0.0;
         sep = 1;
         while( iasum == 0 ) {
            for( jj = -sep; jj <= sep; jj+= 2*sep ) {
               for( ii = -sep; ii <= sep; ii++ ) { // stepping +x
                  if( ix + ii < 1 ) continue;
                  if( ix + ii > nx ) continue;
                  if( iy + jj < 1 ) continue;
                  if( iy + jj > ny ) continue;
                  if( i_arr(ix+ii,iy+jj) ) {
                     iasum++;
                     vasum += v_arr(ix+ii,iy+jj);
                  }
               }
            }
            for( ii = -sep; ii <= sep; ii+= 2*sep ) {
               for( jj = -sep; jj <= sep; jj++ ) { // stepping +y
                  if( ix + ii < 1 ) continue;
                  if( ix + ii > nx ) continue;
                  if( iy + jj < 1 ) continue;
                  if( iy + jj > ny ) continue;
                  if( i_arr(ix+ii,iy+jj) ) {
                     iasum++;
                     vasum += v_arr(ix+ii,iy+jj);
                  }
               }
            }
            sep++; // prepare for next neighbors
         }
         v_arr(ix,iy) = vasum / iasum;
      }
   }
   return v_arr;
}


/* Function zero2pi */

func zero2pi( x )
/* DOCUMENT newx = zero2pi( x )

    An adequate number of (2*pi) is added to or subtracted from
    x so that the result ('newx') is between 0 (zero) and 2*pi

    2006-12-28/NJW
*/
{
   xx = x;
   twopi = 2.0 * pi;
   if( dimsof(xx)(1) == 0 ) {
      while( xx >= twopi ) xx -= twopi
      while( xx < 0.0 ) xx += twopi
   } else {
      while( anyof(xx >= twopi) ) {
         w = where( xx >= twopi);
         xx(w) -= twopi;
      }
      while( anyof(xx < 0.0) ) {
         w = where( xx < 0.0 );
         xx(w) += twopi;
      }
   }

   return xx;
}

/* Function zero360 */

func zero360( x )
/* DOCUMENT newx = zero360( x )

    An adequate number of 360 is added to or subtracted from
    x so that the result ('newx') is between 0 (zero) and 360 degrees.

    2011-01-18/NJW, cloned from zero2pi
*/
{
   xx = x; // avoid altering 'x'
   if( dimsof(xx)(1) == 0 ) {
      while( xx >= 360.0 ) xx -= 360.0;
      while( xx < 0.0 ) xx += 360.0;
   } else {
      while( anyof(xx >= 360.0) ) {
         w = where( xx >= 360.0);
         xx(w) -= 360.0;
      }
      while( anyof(xx < 0.0) ) {
         w = where( xx < 0.0 );
         xx(w) += 360.0;
      }
   }

   return xx;
}

/* Function extract_box */

func extract_box( image, &pix1, &pix2, &w_1, &w_2, ll=, cen= )
/* DOCUMENT box = extract_box( image, (>)pix1, (>)pix2, (>)w_1, (>)w_2, ll=, cen= )

   image:  Input 2D image
   pix1 :  Lower left corner (ll=1) or center (cen=1) of box 1. coord.
   pix2 :  Lower left corner (ll=1) or center (cen=1) of box 2. coord.
   w_1  :  Width of box 1. coord.
   w_2  :  Width of box 2. coord.

   The box returned is always completely inside image and
   lower left coordinates are shifted to match this requirement.
   The center is defined as (w_? + 1)/2.

   At return the 'pix1' and 'pix2' values gives the lower-left (center)
   pixels of the extracted box (useful if position adjustment was
   necessary).

   If 'pix1' at input is a four element array then it is interpreted
   as (x1,y1,x2,y2) of pixel indices and the box is extracted accordingly.
   As a side-effect its contents will be updated!

   2006-11-20/NJW
   2006-12-29/NJW updated with keywords and cen=1 option
   2010-08-06/NJW updated with curmark1(style=1) option

   Example  > newimage = extract_box( image, [10,30,20,10] )
          is equivalent (except for the dimensional test) to
            > newimage = image(10:20,10:30)
*/
{

   if( numberof(pix1) == 4 ) { // interpret as (x1,y1,x2,y2)
      x1 = long(floor(pix1(1)+0.5));
      y1 = long(floor(pix1(2)+0.5));
      x2 = long(floor(pix1(3)+0.5));
      y2 = long(floor(pix1(4)+0.5));
      w_1 = abs(x2 - x1) + 1;
      ll = 1; cen = 0;
      pix1 = min(x1,x2);
      w_2 = abs(y2 - y1) + 1;
      pix2 = min(y1,y2);
   } else {
      ll = ll ? 1 : 0;
      cen = cen ? 1 : 0;
      if( ll+cen != 1 ) {
         write,"Exactly one of keywords 'll' or 'cen' must be set!";
         return [];
      }
   }
   h_1 = w_1 / 2;
   h_2 = w_2 / 2;
   if( cen ) {
      ll_1 = pix1 - h_1;
      ll_2 = pix2 - h_2;
   } else {
      ll_1 = pix1;
      ll_2 = pix2;
   }
   ll_1in = ll_1;
   ll_2in = ll_2;
   dms = dimsof(image);
   if( w_1 > dms(2) ) { // return entire array in this direction
      w_1 = dms(2);
      ll_1 = 1;
      pix1 = cen ? dms(2)/2 + 1 : 1;
   } else {
      if( ll_1 < 1 ) ll_1 = 1;
      if( ll_1 + w_1 - 1 > dms(2) ) ll_1 = dms(2) - w_1 + 1;
      pix1 += (ll_1 - ll_1in);
   }
   if( w_2 > dms(3) ) { // return entire array in this direction
      w_2 = dms(3);
      ll_2 = 1;
      pix2 = cen ? dms(3)/2 + 1 : 1;
   } else {
      if( ll_2 < 1 ) ll_2 = 1;
      if( ll_2 + w_2 - 1 > dms(3) ) ll_2 = dms(2) - w_2 + 1;
      pix2 += (ll_2 - ll_2in);
   }
   return image(ll_1:ll_1+w_1-1,ll_2:ll_2+w_2-1);
}

/* Function local_rms */

func local_rms( image, box_width )
/* DOCUMENT rms_map = local_rms( image, box_width )

   Returns the map of RMS derived in a box of size box_width * box_width
   centered around the pixel in question

   2006-11-20/NJW
*/
{

   dms = dimsof( image );
   res = array( 0.0, dms(2), dms(3) );

   h = long(box_width)/2;
   for( i = 1; i <= dms(2); i++ ) {
      for( j = 1; j <= dms(3); j++ ) {
         ipos = i; jpos = j;
         b = extract_box( image, ipos, jpos, box_width, box_width, cen=1 );
         res(i,j) = wrms(b);
      }
   }

   return res;

}

/* Function circ_area1 */

func circ_area1( d, capr, r )
/* DOCUMENT res = circ_area1( d, capr, r )

    A function to calculate the overlap area between two circles

     d is the distance between the two centers
     capr is the radius of the (larger) circle
     r    is the radius of the (smaller) circle

     xcapr is the distance from the center of the larger circle
           to the line between the two intersection points of the
           two circles
     xr    is equivalent to xcapr but referring to the smaller circle

     acapr is the area of the larger circle inside the smaller circle
     ar    is the area of the smaller circle inside the larger circle

    JEM-X parameters:

   * det_mask = 3385. ; mm
   * capr = 535./2
   * r    = 250./2

   2007-01-02/NJW, translated to Yorick

*/
{
   // define area common to both circles

   if( d  >  capr+r ) return 0.0;
   if( d  <  capr-r || d == 0.0 ) return pi * r^2;
   if( r > capr ) {
      write,"Bad arguments";
      return 0.0;
   }

   xcapr = (capr^2 + d^2 - r^2)/(2.*d);
   t1 = pi*capr^2/2;
   t2 = capr^2 * asin(xcapr/capr);
   t3 = xcapr*sqrt(capr^2 - xcapr^2);
   xr = d - xcapr;
   u1 = pi*r^2/2;
   u2 = r^2*asin(xr/r);
   u3 = xr * sqrt(r^2-xr^2);
   acapr = t1 - t2 - t3;
   ar = u1 - u2 - u3;
   a = ar+acapr;
   return a;
}

/* Function app_slash */

func app_slash( s )
/* DOCUMENT str = app_slash( s )

   Append a slash to the string 's' if there is no trailing slash

    NJW/020305
    2006-10-03/NJW translated to Yorick

*/
{

   if( typeof(s) != "string" ) {
      write,"Bad argument for app_slash";
      return "/";
   }
   if( s == "" ) return "/";

   return (strpart(s,0:0) == "/") ? s : s+"/";

}

/* Function rem_slash */

func rem_slash( s )
/* DOCUMENT str = rem_slash( s )

   Remove a trailing slash from the string 's' if there is a trailing slash

    2006-10-04/NJW

*/
{

   if( typeof(s) != "string" ) {
      write,"Bad argument for rem_slash";
      return "";
   }
   if( s == "" ) return "";

   return (strpart(s,0:0) == "/") ? strpart(s,1:-1) : s;

}

/* Function set_par */

func set_par( parfile, parname, new_value, lolim=, hilim=, arr= )
/* DOCUMENT status = set_par( parfile, parname, new_value, lolim=, hilim=, arr= )

    This is a tool to change a parameter in a parameter
    file in IRAF and DAL style. The main difference
    between this one and the FTOOL: pset is that pset
    will erase all comments.
    When keyword 'arr' is true then 'new_value' is given as a real array
    and should be converted to a string.

    status == 0 means running OK, a value < 0 implies an error of a kind
    and no change to the parameter file.

    This version will only change one parameter per call.

    2007-02-01/NJW reworked to Yorick
    2011-05-04/NJW updated to use PFILES

    SEE ALSO: get_par

*/
{

   if( !file_test(parfile) ) {
      ostype = get_env("OSTYPE");
      if( strlen(ostype) == 0 ) { // neither Linux nor Unix
         pfiles = "."; // *.par file must be in current directory
      } else pfiles = strsplit(get_env("PFILES"),";");
      // for writing: only in front of the ';' sign
      subpfiles = strsplit(pfiles(1),":");
      for( j=1;j<=numberof(subpfiles);j++ ) {
         if( file_test(subpfiles(j)+"/"+parfile) ) {
            parfile = subpfiles(j)+"/"+parfile;
            goto station;
         }
      }
      error,parfile+" was not found ...";
   }
   station:
   parlines = strtrim(rdfile( parfile ));
   numlines = numberof(parlines);

  /*
   * Look for 'arr' keyword and translate 'new_value' into string if true
   */

   if( arr ) {
      if( typeof(new_value) != "double" && typeof(new_value) != "float" ) {
         write,"Illegal combination of keyword and data type";
         return -12;
      }
      n = numberof(new_value);
      s = "";
      for( i = 1; i <= n; i++ ) {
         s += swrite(format="%f ",new_value(i));
      }
      new_value = s;
   }

  /*
   *  Analyze buffer line by line in search for the given parameter
   */

   found = 0;
   for( loop = 1; loop <= numlines; ++loop ) {
      line = parlines(loop);
      if( strpart(line,1:1) == "#" ) continue;
      // save parts in quotes
      qsave = [];
      psave = [];
      p = strpos(line,"\"",1);
      while( p > 0 ) {
        q = strpos(line,"\"",p+1);
        if( q > p ) {
           if( q > p+1 ) {
              grow, qsave, strpart(line, p+1:q-1 );
              repl_str = strjoin(array("X",q-p-1),"");
              line = strput(line, repl_str, p+1);
              grow, psave, p;
           }
           p = strpos(line,"\"",q+1);
        } else {
           write,format="Unpaired quotes in line %i\n", loop;
           return -1;
        }
      }
      // Locate the unquoted commas
      comma = 0;
      pc = strpos(line,",",1);
      while( pc > 0 ) {
         grow, comma, pc;
         pc = strpos(line,",",pc+1);
      }
      grow, comma, strlen(line)+1;
      if( numberof(comma) != 8 ) {
         write,format="Format error in line %i\n", loop;
         return -2;
      }
      // replace the substituted pieces
      for(i=1;i<=numberof(qsave);i++) {
         line = strput( line, qsave(i), psave(i)+1);
      }
      // do the string splitting by the non-quoted commas
      tok = array(string,7);
      for(i=1;i<=7;i++) {
         tok(i) = strpart(line,comma(i)+1:comma(i+1)-1);
      }
      // Now we are ready to make a match
      if( tok(1) == parname ) {
         found++;
         if( tok(2) == "r" ) {  // new_value must be a number
            if( "string" == typeof(new_value) ) {
               write,format="Got a string but a number was expected in line %i\n", loop;
               return -3;
            }
            new_value = double(new_value);
            // Check boundaries
	    lo_bound = is_void(lolim) ? atof(tok(5)) : lolim;
	    hi_bound = is_void(hilim) ? atof(tok(6)) : hilim;
            if( new_value < lo_bound || new_value > hi_bound ) {
               write,format="Parameter %s is outside limits\n", parname;
               return -4;
            }
            tok(4) = swrite(new_value,format="%g");
            if( !is_void(lolim) ) tok(5) = swrite(lolim,format="%g");
            if( !is_void(hilim) ) tok(6) = swrite(hilim,format="%g");
         } else if( tok(2) == "i" ) { // new_value must be an integer
            t = typeof(new_value);
            if( t != "int" && t != "long" ) {
               write,format="Got a non-integer but an integer was expected in line %i\n", loop;
               return -6;
            }
            // Check boundaries
	    lo_bound = is_void(lolim) ? atoi(tok(5)) : lolim;
	    hi_bound = is_void(hilim) ? atoi(tok(6)) : hilim;
            if( new_value < lo_bound || new_value > hi_bound ) {
               write,format="Parameter %s is outside limits\n", parname;
               return -6;
            }
            tok(4) = swrite(new_value,format="%i");
            if( !is_void(lolim) ) {
               t = typeof(lolim);
               if( t != "int" && t != "long" ) {
                  write,format="Got a non-integer but an integer was expected in line %i\n", loop;
                  return -7;
               }
               tok(5) = swrite(lolim,format="%i");
            }
            if( !is_void(hilim) ) {
               t = typeof(hilim);
               if( t != "int" && t != "long" ) {
                  write,format="Got a non-integer but an integer was expected in line %i\n", loop;
                  return -8;
               }
               tok(6) = swrite(hilim,format="%g");
            }
         } else if( tok(2) == "s" ) {
            if( "string" != typeof(new_value) ) {
               write,format="Got a number but a string was expected in line %i\n", loop;
               return -9;
            }
            tok(4) = "\""+new_value+"\"";
            if( !is_void(lolim) ) tok(5) = "\""+lolim+"\"";
            if( !is_void(hilim) ) tok(6) = "\""+hilim+"\"";
         } else {
            write,format="Unsupported type definition in line %i\n", loop;
            return -10;
         }

         parlines(loop) = strjoin(tok,",");
      }

   }

   if( found != 1 ) {
      write,format="Parameter %s was not found in %s\n", parname, parfile;
      return -11;
   }

   write_slist, parfile, parlines;

   return 0;

}

/* Function get_par */

func get_par( parfile, parname, arr= )
/* DOCUMENT value = get_par( parfile, parname, arr= )
    This is a tool to read the value of a parameter in a parameter
    file in IRAF and DAL style. The parameter file is first searched
    in the current directory then according to the PFILES
    environment variable.
    If keyword 'arr' is true then the parameter is expected to be
    a string that should be split up into a number of double's.

    A nil value ([]) is returned if an error occurred.

    2007-02-02/NJW
    2011-05-04/NJW, updated to use PFILES

    SEE ALSO: set_par

*/
{

   if( !file_test(parfile) ) {
      ostype = get_env("OSTYPE");
      if( strlen(ostype) == 0 ) { // neither Linux nor Unix
         pfiles = "."; // *.par file must be in current directory
      } else pfiles = strsplit(get_env("PFILES"),";");
      for( i=1;i<=numberof(pfiles);i++ ) {
         subpfiles = strsplit(pfiles(i),":");
         for( j=1;j<=numberof(subpfiles);j++ ) {
            if( file_test(subpfiles(j)+"/"+parfile) ) {
               parfile = subpfiles(j)+"/"+parfile;
               goto station;
            }
         }
      }
   }
   station:
   parlines = strtrim(rdfile( parfile ));
   numlines = numberof(parlines);

  /*
   *  Analyze buffer line by line in search for the given parameter
   */

   found = 0;
   for( loop = 1; loop <= numlines; ++loop ) {
      line = parlines(loop);
      if( strpart(line,1:1) == "#" ) continue;
      // save parts in quotes
      qsave = [];
      psave = [];
      p = strpos(line,"\"",1);
      while( p > 0 ) {
        q = strpos(line,"\"",p+1);
        if( q > p ) {
           if( q > p+1 ) {
              grow, qsave, strpart(line, p+1:q-1 );
              repl_str = strjoin(array("X",q-p-1),"");
              line = strput(line, repl_str, p+1);
              grow, psave, p;
           }
           p = strpos(line,"\"",q+1);
        } else {
           write,format="Unpaired quotes in line %i\n", loop;
           return [];
        }
      }
      // Locate the unquoted commas
      comma = 0;
      pc = strpos(line,",",1);
      while( pc > 0 ) {
         grow, comma, pc;
         pc = strpos(line,",",pc+1);
      }
      grow, comma, strlen(line)+1;
      if( numberof(comma) != 8 ) {
         write,format="Format error in line %i\n", loop;
         return [];
      }
      // replace the substituted pieces
      for(i=1;i<=numberof(qsave);i++) {
         line = strput( line, qsave(i), psave(i)+1);
      }
      // do the string splitting by the non-quoted commas
      tok = array(string,7);
      for(i=1;i<=7;i++) {
         tok(i) = strpart(line,comma(i)+1:comma(i+1)-1);
      }
      // Now we are ready to make a match
      if( tok(1) == parname ) {
         found++;
         if( tok(2) == "r" ) {  // returned value will be a double
            return atof(tok(4));
         } else if( tok(2) == "i" ) { // returned value will be a long
            return atoi(tok(4));
         } else if( tok(2) == "s" ) {
            s = tok(4);
            if( strpart(s,1:1) == "\"" ) s = strpart(s,2:0);
            if( strpart(s,0:0) == "\"" ) s = strpart(s,1:-1);
            if( arr ) {
               tok = strsplit(s," ");
               ntok = numberof(tok);
               vec = array(double,ntok);
               for(i=1;i<=ntok;i++) vec(i) = atof(tok(i));
               return vec;
            } else {
               return s;
            }
         } else {
            write,format="Unsupported type definition in line %i\n", loop;
            return [];
         }

      }

   }

   if( found != 1 ) {
      write,format="Parameter %s was not found in %s\n", parname, parfile;
      return [];
   }

   return [];

}

/* Function esc_underscore */

func esc_underscore( str_array )
/* DOCUMENT newstring = esc_underscore(  str_array  )

   The underscore character is prefixed with an exclamation mark (!)
   to avoid the special meaning for formatting (starting subscript).

   2007-03-09/NJW
*/
{
   newstring = str_array ;
   n = numberof(str_array);

   // Identify the occurrences of '_'

   for( i = 1; i <= n; i++ ) {

      spos = 1;
      pos = strpos(str_array(i),"_",1);
      if( pos > 0 ) {
         newstring(i) = "";
         while( pos > 0 ) {
            if( pos == 1 ) {
               newstring(i) += "!_";
            } else {
               newstring(i) += strpart(str_array(i),spos:pos-1)+"!_";
            }
            spos = pos + 1;
            pos = strpos(str_array(i),"_",spos);
         }
         newstring(i) += strpart(str_array(i),spos:0);
      }
   }

   return newstring;

}

/* Function array_gauss */

func array_gauss( x, coef)
/* DOCUMENT curve = array_gauss( x, coef )

   Return a gauss curve when
    coef = [amplitude, mean, sigma[,a1[,a2[,a3]]]]

   curve = amplitude*exp(-0.5*((x-mean)/sigma)^2) + a1 + x*a2 + x*x*a3

    2006-02-20/NJW (Yorick version)
    2007-05-03/NJW Expanded to include parabolic bkg term
*/
{
   ncoef = numberof( coef );
   if( ncoef < 3 || ncoef > 6 ) {
     write,"Array 'coef' does not have proper length";
     return [];
   }
   arg = abs((x - coef(2)) / coef(3));
   w = where( arg < 12.0 );
   y = x * 0.0;
   y(w) = coef(1)*exp(-0.5*arg(w)^2);
   n = numberof(coef);
   if( n > 3 ) y += coef(4);
   if( n > 4 ) y += x*coef(5);
   if( n > 5 ) y += x*x*coef(6);

   return y;

}

/* Function array_igauss */

func array_igauss( x, coef)
/* DOCUMENT curve = array_igauss( x, coef )

   Return a integrated, averaged gauss curve when
    coef = [amplitude, mean, sigma[,a1[,a2[,a3]]]]
   'x' is interpreted as boundaries and 'curve' has
   one element fewer than 'x'.

   curve = amplitude*Integ(exp(-0.5*((x-mean)/sigma)^2))/(x2-x1) + a1 + x*a2 + x*x*a3

    2010-04-02/NJW
*/
{
   ncoef = numberof( coef );
   if( ncoef < 3 || ncoef > 6 ) {
     write,"Array 'coef' does not have proper length";
     return [];
   }
   s2 = coef(3)*sqrt(2);
   x1 = x(1:-1);
   x2 = x(2:0);
   tb = erf((x2-coef(2))/s2);
   ta = erf((x1-coef(2))/s2);
   res = sqrt(pi/2)*coef(3)*coef(1)*(tb - ta)/(x2-x1);
   if( ncoef > 3 ) res += coef(4);
   if( ncoef > 4 ) res += x(zcen)*coef(5);
   if( ncoef > 5 ) res += x(zcen)*x(zcen)*coef(6);
   return res;
}

func draw_from_dist( x_arr, y_arr, n )
/* DOCUMENT values = draw_from_dist( x_arr, y_arr, n )

   returns 'n' values of 'x' when the distribution is
   described by y_arr and corresponding x_arr.

   2007-08-02/NJW
   2010-04-16/NJW Updated to use 'integ'
*/
{

   x = double(x_arr);
   y = double(y_arr);
   //+ y(1) = 0;

   if( numberof(x) < 100 ) {
      xx = span(x(1),x(0),100);
      y = interp( y, x, xx );
      x = xx;
   }

   //+ if( nonlin ) {

   //+    get_boundaries, x, x1, x2;
   //+    dx = x2 - x1;
   //+    y *= dx;

   //+ }

   //+ ycum = y(psum);
   //+ ycum /= ycum(0);
   //+ xnew = (x_arr + shift(x_arr,1))/2.;
   //+ xnew(1) = x_arr(1);
   //+ xnew(0) = x_arr(0);
   //+ return interp(xnew, ycum, random(n));

   yint = integ(y, x, x);
   yint /= yint(0);

   return interp( x, yint, random(n));

}

/* Function file_rsearch */

func file_rsearch( name, dir )
/* DOCUMENT list = file_rsearch( name, dir )

   Searches for all files by name of 'name' in directory 'dir' and
   all its subdirectories (recursive search).

   Omitting 'dir' makes file_rsearch start in the current directory.

   SEE ALSO: file_search

   2007-08-19/NJW
*/
{
   local nsubdirs, list, nlist, res, sres, subdirs;

   if( is_void(dir) ) dir = ".";
   if( !file_test(dir) ) {
      write,format="FILE_RSEARCH: No such directory: %s\n", dir;
      return [];
   }
   res = [];
   list = lsdir( dir, subdirs );
   nlist = numberof(list);
   if ( nlist ) {
      for(i=1;i<=nlist;i++) {
         if( strcompare( list(i), name)) grow,res,dir+"/"+list(i);
      }
   }
   nsubdirs = numberof( subdirs );
   if( nsubdirs ) {
      for( i = 1; i <= nsubdirs; i++) {
         sres = file_rsearch( name, dir+"/"+subdirs(i) );
         if( !is_void(sres) ) grow, res, sres;
      }
   }
   if( is_void(res) ) {
      return res;
   } else {
      return res(sort(res));
   }
}

/* Function strip_curly_br */

func strip_curly_br( str )
/* DOCUMENT newstr = strip_curly_br( str )

  Strip part of string inside curly bracketts e.g. jmx1_srcl_arf.fits{1}
  write, strip_curly_br("jmx1_srcl_arf.fits{1}")
  > jmx1_srcl_arf.fits

     2005-05-09/NJW
     2008-01-17/NJW translated from IDL to Yorick
*/
{
   pl = strpos( str, "{", 1 );
   pr = strpos( str, "}", 0, rev=1 );
   if( pl  >  1 && pr  >=  1 && pr  >  pl ) {
      return strpart(str,1:pl-1)+strpart(str,pr+1:9999);
   } else if( pl  ==  1 && pr  >  1 ) {
      return strpart(str,pr+1:9999);
   } else return str;
}

/* Function most_freq_elem */

func most_freq_elem( arr )
/* DOCUMENT val = most_freq_elem( arr )

   Returns the most frequent element of array 'arr'
   If all elements are different arr(1) is returned. If arr(n) and
   arr(m) appear an equal number of times larger than any other then
   the one with the lowest index will be returned.

    2008-01-25/NJW
*/
{

   narr = numberof( arr );
   narr2 = narr/2;
   nmax = 1;
   imax = 1;
   for( i = 1; i <= narr; i++ ) {
      n = sum( arr(i) == arr );
      if( n > nmax ) {
         nmax = n;
         imax = i;
         if( nmax > narr2 ) break;
      }
   }

   return arr(imax);

}

/* Function monincr */

func monincr( arr, num )
/* DOCUMENT idx_piece = monincr( arr, num )

   returns the index numbers of the 'num'th piece of
   'arr' where it is monotoneously increasing.

   2008-01-28/NJW
*/
{

   w = where( arr(dif) < 0 );
   nw = numberof(w);
   if( num > nw + 1 ) {
      write,format="MONINCR error: only %i sections\n", nw+1;
      return arr;
   }
   if( nw == 0 ) return arr;
   narr = numberof(arr);
   if( num == 1 ) {
      return indgen(w(1));
   } else if( num == nw+1 ) {
      return indgen(narr-w(0))+w(0);
   } else {
      return indgen(w(num)-w(num-1))+w(num-1);
   }
}

/* Function chi2 */

func chi2( model, y, dy, red= )
/* DOCUMENT value = chi2( model, y, dy, red= )

 Evaluate chi-square as sum(((y-model)/dy)^2)

 If keyword 'red' is given then the reduced chi-square is
 returned with DOF = numberof(y) - red

  2008-03-14/NJW Translated from IDL

*/
{

   if( is_void(dy) ) {
      write,"chi2 syntax: value = chi2(model, y, dy)";
      write,"or reduced_chi2 = chi2(model, y, dy, red=n )";
      return [];
   }

   nm = numberof(model);
   if( nm  !=  numberof(y) || nm  !=  numberof(dy) ) {
      write,"The arrays have different dimensions !";
      return [];
   }

   notz = where( dy  >  0.0 );
   n_notz = numberof(notz);
   if( n_notz  >  0 ) {
      d = (y(notz) - model(notz)) / dy(notz);
   } else {
      write,"chi2 error! dy has only illegal values";
      d = 0.;
   }
   if( is_void(red) ) {
      return sum(d^2);
   } else {
      if( red < n_notz ) {
         return sum(d^2) / (n_notz - red);
      } else {
         error,"chi2: too few data points";
      }
   }
}

/* Function hpd */

func hpd( x_in, y_in )
/* DOCUMENT res = hpd( x_in, y_in )

   returns HPD (Half Power Diameter) from event arrays
   x and y

   SEE ALSO image2events in 'image.i'

   2008-04-07/NJW
*/
{

   if( is_void(x_in) ) {
      write,"Entered hpd with void x_in";
      return [];
   }
   if( is_void(y_in) ) {
      write,"Entered hpd with void y_in";
      return [];
   }
   x = double(x_in);
   y = double(y_in);
   n_events = numberof(x);
   if( n_events < 3 ) {
      write,"HPD: Too few events";
      return [];
   }
   // get best position
   xp = avg(x);
   yp = avg(y);
   write,format="Center with all %i events: %7.3f %7.3f\n", n_events, xp, yp;
   xrms = wrms(x - xp);
   yrms = wrms(y - xp);
   w = where( abs(x - xp) < 3. * xrms );
   if( numberof(w) < 2 ) {
      write,"HPDx: Too few events";
      return [];
   }
   xp = avg(x(w));
   nwx = numberof(w);
   w = where( abs(y - yp) < 3. * yrms );
   if( numberof(w) < 2 ) {
      write,"HPDy: Too few events";
      return [];
   }
   yp = avg(y(w));
   nwy = numberof(w);
   write,format="Improved center with %i, %i events: %7.3f %7.3f\n", nwx, nwy, xp, yp;

   r = sqrt((x-xp)^2 + (y-yp)^2);
   is = sort(r);
   r = r(is);
   whpd = 2. * r(n_events/2);

   return whpd;

}

/* Function fold_gaussx */

func fold_gaussx( e, f, sigma, silent= )
/* DOCUMENT fnew = fold_gaussx( [e,] f, sigma, silent= )

  Fold a spectrum with a Gauss function with a non-constant sigma

   Call -  e : energy array
                If 'e' is absent it is assumed to be indgen(numberof(f))
           f : array with spectrum, same size as 'e'
         sigma  : scalar with standard deviation,
                  or array with same size as 'e'

   Return : folded spectrum

      When ? /NJW
       2003-08-29/NJW   updated (IDL version)
       2006-02-16/NJW   Yorick version
       2006-02-20/NJW   Allow scalar sigma

    SEE ALSO: fold_gaussy
              to fold several spectra simultaneously based on the same
              energy array.
*/

{
   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(sigma) ) {
      // There are at most two arguments
      sigma = f;
      f = e;
      e = double(indgen(numberof(f)));
   }

   n = numberof(e);
   ee = double( e );
   ns = numberof(sigma);
   if( numberof(f) != n ) {
      write,"mismatching dimensions of 'e' and 'f'\n";
      return -1;
   }
   if( ns != 1 && ns != n ) {
      write,"'sigma' has illegal dimension\n";
      return -1;
   }
   sigma2 = sigma * sqrt(2.);
   if( ns == 1 ) sigma2 = sigma2(-:1:n);

   // Define channel boundaries

   eb = 0.5*(ee + shift(ee,-1));
   eb(1) = (3*ee(1) - ee(2))/2;
   grow,eb,(3*ee(0) - ee(-1))/2;
   g = ee * 0.;
   for( i = 1; i <= n; i++ ) {
      j = where((e > ee(i)-3.5*sigma2(i)) + (e < ee(i)+3.5*sigma2(i)) == 2);
      if( numberof(j) ) {
         x2 = (eb(j+1) - ee(i))/sigma2(i);
         x1 = (eb(j) - ee(i))/sigma2(i);
         w = erf(x2) - erf(x1);
         zum = f(j) * w;
         g(i) = sum(zum) / sum(w);
      }
   }

   timer, time_keeper, elapsed_time;
   if(!silent)write,"CPU time used: "+ftoa(elapsed_time(1),ndec=3)+" s";

   return g;

}

/* Function str2arr */

func str2arr( str )
/* DOCUMENT  arr = str2arr( str )

    Convert an expression such as '3,5,6,9-14,16-20'
    to array: [3,5,6,9,10,11,12,13,14,16,17,18,19,20]

    2004-02-11/NJW
    2006-10-01/NJW translated to Yorick
*/

{

   if( typeof( str ) != "string" ) {
      write,"Argument must be a string";
      return -1;
   }

   tok = strsplit(str,",");
   ntok = numberof(tok);

   first = 1;
   for( i = 1; i <= ntok; i++ ) {

      pos = strpos(tok(i),"-");
      if( pos == 1 || pos == strlen(tok(i)) ) {
         print,"Illegal format";
         return -1;
      }
      if( pos > 1 ) {
         upl = strsplit(tok(i),"-");
         nupl = numberof(upl);
         if( nupl != 2 ) {
            print,"Illegal format";
            return -1;
         }
         k1 = toint(upl(1));
         k2 = toint(upl(2));
         if( k2 <= k1 ) {
            print,"Illegal format";
            return -1;
         }
         if( first ) {
            arr = indgen(k2-k1+1) + k1 - 1;
            first = 0;
         } else {
            // arr = [arr,indgen(k2-k1+1) + k1];
            grow, arr, indgen(k2-k1+1) + k1 - 1;
         }
      } else {
         if( first ) {
            arr = toint(tok(i));
            first = 0;
         } else {
            // arr = [arr,toint(tok(i))];
            grow, arr, toint(tok(i));
         }
      }

   }

   return arr;

}

/* Function outlier */

func outlier( arr, qlimit )
/* DOCUMENT is = outlier( arr, qlimit)

   returns the indices of the elements in array 'arr'
   where abs(arr(i)) > qlimit * abs(avg(arr(except i)))

   2009-06-05/NJW
*/
{
   n = numberof(arr);
   is = [];
   for(i=1;i<=n;i++) {
      if( abs(arr(i)) > qlimit * abs(avg(rem_elem(arr,i))) ) grow, is, i;
   }
   return is;
}

/* Function strdelcom */

func strdelcom( str, repl=, mode= )
/* DOCUMENT newstr = strdelcom( str, repl=, mode= )

   Returns string of same length as 'str' but with all
   contents between pair of "" or '' reset to spaces.

   abc"def"gh'ijkl'mn  -> abc"   "gh'    'mn

   Keywords:  repl   (char) replacement character (default is space)
              mode   if set then quotes will be replaced as well

   2009-06-25/NJW
*/
{
   len = strlen( str );
   newstr = str;
   flag = array(int,len);
   mode = mode ? 0 : 1;
   if( is_void(repl) ) repl = ' ';

   // locate double quotes
   pdqarr = [];
   pdq = 0;
   while( (pdq = strpos(str,"\"",pdq+1))) grow,pdqarr,pdq;
   num_pdq = numberof(pdqarr);

   // locate single quotes
   psqarr = [];
   psq = 0;
   while( (psq = strpos(str,"'",psq+1))) grow,psqarr,psq;
   num_psq = numberof(psqarr);

   if( num_pdq+num_pdq == 0 ) return str; // no quotes, so no action
   if( num_pdq%2 == 1 ) {
      write,"STRDELCOM Warning: Unpaired double quotes - no action";
      return str;
   }
   if( num_psq%2 == 1 ) {
      write,"STRDELCOM Warning: Unpaired single quotes - no action";
      return str;
   }

   for( i = 1; i <= num_pdq; i += 2 ) {
      if( pdqarr(i+1)-mode >= pdqarr(i)+mode ) \
         flag(indgen(pdqarr(i)+mode:pdqarr(i+1)-mode)) += 2;
   }
   for( i = 1; i <= num_psq; i += 2 ) {
      if( psqarr(i+1)-mode >= psqarr(i)+mode ) \
         flag(indgen(psqarr(i)+mode:psqarr(i+1)-mode)) += 1;
   }

   if( anyof(flag==3) ) {
      write,"STRDELCOM Warning: Intertwined quotes - no action";
      return str;
   }

   cstr = *pointer(str);

   w = where(flag);
   if( numberof(w) ) cstr(w) = repl;

   return string(&cstr);
}

/* Function cent2bds */

func cent2bds( arr, &bdslo, &bdshi, lg= )
/* DOCUMENT bds = cent2bds( arr, >bdslo, >bdshi, lg= )

 Returns array with boundaries where the "arr" values are
 centers in the bins.

 Keyword 'lg' for logarithmical spacing

  2009-06-29/NJW  based on cent2bds.pro

*/
{
   n = numberof(arr);
   res = array(double,n+1);

   if( lg ) {
      res(2:-1) = sqrt(arr(1:-1) * arr(2:0));
      res(1) = res(2) / arr(2) * arr(1);
      res(0) = res(-1) * arr(0) / arr(-1);
   } else {
      res(2:-1) = 0.5*(arr(1:-1) + arr(2:0));
      res(1) = res(2) - arr(2) + arr(1);
      res(0) = res(-1) + arr(0) - arr(-1);
   }

   bdslo = res(1:-1);
   bdshi = res(2:0);

   return res;

}

/* Function linscale */

func linscale( a, b, anew, bnew, &p, &q )
/* DOCUMENT linscale, a, b, anew, bnew, >p, >q

    Linear rescaling so that a -> anew, b -> bnew
      by (anew =) a*p + q etc.
    (linear transformation)

   2009-10-30/NJW
*/
{
   if( a == b ) error,"LINSCALE bad input";
   ba = double(b-a);
   p = (bnew - anew)/ba;
   q = (b*anew - a*bnew)/ba;
}

/* Function shd_upd */

func shd_upd( shd, idx )
/* DOCUMENT new_shd = shd_upd( shd, idx )

     where 'shd' is an array to be updated (increased by 1) at
     positions (indices) as given by 'idx'.

     Takes into account that indices may be repeated.

     2009-11-03/NJW
*/
{

   shdw = shd;
   idxw = idx(sort(idx));

   do {
      dxi = shift(idxw,1);
      d = shift(dxi - idxw,-1);
      d(1) = 1;
      // unique elements are now: where(d)
      shdw(idxw)++; // operates only once on each array element
      w = where(d==0); // repeated elements
      nw = numberof(w);
      if( nw ) idxw = idxw(w);
   } while( nw );

   return shdw;

}

/* Function str_erase_between_symbols */

func str_erase_between_symbols( line, symbol )
/* DOCUMENT new_line = str_erase_between_symbols( line, symbol )

    'symbol' can be a character or a string (only the first
    character of the string is considered).
    Only erasure between matching pairs.

   2010-06-09/NJW
*/
{
   lenline = strlen(line);
   cline = *pointer(line);
   if( structof(symbol) == string ) symbol = (*pointer(symbol))(1);
   n = 0;
   p = [];
   for( i = 1; i <= lenline; i++ ) {
      if( cline(i) == symbol ) {
         grow,p,i;
         n++;
      }
   }
   if( n == 0 || n%2 == 1 ) return line;
   for(j = 1; j < n; j += 2 ) {
      for( i = p(j); i <= p(j+1); i++ ) cline(i) = ' ';
   }
   return string(&cline);
}

/* Function str_get_words */

func str_get_words( str, skip= )
/* DOCUMENT res = str_get_words( str, skip= )

   Returns an array of strings holding each word from the
   input string 'str' (must be a scalar string).

   Keyword 'skip' can be set to a character and everything
                  between such a pair will be erased before
                  words are extracted.
   2010-06-09/NJW
*/
{
   if( skip ) str = str_erase_between_symbols( str, skip );
   //+ sel = strword( str,"- \n\t.,:;|<>()%@$?[]{}'\\!=#\"+&*/" ,100);
   sel = strword( str, "^_A-Za-z0-9", 100);
/*
 *   You might consider using
 *     delim = "^_A-Za-z0-9"
 */
   if( sel(2) < 0 ) return []; // indicating no words found
   words = strpart( str, sel );
   words = words(where(words));
   // eliminate words that consist of only digits
   dig = is_digit(words);
   words = words(where(!dig));
   return words;
}

/* Function rm_slashcom */

func rm_slashcom( filename )
/* DOCUMENT new_text = rm_slashcom( filename )

   Returns the file content but cleaned for
   double slash comments.

  2010-06-09/NJW
*/
{
   text = rdfile( filename );
   ntext = numberof(text);

   for( i = 1; i <= ntext; i++ ) {
      line = str_erase_between_symbols( text(i), '"' );
      if( is_void(line) ) continue;
      if( (pos = strpos(line,"//")) ) {
         text(i) = pos == 1 ? "" : strpart(text(i),1:pos-1);
      } else continue;
   }
   return text;
}

/* Function parpath */

func parpath( rootname )
/* DOCUMENT par_file_name = parpath( rootname )

   Returns name of .par file from PFILES
*/
{
   ostype = get_env("OSTYPE");
   if( strlen(ostype) == 0 ) { // neither Linux nor Unix
      pfiles = "."; // *.par file must be in current directory
   } else pfiles = strsplit(get_env("PFILES"),";")(1);
   ss = strsplit(pfiles,":");
   nss = numberof(ss);
   for( i = 1; i <= nss; i++ ) {
      fname = ss(i)+"/"+rootname+".par";
      if( file_test(fname) ) return fname;
   }
   return [];
}

/* Function sigdig */

func sigdig( x, n )
/* DOCUMENT xd = sigdig( x, n )

    returns 'x' with 'n' digits.

    Ex: > sigdig( 12.345, 2)
        12
        > sigdig(0.012345, 3)
        0.0123
*/
{
   if( double(x) == 0.0 ) return 0.0;
   ax = abs(double(x));
   sGn = x < 0 ? -1 : 1;
   f = 10.^(-floor(log10(ax)));
   g = 10^(n-1);
   y = long(ax*f*g+0.5)/(f*g);
   return sGn * y;
}

/* Function arr_info */

struct s_Arr_info {
   string type;
   long n;
   double mn;
   double mx;
   double av;
   double rs;
}
func arr_info( arr )
/* DOCUMENT arr_info, arr

   Function: returns struct
   Subroutine: prints results

   Type                 s.type
   Number of elements   s.n
   Minimum, maximum     s.mn, s.mx
   Average, RMS         s.av, s.rs
*/
{
   t = typeof(arr);
   if( am_subroutine() ) {
      write,format="%i elements of type %s\n", numberof(arr), t;
      if( t == "long" || t == "int" ) {
         write,format="Min: %i, Max: %i\n", min(arr), max(arr);
      } else if( t == "double" || t == "float" ) {
         write,format="Min: %.6g, Max: %.6g\n", min(arr), max(arr);
      }
      write,format="Avg: %.6g, Rms: %.6g\n", wavg(arr), wrms(arr);
   } else {
      s = s_Arr_info();
      s.type = t;
      s.n = numberof(arr);
      s.mn = double(min(arr));
      s.mx = double(max(arr));
      s.av = double(wavg(arr));
      s.rs = double(wrms(arr));
   }
   return s;
}

/* Function interp2 */

func interp2( zorig, xorig, yorig, x, y )
/* DOCUMENT z = interp2( zorig, xorig, yorig, x, y )

    Returns the bi-linearly interpolated value where
       zorig  is a MxN array of z-values
       xorig  is a M dim array of x values
       yorig  is a N dim array of y values
       x,y    is where the z value is wanted
   Outside of the area spanned by xorig,yorig the edge values of zorig
   are returned.

   SEE ALSO: interp (Yorick function), interpl (log interpolation, this file).

   2011-01-02/NJW
*/
{
   if( !is_scalar(x) ) error,"x must be a scalar";
   if( !is_scalar(y) ) error,"y must be a scalar";

   dmsz = dimsof( zorig );
   dmsx = dimsof( xorig );
   dmsy = dimsof( yorig );

   M = dmsx(2); // number of elements in xorig array
   N = dmsy(2); // number of elements in yorig array

   if( dmsz(1) != 2 ) error,"zorig must be a 2D array";
   if( dmsx(1) != 1 ) error,"xorig must be a 1D array";
   if( dmsy(1) != 1 ) error,"yorig must be a 1D array";
   if( dmsz(2) != M ) error,"Dim of xorig does no match first dim of zorig";
   if( dmsz(3) != N ) error,"Dim of yorig does no match second dim of zorig";

   wx = where( x > xorig );
   if( numberof(wx) == 0 ) { // x is 'too small'
      return interp( zorig(1,), yorig, y );
   } else if( numberof(wx) == M ) { // x is 'too large'
      return interp( zorig(0,), yorig, y );
   } else { // x is inside covered interval
      i = wx(0);
      wy = where( y > yorig );
      if( numberof(wy) == 0 ) { // y is 'too small'
         return interp( zorig(,1), xorig, x );
      } else if( numberof(wy) == N ) { // y is 'too large'
         return interp( zorig(,0), xorig, x );
      } else { // y is inside covered interval
         j = wy(0);
         f = (x - xorig(i))/(xorig(i+1)-xorig(i));
         za = zorig(i,j) + f*(zorig(i+1,j) - zorig(i,j));
         zb = zorig(i,j+1) + f*(zorig(i+1,j+1) - zorig(i,j+1));
         return za + (y - yorig(j))*(zb - za)/(yorig(j+1)-yorig(j));
      }
   }
}

/* Function interpl */

func interpl( v, vx, x )
/* DOCUMENT vals = interpl( v, vx, x )

    Returns an array of logarithmically interpolated values
    hence none of the argument arrays may contain zero or negative values.

    SEE ALSO: interp (Yorick function).

*/
{
   if( anyof(v <= 0.0) ) error,"Unexpected value (v) <= 0";
   if( anyof(vx <= 0.0) ) error,"Unexpected value (vx) <= 0";
   if( anyof(x <= 0.0) ) error,"Unexpected value (x) <= 0";

   return exp(interp(log(v),log(vx), log(x)));
}

/* Function arr_fill_in */

func arr_fill_in( x, val=, epsi= )
/* DOCUMENT res = arr_fill_in( x, val=, epsi= )

   Returns an array (1D like 'x') filled in with interpolated
   values around elements with value near 'val' (default -99.)
   with maximal deviation 'epsi' (default 0.1). It wraps around.

   2011-02-01/NJW
*/
{
   n = numberof(x);
   xout = x;
   if( is_void(val) ) val = -99.0;
   if( is_void(epsi) ) epsi = 0.1;

   for( i = 1; i <= n; i++ ) {

      if( !near( xout(i), val, epsi ) ) continue;
      // locate left anchor
      i1 = i;
      while( near( xout(i1), val, epsi) ) i1--;
      // i1 may be <= 0

      // locate right anchor
      i2 = i;
      while( near( xout(i2%n), val, epsi) ) i2++;
      // i2 may be > n

      // Fill in
      range = indgen(i1:i2)%n;
      nrange = numberof(range);
      w = where( range <= 0 );
      if( numberof(w) ) range(w) += n;
      xout(range(2:nrange-1)) = interp([xout(i1),xout(i2%n)],[i1,i2],indgen(i1+1:i2-1));
   }
   return xout;
}

/* Function xjour */

func xjour( strngs, see=, ed= )
/* DOCUMENT xjour, strngs, see=, ed=

    Will write the content of 'strngs' (scalar or string
    array) to a file named 'journal_YYMMDD' while appending.
    This is intended for saving Yorick commands etc. for future
    reference and perhaps macro making.

    Since '"' is an annoying character that should be escaped
    if can be replaced with '@' that is translated to '"'.

    Sorry, no way to save '@' in the string.

   Keywords:
      see    for inspecting the journal file so far
      ed     for editing the journal file
*/
{
   jname = "journal_"+ndate(1);
   if( typeof(strngs) == "string" ) {
      write_slist,jname,strstrrepl(strngs,"@","\""),app=1;
   }
   if( see ) {
      write,"Today's journal: "+jname;
      prstrarr, rdfile(jname);
   }
   if( ed ) vi,jname;
}

/* Function f2scienota */

func f2scienota( x, ndec= )
/* DOCUMENT  strngs = f2scienota( x, ndec= )

    Returns strings with the numbers 'x' in scientific notation
    suited for yorick plot annotations.

    Keyword: ndec   Number of decimals (defaults to 2)
*/
{
   if( is_scalar(x) ) return _f2scienota( x, ndec=ndec );
   n = numberof(x);
   scistr = array(string,n);
   for( i = 1; i <= n; i++ ) scistr(i) = _f2scienota( x(i), ndec=ndec );
   return scistr;
}

func _f2scienota( x, ndec= )
{
   if( x == 0 ) return "0";
   if( is_void(ndec) ) ndec = 3;
   s = " ";
   if( x < 0 ) {
      s = "-";
      x = -x;
   }
   lx = log10(x);
   exponent = long(floor(lx));
   mantissa = x * 10.^(-exponent);
   fmt = swrite(format="%%s%%%i.%if 10^%%i^", ndec+2, ndec);
   //+ write,"fmt : >"+fmt+"<";
   scistr = swrite(format=fmt, s, mantissa, exponent);
   //+ write,"scistr : >"+p1+"<";
   return scistr;
}

/* Function ranstr */

func ranstr( len, uc=, lc=, n= )
/* DOCUMENT str = ranstr( len, uc=, lc=, n= )

    Returns a random string of length 'len' using
    characters A-Z,a-z,0-9

    Keywords:
       uc      Only upper letters are used (i.e. no digits)
       lc      Only lower letters are used (i.e. no digits)
       n       Only numbers are used
*/
{
   if( uc ) {
      return string(&char('A'+indgen(0:25))(long(floor(random(len)*26)+1)));
   } else if( lc ) {
      return string(&char('a'+indgen(0:25))(long(floor(random(len)*26)+1)));
   } else if( n ) {
      return string(&char('0'+indgen(0:9))(long(floor(random(len)*10)+1)));
   } else {
      basket = array( char, 62);
      basket(1:26) = 'A'-1+indgen(26);
      basket(27:52) = 'a'-1+indgen(26);
      basket(53:62) = '0'-1+indgen(10);
      return string(&basket(long(floor(random(len)*62)+1)));
   }
}

/* Function datagroups */

func datagroups( arr, spacelimit )
/* DOCUMENT idx = datagroups( t, spacelimit )

   A function to analyze typically a timeseries (t) and
   return indices of the groups of elements.

   't' is assumed to be sorted in increasing order.

   The groups are identified by a certain amount of
   empty space between them.

   An example:
      t = [1.,1.2,1.5,1.7,4.,4.2,4.5, 5.1,5.2]
      datagroups(t, 2.) will return [1, 5]
      datagroups(t, 0.5 ) will return [1, 5, 8]

      Obtain the lengths of the groups by:
        g = datagroups(t, 0.5);
        gg = g;
        grow, gg, numberof(t)+1;
        len = gg(dif);

      Indices of group N are:
        idx = indgen(gg(N):gg(N+1)-1);

    Note the resemblance with the function 'uniq'

    2011-05-27/NJW
*/
{
   return grow(1, where(arr(dif) > spacelimit)+1);
}

/* Function fold_gaussy */

func fold_gaussy( e, f, sigma )
/* DOCUMENT fnew = fold_gaussy( [e,] f, sigma )

  Fold a spectrum or a number of spectra with a Gauss function with a non-constant sigma
  The folding is done along the first dimension.

   Call -  e :  1D energy array
                If 'e' is absent it is assumed to be indgen(dimsof(f)(2))
           f : array with spectrum, first dimension must have same size as 'e'
         sigma  : scalar with standard deviation,
                  or array with same size as 'e'

   Return : folded spectrum, conformable with 'f'.

    2012-11-06/NJW based on 'fold_gaussx'

   SEE ALSO: fold_gaussx

   fold_gaussy is slightly slower than fold_gaussx when operating on a
   1D spectrum.

*/

{
   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(sigma) ) {
      // There are at most two arguments
      sigma = f;
      f = e;
      fdms = dimsof(f);
      e = double(indgen(fdms(2)));
   }
   fdms = dimsof(f);

   n = numberof(e); // == fdms(2)
   ee = double( e );
   ns = numberof(sigma);
   if( fdms(2) != n ) {
      write,"mismatching dimensions of 'e' and 'f'\n";
      return -1;
   }
   if( ns != 1 && ns != n ) {
      write,"'sigma' has illegal dimension\n";
      return -1;
   }
   sigma2 = sigma * sqrt(2.);
   if( ns == 1 ) sigma2 = sigma2(-:1:n);

   // Define channel boundaries

   eb = 0.5*(ee + shift(ee,-1));
   eb(1) = (3*ee(1) - ee(2))/2;
   grow,eb,(3*ee(0) - ee(-1))/2;

   w = array(double,n,n); // 'redistribution matrix'
   for( i = 1; i <= n; i++ ) {
      j = where((e > ee(i)-3.5*sigma2(i)) + (e < ee(i)+3.5*sigma2(i)) == 2);
      if( numberof(j) ) {
         x2 = (eb(j+1) - ee(i))/sigma2(i);
         x1 = (eb(j) - ee(i))/sigma2(i);
         wei = erf(x2) - erf(x1);
         w(i,j) = wei / wei(sum);
      }
   }

   g = w(,+) * f(+,..);

   timer, time_keeper, elapsed_time;
   write,"CPU time used: "+ftoa(elapsed_time(1),ndec=3)+" s";

   return g;

}
 /* Function message_board */

func message_board( text, pane= )
/* DOCUMENT message_board, text, pane=

     Displays the text 'text' (scalar string) in a
     plot window define by 'pane' (defaults to 7).

*/
{
   if( is_void(pane) ) pane = 7;
   prev_win = window();
   window,pane,style="nobox.gs";
   xyouts,0.5,0.58,ndate(3),charsize=1.0,vir=1,align=0.5;
   xyouts,0.5,0.42,text,charsize=3.,vir=1,align=0.5,font="times",color=blue;
}
%FILE% ifs.i
/************************************************************
 *
 *  A visual or graphical selection of a file
 *
 *  Package with functions:
 *        ia_file_selection
 *        directory_selection
 *        file_selection
 *
 **************************************************************/

/* Function ia_file_selection */

func ia_file_selection( start_dir, &res_dir, sel= )
/* DOCUMENT file = ia_file_selection( start_dir, >res_dir, sel= )

    Argument: start_dir tells where to start the search
                if omitted the current directory will be used.
              res_dir is returned as the last directory searched.
    Keyword: 'sel' is used as an argument for 'strglob' to present
             only a selection of files.

    2011-12-16/NJW
*/
{
   cwind = window();
   cwd = get_cwd();
   if( !is_void(start_dir) ) cd, start_dir;

   do {
      status = directory_selection(sel=sel);
      if( status ) {
         window,cwind;
         return [];
      }
      res_dir = get_cwd();
      file = file_selection(sel=sel);
   } while ( structof(file) == int );

   cd,cwd;
   write,"Now back in "+get_cwd();
   window,cwind;
   write,"  - and using window "+itoa(cwind);
   return file;
}

func directory_selection( sel= )
{
   local subdirs;

   // List directories

   window,7,style="nobox.gs";
   files = lsdir(".",subdirs);
   nfiles = numberof(files);
   cwd = get_cwd();
   if( cwd != "/" ) grow,subdirs,"..";

   nsubdirs = numberof(subdirs);

   if( nsubdirs ) {
      subdirs = subdirs(sort(subdirs));
      nbatches = (nsubdirs-1)/60 + 1;
      ibatch = 1;

      showbatch:

      //+ write,"Showing batch#"+itoa(ibatch)+" of "+itoa(nbatches);
      nbstart = (ibatch - 1)*60 + 1;
      nbstop  = ibatch == nbatches ? nsubdirs : ibatch*60;

      plot,[0,0,1,1,0],[0,1,1,0,0];
      xyouts,0.16,0.894,esc_underscore(get_cwd()),charsize=0.7,font="schoolbook",device=1;
      y = 0.95;
      x = 0.1;
      xarr = yarr = [];
      for( i = nbstart; i <= nbstop; i++ ) {
         oplot,[x-0.05],[y+0.010],ps=19,symsize=0.35,color="blue";
         xyouts,x,y,esc_underscore(subdirs(i)),charsize=0.7,font="schoolbook",color="blue";
         grow, xarr, x - 0.05;
         grow, yarr, y + 0.01;
         y -= 0.031;
         if( y < 0.02 ) {
            x = 0.6;
            y = 0.95;
         }
      }
      // Draw box for shift to plain files but only if there are some
      if( nfiles ) {
         xyouts,0.5,0.015,"Go to files",charsize=0.8,font="schoolbook",color="green",align=0.5;
         oplot,0.3*([0,0,1,1,0]-0.5)+0.5,0.04*([0,1,1,0,0]-0.5)+0.025,color="green";
         grow, xarr, 0.5;
         grow, yarr, 0.025;
      } else {
         grow, xarr, 10.; // make values that can never be selected
         grow, yarr, 10.;
      }
      // When more directories exist then show arrow
      if( ibatch < nbatches ) {
         oplot,[0.98],[0.02],ps=21,fill=1,symsize=0.8,color="red";
         grow, xarr, 0.98;
         grow, yarr, 0.02;
         flagforw = 1;
      } else flagforw = 0;
      // When less directories exist then show arrow
      if( ibatch > 1 ) {
         oplot,[0.02],[0.98],ps=20,fill=1,symsize=0.8,color="red";
         grow, xarr, 0.02;
         grow, yarr, 0.98;
         flagbackw = 1;
      } else flagbackw = 0;

      r = curmark1(prompt="Select the directory ...",nomark=1);
      d = (xarr - r(1))^2 + (yarr - r(2))^2;
      idx = d(mnx);
      //+ write,"Min d = "+ftoa(d(idx),ndec=5);
      if( d(idx) > 0.02 ) return 1; // stop when too far from selection
      if( idx < numberof(xarr)-flagforw-flagbackw ) {
         //+ write,"You chose a subdirectory: "+subdirs(idx+nbstart-1)+", confirm ...";
         oplot,[xarr(idx)],[yarr(idx)],ps=19,symsize=0.35,color="red";
         r = curmark1(prompt="Confirm the selection ...",nomark=1);
         d = (xarr - r(1))^2 + (yarr - r(2))^2;
         idx2 = d(mnx);
         //+ write,"Min d = "+ftoa(d(idx2),ndec=5);
         if( d(idx2) > 0.02 ) return 1; // stop when too far from selection
         if( idx == idx2 ) {
            //+ write,"Yes, confirmed!";
            cd, subdirs(idx+nbstart-1);
         } //+ else write,"Try again!";
         status = directory_selection(sel=sel);
      } else {
         if( idx == numberof(xarr) - flagforw - flagbackw ) {
            //+ write,"You'll move to file selection.";
         } else {
            if( idx == numberof(xarr) - flagbackw ) {
               // move forwards
               //+ write," - forward move";
               ibatch++;
               goto showbatch;
            } else {
               // move backwards
               //+ write," - backward move";
               ibatch--;
               goto showbatch;
            }
         }
      }
   }
   return 0; // flag status OK at return
}


/* Function file_selection */


func file_selection( sel= )
{
   extern Previous_selections;

   local subdirs;

   // List files

   window,7,style="nobox.gs";
   files = lsdir(".",subdirs);
   if( !is_void(sel) ) {
      w = where(strglob(sel,files));
      files = numberof(w) ? files(w) : [];
   }

   nfiles = numberof(files);

   if( nfiles ) {
      files = files(sort(files));
      nbatches = (nfiles-1)/60 + 1;
      ibatch = 1;

      showbatch:

      //+ write,"Showing batch#"+itoa(ibatch)+" of "+itoa(nbatches);
      nbstart = (ibatch - 1)*60 + 1;
      nbstop  = ibatch == nbatches ? nfiles : ibatch*60;

      plot,[0,0,1,1,0],[0,1,1,0,0];
      xyouts,0.16,0.894,esc_underscore(get_cwd()),charsize=0.7,font="schoolbook",device=1;
      y = 0.95;
      x = 0.1;
      xarr = yarr = [];
      for( i = nbstart; i <= nbstop; i++ ) {
         // Check for previous selections
         if( numberof(Previous_selections) ) {
            if( numberof(where(Previous_selections == fullpath(files(i)))) ) {
               oplot,[x-0.05],[y+0.010],ps=19,symsize=0.3,color="yellow",fill=1;
            }
         }
         oplot,[x-0.05],[y+0.010],ps=19,symsize=0.35,color="green";
         xyouts,x,y,esc_underscore(files(i)),charsize=0.7,font="schoolbook",color="green";
         grow, xarr, x - 0.05;
         grow, yarr, y + 0.01;
         y -= 0.031;
         if( y < 0.02 ) {
            x = 0.6;
            y = 0.95;
         }
      }

      // Draw box for shifting back to directory
      xyouts,0.5,0.015,"Go back to directory",charsize=0.8,font="schoolbook",color="blue",align=0.5;
      oplot,0.3*([0,0,1,1,0]-0.5)+0.5,0.04*([0,1,1,0,0]-0.5)+0.025,color="blue";
      grow, xarr, 0.5;
      grow, yarr, 0.025;

      // When more files exist then show arrow
      if( ibatch < nbatches ) {
         oplot,[0.98],[0.02],ps=21,fill=1,symsize=0.8,color="red";
         grow, xarr, 0.98;
         grow, yarr, 0.02;
         flagforw = 1;
      } else flagforw = 0;
      // When less directories exist then show arrow
      if( ibatch > 1 ) {
         oplot,[0.02],[0.98],ps=20,fill=1,symsize=0.8,color="red";
         grow, xarr, 0.02;
         grow, yarr, 0.98;
         flagbackw = 1;
      } else flagbackw = 0;

      r = curmark1(prompt="Select a file ...",nomark=1);
      d = (xarr - r(1))^2 + (yarr - r(2))^2;
      idx = d(mnx);
      //+ write,"Min d = "+ftoa(d(idx),ndec=5);
      if( d(idx) > 0.02 ) return []; // stop when too far from selection
      if( idx == numberof(xarr)-flagforw-flagbackw ) return int(1);
      if( idx < numberof(xarr)-flagforw-flagbackw ) {
         //+ write,"You chose a file: "+files(idx+nbstart-1)+", confirm ...";
         oplot,[xarr(idx)],[yarr(idx)],ps=19,symsize=0.35,color="red";
         r = curmark1(prompt="Confirm selection ...",nomark=1);
         d = (xarr - r(1))^2 + (yarr - r(2))^2;
         idx2 = d(mnx);
         //+ write,"Min d = "+ftoa(d(idx2),ndec=5);
         if( d(idx2) > 0.02 ) return []; // stop when too far from selection
         if( idx == idx2 ) {
            //+ write,"Yes, confirmed!";
            grow, Previous_selections, fullpath(files(idx+nbstart-1));
            return fullpath(files(idx+nbstart-1));
         } else {
            //+ write,"Try again:";
            return file_selection(sel=sel);
         }
      } else {
         if( idx == numberof(xarr) - flagforw - flagbackw ) {
            //+ write,"You'll move to file selection.";
         } else {
            if( idx == numberof(xarr) - flagbackw ) {
               // move forwards
               //+ write," - forward move";
               ibatch++;
               goto showbatch;
            } else {
               // move backwards
               //+ write," - backward move";
               ibatch--;
               goto showbatch;
            }
         }
      }
   }
}

ifs = ia_file_selection;
//+ write,"Shorthand: ifs for ia_file_selection.";
%FILE% image.i
/* Function imagedoc */

extern imagedoc;
/* DOCUMENT ****************************************************
 *
 *      Package by Niels J. Westergaard 2003-03-30 for
 *      image analysis.
 *      2008-09-24/NJW added palette manipulation functions

    _colscale           getimval            peaksearch2         
    _pal_write          getimvals           rebin               
    add_peak            gkernel             remap               
    convol2d            image2events        signif              
    cur_extract_box     imcut               src_cts             
    curmark             imhcut              unwiden_image       
    curmark1            mk_palette          w0                  
    disp                pal                 w1                  
    disp9               pal_edit            w2                  
    dispc               pal_plot            w3                  
    distances           palastro            w4                  
    edge_suppress       peaksearch0         widen_image         
    flatfield           peaksearch1         imcolorbar

*****************************************************/

/* Function mk_palette */

func mk_palette( name )
/* DOCUMENT mk_palette, name

   The RGB are defined individually by mouse clicking in coordinate system.
   The argument 'name' is without the '.gp' extension.

   2008-10-10/NJW (or about that time)

*/
{
   if( typeof(name) != "string" ) error,"A name must be given";
   window,0;
   ncolors = 240;
   // define red
   plot,[1,ncolors],[0,0],yr=[0,256];
   oplot,[1,ncolors],[255,255];
   oplot,[1,1],[0,255];
   oplot,[ncolors,ncolors],[0,255];
   write,"Define the RED color function :";
   r = _colscale( ncolors );
   oplot, r, color="red";
   write,"Define the GREEN color function :";
   g = _colscale( ncolors );
   oplot, g, color="green";
   write,"Define the BLUE color function :";
   b = _colscale( ncolors );
   oplot, b, color="blue";

   _pal_write, name, r, g, b;

   write,format="Palette now stored in %s.gp\n", name;

}

/* Function _pal_write */

func _pal_write( name, r, g, b )
{
   ncolors = numberof(r);
   stream = open(GISTDIR+name+".gp","w");
   write,stream,format="# Palette created by mk_palette %s/NJW\n", ndate(3);
   write,stream,format="ncolors= %i\n", ncolors;
   write,stream,format="#    r   g    %s\n","b";
   for( i = 1; i <= ncolors; i++ ) {
      write,stream,format="%8i%8i%8i\n", r(i), g(i), b(i);
   }
   close, stream;

}

/* Function _colscale */

func _colscale( ncolors )
{
   rc = curmark();
   n = numberof(rc)/2;
   rcx = rc(1:0:2);
   rcy = rc(2:0:2);
   is = sort(rcx);
   rcx = rcx(is);
   rcy = rcy(is);
   rcx(1) = 1.;
   if( rcx(2) < rcx(1) ) rcx(2) = 2.;
   rcx(0) = ncolors;
   if( rcx(-1) > rcx(0) ) rcx(-1) = ncolors-1;
   r = long(interp( rcy, rcx, indgen(ncolors) ) );
   w = where( r < 0 );
   if( numberof(w) ) r(w) = 0;
   w = where( r > 255 );
   if( numberof(w) ) r(w) = 255;

   return r;

}

/* Function pal_edit */

func pal_edit( name, step= )
{
   if( is_void(step) ) step = 10;

   p = GISTDIR+name+".gp";
   pal_plot, name;
   r = rscol(p,1,lng=1,silent=1,nomem=1);
   g = rscol(p,2,lng=1,silent=1,nomem=1);
   b = rscol(p,3,lng=1,silent=1,nomem=1);
   ncolors = numberof(r);
   rgb = array(long,ncolors,3);
   rgb(,1) = r;
   rgb(,2) = g;
   rgb(,3) = b;

   ans = "";
   answ = ["r","g","b"];
   cstr = ["red","green","blue"];
   read,prompt="Enter color (r,g, or b) : ... ", ans;
   w = where( ans == answ );
   if( !numberof(w) ) error,"Illegal input";
   nc = w(1);
   again = 1;
   h = 1;
   grow,h,indgen(step:ncolors:step);

   //while( again ) {
      oplot,h,rgb(h,nc),ps=2,symsize=2,color=cstr(nc);
      for( i = 1; i <= numberof(h); i++ ) {
         oplot,[h(i),h(i)],[0,255],color=cstr(nc);
      }
      pts = curmark();
      npts = numberof(pts);
      xpts = pts(1:npts:2);
      ypts = pts(2:npts:2);
      npts /= 2;
      y0 = rgb(h,nc);
      for( i = 1; i <= npts; i++ ) {
         w = where( min(abs(xpts(i)-h)) == abs(xpts(i)-h) )(1);
         y0(w) = long(ypts(i));
      }
      rgb(,nc) = long(interp( y0, h, indgen(ncolors) ));
      w = where( rgb(,nc) < 0 ); if(numberof(w)) rgb(w,nc) = 0;
      w = where( rgb(,nc) > 255 ); if(numberof(w)) rgb(w,nc) = 255;
      oplot, rgb(,nc), color=cstr(nc);
      _pal_write, name, rgb(,1), rgb(,2), rgb(,3);
      pal_plot, name;
      again = 0;
   //}
}


/* Function pal_plot */

func pal_plot( name )
{
   pal, name;
   p = GISTDIR+name+".gp";
   r = rscol(p,1,lng=1,silent=1,nomem=1);
   g = rscol(p,2,lng=1,silent=1,nomem=1);
   b = rscol(p,3,lng=1,silent=1,nomem=1);
   ncolors = numberof(r);
   a = array(double,ncolors,256);
   for(i=1;i<=ncolors;i++) a(i,) = i-1;
   disp,a,reset=1,title=name+".gp";

   oplot,r,color="red";
   oplot,g,color="green";
   oplot,b,color="blue";

}

/* Function flatfield */

func flatfield( image, sigma, sel= )
/* DOCUMENT new_image = flatfield( image, sigma, sel= )

   The image 'image' is folded with a gaussian kernel
   with sigma = 'sigma' and then subtracted from the
   original image. The process is repeated with
   excluded source areas.
   Keyword 'sel' must be an array of same dimension
   as 'image' with 1 where pixels are useful and zero
   elsewhere.

   2007-06-19/NJW

*/
{
   require, "fconvol.i";

   di = dimsof(image);
   if( di(1) != 2 ) {
      write,"Not a 2D image";
      return [];
   }
   dosel = 0;
   if( !is_void(sel) ) {
      d = dimsof(sel);
      if( d(1) != 2 ) {
         write,"'sel' is not a 2D image";
         return [];
      }
      if( d(2) != di(2) || d(3) != di(3) ) {
         write,"'sel' is not commensurate with 'image'";
         return [];
      }
      dosel = 1;
   }
   w = dosel ? where( sel ) : indgen(di(2)*di(3));
   //   Avoid changing the input image
   im1 = image;
   fimage = gfconvol( image, sigma );
   //    First subtraction
   diff  = image - fimage;
   //    Substitute image parts that exceed 3sigma
   //    to avoid subtracting too much around sources
   rms_1 = wrms( diff(w) );
   q = where( abs(diff) > 3*rms_1 );
   if( numberof(q) > 0 ) {
      im1(q) = fimage(q);
      fimage = gfconvol( im1, sigma );
      diff = image - fimage;
   }

   return diff;
}


/* Function src_cts */

func src_cts( image )
/* DOCUMENT number_of_counts = src_cts( image )

   Interactive function to get the number of source
   counts under the assumption that 'image' is a 2D
   array displayed in an active plot window where the
   unit of the axes is in pixels.
   'curmark1' is called twice; first to define the
   source area and then to define the background area.

   The source area must either be completely included
   in the background area or the two areas should be
   disjunct.

   2007-02-06/NJW
*/
{

   p_src = curmark1( style=1, prompt="Mark source ..." );
   p_bkg = curmark1( style=1, prompt="Mark background ..." );
   if( p_src(1) > p_src(3) ) { // swap
      x = p_src(3); p_src(3) = p_src(1); p_src(1) = x;
   }
   if( p_src(2) > p_src(4) ) { // swap
      x = p_src(4); p_src(4) = p_src(2); p_src(2) = x;
   }
   if( p_bkg(1) > p_bkg(3) ) { // swap
      x = p_bkg(3); p_bkg(3) = p_bkg(1); p_bkg(1) = x;
   }
   if( p_bkg(2) > p_bkg(4) ) { // swap
      x = p_bkg(4); p_bkg(4) = p_bkg(2); p_bkg(2) = x;
   }
   dms = dimsof( image );
   x = span(1,dms(2),dms(2))(,-:1:dms(3));
   y = span(1,dms(3),dms(3))(-:1:dms(2),);
   i_src = x > p_src(1) & x < p_src(3) & y > p_src(2) & y < p_src(4);
   w_src = where( i_src );
   nw_src = numberof( w_src );
   i_bkg = x > p_bkg(1) & x < p_bkg(3) & y > p_bkg(2) & y < p_bkg(4);
   w_bkg = where ( i_bkg & (!i_src) );
   nw_bkg = numberof( w_bkg );

   if( nw_src == 0 || nw_bkg == 0 ) {
      write,"Source or background area is zero!";
      return [];
   }
   bkg_level = avg( image(w_bkg) );
   write,format="Number of src pixels: %i\n", nw_src;
   write,format="Number of bkg pixels: %i\n", nw_bkg;
   write,format="Bkg level: %f\n", bkg_level;
   write,format="Cts in source area: %f\n", sum(image(w_src));
   src_counts = sum(image(w_src)) - bkg_level * nw_src;
   write,format="Src counts: %f\n", src_counts;

   return src_counts;

}

/* Function palastro */

func palastro(num)
/* DOCUMENT palastro[, num]

   defines the astro-num palette for plot window

    2007-02-06/NJW
*/
{
   require, "idlx.i";

   if( is_void(num) ) num = 1;
   snum = itoa(num);
   palette,GISTDIR+"astro"+snum+".gp";
}

/* Function pal */

func pal(name)
/* DOCUMENT pal, name

   defines the named palette for plot window

    2007-03-05/NJW, 2010-04-20/NJW update
*/
{
   require, "idlx.i";
   local dirname, basname;

   if( is_void(name) ) {
      write,format="GISTDIR: %s\n", GISTDIR;
      list = file_search("*.gp",GISTDIR);
      for( i = 1; i <= numberof(list); i++ ) {
         splitfname, list(i), dirname, basname;
         write,format="%20s\n",basname;
      }
      return;
   }
   palette,GISTDIR+"/"+name+".gp";
}

func w0(a) { window,0; }
func w1(a) { window,1; }
func w2(a) { window,2; }
func w3(a) { window,3; }
func w4(a) { window,4; }

/* Function 'distances' */

func distances( arg1, arg2, arg3, arg4, arg5, arg6 )
/* DOCUMENT array = distances( dim1, cen1 )
                     1 D version
            array = distances( dim1, dim2, cen1, cen2 )
                     2 D version
            array = distances( dim1, dim2, dim3, cen1, cen2, cen3 )
                     3 D version
      returns an array with dimensions dim1, dim2, ... with
      distances in units of pixel
      from the position (cen1, cen2, ...)

   To get a symmetrical image: cen = double(dim + 1)/2.

*/

{
   if( is_void(arg3) ) { // 1D version
      dim1 = arg1; cen1 = arg2;
      return abs(indgen(dim1) - cen1);
   }
   if( is_void(arg5) ) { // 2D version
      dim1 = arg1; dim2 = arg2;
      cen1 = arg3; cen2 = arg4;
      x = indgen(dim1)(,-:1:dim2);
      y = indgen(dim2)(-:1:dim1,);
      return sqrt((x-cen1)^2 + (y-cen2)^2);
   }
   // 3D version
   dim1 = arg1; dim2 = arg2; dim3 = arg3;
   cen1 = arg4; cen2 = arg5; cen3 = arg6;
   x = indgen(dim1)(,-:1:dim2,-:1:dim3);
   y = indgen(dim2)(-:1:dim1,,-:1:dim3);
   z = indgen(dim3)(-:1:dim1,-:1:dim2,);
   return sqrt((x-cen1)^2 + (y-cen2)^2 + (z-cen3)^2);
}

/* Function disp */

func disp( im, pane=, reset=, xax=, yax=, title=, xtitle=, \
           ytitle=, lcut=, ucut=, Lcut=, Ucut=, pal=, uplf=, cb= )
/* DOCUMENT disp, im, pane=, reset=, xax=, yax=, title=, xtitle=, \
                      ytitle=, lcut=, ucut=, Lcut=, Ucut=, pal=, uplf=, cb=

      Display an image on the screen

              pane : Plot window number (0 thru 7), default is current
     Keywords lcut : Lower cut
              ucut : Upper cut, values in accumulated distribution
                Both defined as fractions compared to the interval
                min(im) - max(im)
              Ucut : Upper cut in image values
              Lcut : Lower cut in image values
              pal  : Name of palette to use (.gp name extension is added if missing)
              cb   : Add a colorbar with this number of ticbars

     2007-02-06/NJW
     2009-11-02/NJW Using 'pli' iso. 'plf'
*/

{
   local x, h;

   if( !is_void(pane) ) window, pane;
   if( !is_void(pal) ) {
      if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
      palette, pal;
   }

  /*
   *   Apply cuts if defined
   */

   im_work = im;
   if( !is_void(lcut) || !is_void(ucut) ) {
      w = where( im_work != 0 );
      if( numberof(w) > 0 ) {
         binsize = (max(im_work) - min(im_work)) / 1000.0;
         histos, im_work(w), h, x, binsize=binsize;
         h = arr_accum(h, norm=1);

         if( !is_void(lcut) ) {
            index1 = long(interp(indgen(numberof(h)),h,lcut));
            val1 = x(index1);
            w1 = where( im_work < val1 );
            if( numberof(w1) > 0 ) im_work(w1) = val1;
         }

         if( !is_void(ucut) ) {
            index2 = long(interp(indgen(numberof(h)),h,ucut));
            val2 = x(index2);
            w2 = where( im_work > val2 );
            if( numberof(w2) > 0 ) im_work(w2) = val2;
         }
      }
   }
   if( !is_void(Ucut) ) {
      w = where( im_work > Ucut );
      if( numberof(w) ) im_work(w) = Ucut;
      else im_work(0) = Ucut;// statement inserted 2011-02-08/NJW
   }
   if( !is_void(Lcut) ) {
      w = where( im_work < Lcut );
      if( numberof(w) ) im_work(w) = Lcut;
      else im_work(1) = Lcut;// statement inserted 2011-02-08/NJW
   }
   sz = dimsof(im_work);
   if( sz(1) == 2 ) {
      nxax = numberof(xax);
      nyax = numberof(yax);
      if( nxax > 0 ) {
         if( nxax != sz(2) ) {
            write,"Bad dimension of xax keyword";
            return;
         }
         f = double(sz(2))/(sz(2)-1);
         c = 0.5*(xax(0)+xax(1));
         d = 0.5*(xax(0)-xax(1));
         xv = span(c-f*d, c+f*d,sz(2)+1);
      } else {
         xv = span(0.5,sz(2)+0.5,sz(2)+1);
      }
      if( nyax > 0 ) {
         if( nyax != sz(3) ) {
            write,"Bad dimension of yax keyword";
            return;
         }
         f = double(sz(2))/(sz(2)-1);
         c = 0.5*(yax(0)+yax(1));
         d = 0.5*(yax(0)-yax(1));
         yv = span(c-f*d, c+f*d,sz(3)+1);
      } else {
         yv = span(0.5,sz(3)+0.5,sz(3)+1);
      }
      x = xv(,-:1:sz(3)+1);
      y = yv(-:1:sz(2)+1,);
      fma;
      limits; // this statement added 2009-03-13/NJW
      if( uplf ) {
         plf,im_work,y,x,legend="";
      } else {
         pli,im_work,xv(1),yv(1),xv(0),yv(0),legend="";
      }
      if( reset ) limits,"e","e","e","e";
      if( !is_void(title) ) pltitle, title;
      if( is_void(xtitle) ) xtitle="";
      if( is_void(ytitle) ) ytitle="";
      xytitles, xtitle, ytitle;
      plotcomments,init=1; // this statement added 2009-03-13/NJW
      if( cb ) colorbar,sigdig(min(im_work),3),sigdig(max(im_work),3),levs=cb;
   } else {
      write,"Not a 2D array";
   }
}


/* Function dispc */

func dispc( im, pane=, xax=, yax=, levels=, itype=, color=, over=, title=, xtitle=, ytitle= )
/* DOCUMENT dispc, im, pane=, xax=, yax=, levels=, itype=, color=, over=,
                     title=, xtitle=, ytitle=
      Display a contour plot on the plot window
      Keywords:
          pane: plot window number
          itype: axis transforms 0: both linear, 1: y log, x lin,  2: y lin, xlog, 3: both log
          xax: x-axis coordinate values
          yax: y-axis coordinate values
          levels: array of level values
          color: standard meaning
          over: causes overplot
*/

{
   if( !is_void(pane) ) window, pane;

   sz = dimsof(im);
   if( sz(1) != 2 ) {
      write,"Not a 2D array";
      return;
   }
   if( is_void(levels) ) {
      levels=span(min(im),max(im),6)(zcen);
   } else if( numberof(levels) == 1 ) {
         levels=span(min(im),max(im),long(levels)+1)(zcen);
   }
   nxax = numberof(xax);
   nyax = numberof(yax);
   if( nxax > 0 ) {
      if( nxax != sz(2) ) {
         write,"Bad dimension of xax keyword";
         return;
      }
      xv = xax;
   } else {
      xv = indgen(sz(2));
   }
   if( nyax > 0 ) {
      if( nyax != sz(3) ) {
         write,"Bad dimension of yax keyword";
         return;
      }
      yv = yax;
   } else {
      yv = indgen(sz(3));
   }
   x = xv(,-:1:sz(3));
   y = yv(-:1:sz(2),);
   fma;
   if( !is_void(itype) ) mlogxy, itype > 1, itype%2;
   limits, xv(1), xv(0), yv(1), yv(0);
   if( over) {
      plfc,im,y,x,levs=levels;
   }
   go_ahead = 1;
   if( !is_void(color) ) if( color == 0 ) go_ahead = 0;
   if( go_ahead ) plc,im,y,x,levs=levels,marks=0,color=color,legend="";
   if( !is_void(title) ) pltitle, title;
   if( is_void(xtitle) ) xtitle="";
   if( is_void(ytitle) ) ytitle="";
   xytitles, xtitle, ytitle;
   plotcomments,init=1; // this statement added 2009-11-04/NJW
}

func dispcc( im, xax, yax, levels= )
{
   plot,xax,yax,itype=2;
   dms = dimsof(im);
   x = xax(,-:1:dms(3));
   y = yax(-:1:dms(2),);
   //+ limits, 1, dms(2), 1, dms(3);
   plfc,im,y,x,levs=levels;
}

/* Function add_peak */

func add_peak( im, xp, yp, sigmax, sigmay, peak=, volume= )
/* DOCUMENT add_peak( im, xp, yp, sigmax[, sigmay], peak=, volume= )

   Returns the image with a gaussian peak added.
   Coordinate (i,j) refers to center of pixel (i,j).
   If 'sigmay' is not given it is assumed equal to 'sigmax'.
   Keyword   peak   :  Defining peak value
             volume :  Volume of peak (defaults to 1)
                       If given it will override the 'peak' value

   2006-02-23/NJW (Updated from earlier version ca. 2004)
   2010-04-06/NJW Updated to use proper integral over pixels
                  and keywords
*/

{

   if( !is_void(volume) ) {
      peak = [];
   } else {
      volume = 1.;
   }
   if( is_void(sigmay) ) sigmay = sigmax;
   sx = abs(sigmax) * sqrt(2);
   sy = abs(sigmay) * sqrt(2);
   dms = dimsof(im);
   if( dms(1) == 2 ) {
      ii = indgen(dms(2));
      arg1 = (ii + 0.5 - xp)/sx;
      arg2 = (ii - 0.5 - xp)/sx;
      tx = erf(arg1) - erf(arg2);
      jj = indgen(dms(3));
      arg1 = (jj + 0.5 - yp)/sy;
      arg2 = (jj - 0.5 - yp)/sy;
      ty = erf(arg1) - erf(arg2);
      a = volume * 0.25 * tx * ty(-,);
      if( !is_void(peak) ) a *= (peak/max(a));
      return(im + a);
   } else {
      write,"Not a 2D array";
      return(-1.0);
   }
}

/* Function convol2d  */

func convol2d( a, b )
/* DOCUMENT res = convol2d(a,kernel)

   returns the convolution of 'a' and 'kernel', both 2D arrays.
*/

{

   sza = dimsof(a);
   szb = dimsof(b);
   if( (sza(1) != 2) || (szb(1) != 2) ) {
      print,"convol2d must be called with 2d arguments";
      return;
   }
   if( szb(2) % 2 != 1 || szb(3) % 2 != 1 ) {
      print,"Kernel must have odd dimensions";
      return;
   }
   ad = double(a);
   bd = double(b);
   dx = szb(2) / 2;
   dy = szb(3) / 2;

   res = ad;

   for( i = 1; i <= sza(2); i++ ) {
   for( j = 1; j <= sza(3); j++ ) {
      weight = 0.0;
      ssum = 0.0;
      for( k = -dx; k <= dx; k++ ) {
         if( k+i >= 1 && k+i <= sza(2) ) { // in large array in x
	 for( l = -dy; l <= dy; l++ ) {
	    if( l+j >= 1 && l+j <= sza(3) ) { // in large array in y
	       ssum += ad(i+k,j+l) * bd(k+dx+1,l+dy+1);
	       weight += bd(k+dx+1,l+dy+1);
	    }
	 }
	 }
      }
      res(i,j) = ssum / weight;
   }
   }
   return( res );
}

/* Function gkernel */

func gkernel( dim1, dim2, sigma)
/* DOCUMENT kernel = gkernel(dim1, dim2, sigma)

   Returns 2D kernel with 2d Gauss function
*/

{

   dim1 = (dim1/2)*2 + 1;
   dim2 = (dim2/2)*2 + 1;
   x = distances(dim1,dim2,dim1/2+1,dim2/2+1);
   kernel = exp(-0.5*(x/sigma)^2);
   return( kernel/sum(kernel) );
}

/* Function edge_suppress */

func edge_suppress( dim1, dim2, radius, lambda )
/* DOCUMENT suppress = edge_suppress( dim1, dim2, radius, lambda )

   Returns a double array dim1 x dim2 with values close to 1 when
   r < radius and approaching zero when r > radius. lambda determines
   the scale, the smaller the sharper the shift.

   2007-02-01/NJW
*/

{
   c1 = (dim1+1.0) / 2;
   c2 = (dim2+1.0) / 2;
   d = distances( dim1, dim2, c1, c2 );
   return 1.0 - sost(d, radius, lambda );
}

/* Function curmark1 */

func curmark1(void, style=, prompt=, nomark=, ps=, symsize= )
/* DOCUMENT pts = curmark1(style=, prompt=, nomark=, ps=, symsize= )
    or      curmark1, style=, prompt=, nomark=, ps=, symsize=

   Returns array with points marked with click of left mouse
   button.
   Keywords:
   'style' 0: simple click     returns (x,y)
           1: rubberband box   returns (xpres,ypres,xrelease,yrelease)
           2: rubber band line returns (xpres,ypres,xrelease,yrelease)
   'prompt': Prompt string (defaults to 'Expecting left mouse click: ...'
   'nomark': Set if point marking is to be avoided
   'ps':     Plot symbol for point mark
   'symsize': Symbol size for point mark

   When called as a subroutine the values will be printed on the screen.

   Right mouse button will return void ([]).

   SEE ALSO: curmark, mouse

*/

{
   require, "plot.i";

   local lx, ly;

   if( is_void(prompt) ) prompt = "Expecting left mouse click: ...";
   if( is_void(style) ) style = 0;
   if( is_void(ps) ) ps = 2;
   if( is_void(symsize) ) symsize = 1.;

   // Check for logarithmic scales
   mlogxy,lx,ly,get=1;

   res = mouse( -1, style, prompt );
   if( long(res(10)) != 1 ) return []; // Right mouse click
   if( lx ) res(1:3:2) = 10.^res(1:3:2);
   if( ly ) res(2:4:2) = 10.^res(2:4:2);
   if( style == 0 ) {
      if(!nomark) oplot,[res(1)],[res(2)],ps=ps,symsize=symsize;
      if( am_subroutine() ) {
         write,format="Result of curmark1: (x,y) = (%.3f,%.3f)\n", res(1), res(2);
      } else return res(1:2);
   } else {
      oplot,[res(1),res(3),res(3),res(1),res(1)], \
            [res(2),res(2),res(4),res(4),res(2)];
      if( am_subroutine() ) {
         write,format="Result of curmark1: (x1,y1) = (%.3f,%.3f)\n", res(1), res(2);
         write,format="                    (x2,y2) = (%.3f,%.3f)\n", res(3), res(4);
      } else return res(1:4);
   }
}

/* Function curmark */

func curmark( void, nomark=, ps=, symsize= )
/* DOCUMENT pts = curmark( nomark=, ps=, symsize= )
     or     curmark, nomark=, ps=, symsize=

   Returns array with points marked with click of left mouse
   button.
   Keywords:
   'nomark': Set if point marking is to be avoided
   'ps':     Plot symbol for point mark
   'symsize': Symbol size for point mark

   When called as a subroutine the values will be printed on the screen.

   SEE ALSO: curmark1, mouse

*/

{
   require, "plot.i";

   local lx, ly;

   if( is_void(ps) ) ps = 2;
   if( is_void(symsize) ) symsize = 1.;

   // Check for logarithmic scales
   mlogxy,lx,ly,get=1;

   pts = [];
   i = 0;
   while( 1 ) {
      res = mouse( -1, 0, "Expecting left mouse click (right to stop ) ..." );
      if( long(res(10)) != 1 ) return pts;
      if( lx ) res(1:3:2) = 10.^res(1:3:2);
      if( ly ) res(2:4:2) = 10.^res(2:4:2);
      if(!nomark) oplot,[res(1)],[res(2)],ps=ps,symsize=symsize;
      if( am_subroutine() ) {
         write,format="Position %3i: (x,y) = (%.3f,%.3f)\n", ++i, res(1), res(2);
      }
      grow, pts, res(1:2);
   }
}

/* Function peaksearch0 */

func peaksearch0( im, reg=, src_rad=, bkg_rad1=, bkg_rad2=, show= )
/* DOCUMENT  res = peaksearch0( im, reg=, src_rad=, bkg_rad1=, bkg_rad2=, show= )

    Returns highest pixel value, position, and total of the strongest peak
    in the image 'im' :
     [maximal value, xpos, ypos, summed peak - bkg, significance,
                                         src_rad,bkg_rad1,bkg_rad2].

    If the keyword 'reg' (for region) has been given then the search
    for a maximum is confined to im(reg).

    The keywords define the source radius (src_rad) and the
    background annulus between bkg_rad1 and bkg_rad2.
    Default values are  src_rad  =  3.0 pixels
                        bkg_rad1 =  4.0 pixels
                        bkg_rad2 = 10.0 pixels
    [The values are saved to externals _Src_rad, _Bkg_rad1, _Bkg_rad2
     so that they need not be supplied at the next call]

    Keyword 'show' will display the regions and results.

    It is assumed that the image contains no NAN values.
    A cleaning can be done with 'nan2zero' found in basic.i

    This version applies only a search for the maximum
    in the image.

    SEE ALSO: peaksearch1, peaksearch2

   2006-02-23/NJW

*/
{

   extern _Src_rad, _Bkg_rad1, _Bkg_rad2;

   local mxval, xc, yc, idx;

   sz = dimsof(im);

   // The search for a maximum

   if( is_void(reg) ) {
      // The global maximum
      maxim, im, mxval, xc, yc;
   } else {
      // the local maximum
      maxarr,im(reg),mxval,idx;
      idxx = indices(im,reg(idx(1)));
      xc = idxx(1);
      yc = idxx(2);
   }

   if( is_void(src_rad) ) {
      if( is_void(_Src_rad) ) {
         src_rad = 3.0;
         _Src_rad = 3.0;
      } else src_rad = _Src_rad;
   } else {
      _Src_rad = src_rad;
   }
   if( is_void(bkg_rad1) ) {
      if( is_void(_Bkg_rad1) ) {
         bkg_rad1 = 4.0;
         _Bkg_rad1 = 4.0;
      } else bkg_rad1 = _Bkg_rad1;
   } else {
      _Bkg_rad1 = bkg_rad1;
   }
   if( is_void(bkg_rad2) ) {
      if( is_void(_Bkg_rad2) ) {
         bkg_rad2 = 10.0;
         _Bkg_rad2 = 10.0;
      } else bkg_rad2 = _Bkg_rad2;
   } else {
      _Bkg_rad2 = bkg_rad2;
   }

   if( src_rad > bkg_rad1 ) {
      write,format="bkg_rad1 redefined to src_rad: %10.3f\n", src_rad;
      bkg_rad1 = src_rad;
   }
   if( bkg_rad1 > bkg_rad2 ) {
      write,format="bkg_rad2 redefined to 1.5*bkg_rad1: %10.3f\n", 1.5*bkg_rad1;
      bkg_rad2 = 1.5*bkg_rad1;
   }

   xarr = span(1,sz(2),sz(2))(,-:1:sz(3));
   yarr = span(1,sz(3),sz(3))(-:1:sz(2),);

   d = distances( sz(2), sz(3), xc, yc );
   ann = where( d > bkg_rad1 & d < bkg_rad2 );
   w = where( d < src_rad );
   x = xarr(w);
   y = yarr(w);
   z = im(w) - avg(im(ann));
   peakcts = sum(z);
   if( peakcts <= 0.0 ) {
      xpos = double(xc);
      ypos = double(yc);
   } else {
      xpos = sum(x*z)/peakcts;
      ypos = sum(y*z)/peakcts;
      if(abs(xpos-xc) > src_rad ) xpos = double(xc);
      if(abs(ypos-yc) > src_rad ) ypos = double(yc);
   }

   // iterate for better source position

   xc = xpos;
   yc = ypos;

   d = distances( sz(2), sz(3), xc, yc );
   ann = where( d > bkg_rad1 & d < bkg_rad2 );
   w = where( d < src_rad );
   x = xarr(w);
   y = yarr(w);
   z = im(w) - avg(im(ann));
   peakcts = sum(z);
   if( peakcts <= 0.0 ) {
      xpos = double(xc);
      ypos = double(yc);
   } else {
      xpos = sum(x*z)/peakcts;
      ypos = sum(y*z)/peakcts;
      if(abs(xpos-xc) > src_rad ) xpos = double(xc);
      if(abs(ypos-yc) > src_rad ) ypos = double(yc);
   }

   if( show ) {
      disp, im;
      circa = span(0,2*pi,100);
      circx = cos(circa);
      circy = sin(circa);
      oplot,xpos+src_rad*circx,ypos+src_rad*circy;
      oplot,xpos+bkg_rad1*circx,ypos+bkg_rad1*circy;
      oplot,xpos+bkg_rad2*circx,ypos+bkg_rad2*circy;
   }

   significance = signif(im,pos=long([xpos+0.5,ypos+0.5]));

   return [double(mxval),xpos,ypos,peakcts,significance, \
                       src_rad,bkg_rad1,bkg_rad2];
}

/* Function peaksearch1 */

func peaksearch1( im, src_rad=, bkg_rad1=, bkg_rad2= )
/* DOCUMENT  res = peaksearch1( im, src_rad=, bkg_rad1=, bkg_rad2= )

    Returns position and amplitude of the strongest peak
    in the image 'im'.

    The keywords define the source radius (src_rad) and the
    background annulus between bkg_rad1 and bkg_rad2.
    Default values are  src_rad  =  7.0 pixels
                        bkg_rad1 =  7.0 pixels
                        bkg_rad2 = 10.0 pixels

    It is assumed that the image contains no NAN values
    A cleaning can be done with 'nan2zero' found in basic.i

    This version applies only a search for the maximum
    in the image followed by an 'amoeba' gauss peak fitting.

   2006-02-23/NJW

*/
{
   require, "datafit.i";

   sz = dimsof(im);
   maxim, im, mxval, xc, yc;

   if( is_void(src_rad) ) src_rad = 7.0;
   if( is_void(bkg_rad1) ) bkg_rad1 = 7.0;
   if( is_void(bkg_rad2) ) bkg_rad2 = 10.0;

   if( src_rad > bkg_rad1 ) {
      write,format="bkg_rad1 redefined to src_rad: %10.3f\n", src_rad;
      bkg_rad1 = src_rad;
   }
   if( bkg_rad1 > bkg_rad2 ) {
      write,format="bkg_rad2 redefined to 1.5*bkg_rad1: %10.3f\n", 1.5*bkg_rad1;
      bkg_rad2 = 1.5*bkg_rad1;
   }

   d = distances( sz(2), sz(3), xc, yc );
   ann = where( d > bkg_rad1 & d < bkg_rad2 );
   w = where( d < src_rad );
   xarr = span(1,sz(2),sz(2))(,-:1:sz(3));
   yarr = span(1,sz(3),sz(3))(-:1:sz(2),);
   x = xarr(w);
   y = yarr(w);
   z = im(w);

   estimate = [mxval, xc, yc, 1.1, avg(im(ann))];
   parm = gaussfit2ds_uam( x , y, z, esti=estimate, nterm=5, chat=3);
   return parm;
}

/* Function peaksearch2 */

func peaksearch2( im )
/* DOCUMENT  res = peaksearch2( im )

    Returns position and amplitude of the strongest peak
    in the image 'im'.

    The keywords define the source radius (src_rad) and the
    background annulus between bkg_rad1 and bkg_rad2.
    Default values are  src_rad  =  7.0 pixels
                        bkg_rad1 =  7.0 pixels
                        bkg_rad2 = 10.0 pixels

    It is assumed that the image contains no NAN values
    A cleaning can be done with 'nan2zero' found in basic.i

    This version applies a Mexican hat wavelet
    in the image followed by a gauss peak fitting.

   2006-02-23/NJW

*/
{

   extern Mex_hat, Mex_fk511;

   if( is_void(Mex_hat) ) mexican_hat_ps2;
   // initializing wavelet

   sz = dimsof(im);

   print,"Convolving ...";
   fim = fconvol( im, Mex_fk511 );

   maxim, fim, mxval, xc, yc;

   d = distances( sz(2), sz(3), xc, yc );
   k = d < 7.0;
   l = d > 3.0;
   ann = where( k+l == 2 );
   w = where( d < 7.0 );
   xarr = span(1,sz(2),sz(2))(,-:1:sz(3));
   yarr = span(1,sz(3),sz(3))(-:1:sz(2),);
   x = xarr(w);
   y = yarr(w);
   z = fim(w);

   estimate = [mxval, xc, yc, 1.1, avg(im(ann))];
   parm = gaussfit2ds_uam( x , y, z, esti=estimate, nterm=5, chat=1, delta=0.03);
   return parm;
}

/* Function disp9 */

func disp9( image, off= )
/* DOCUMENT disp9, image, off=

   Display image with ds9. Works only on Uhuru
   Keyword 'off' will terminate the ds9 window
   2007-10-03/NJW
*/
{
   //+extern flag_for_ds9_window;
   require, "kfits.i";
   require, "mfits.i";

   //+if( flag_for_ds9_window && off ) {
   //+   system,"dsexit";
   //+   flag_for_ds9_window = 0;
   //+   return;
   //+}

   //+if( is_void(flag_for_ds9_window) ) {
   //+   system,"dsinit";
   //+   pause,10;
   //+   flag_for_ds9_window = 1;
   //+} else if( flag_for_ds9_window == 0 ) {
   //+   system,"dsinit";
   //+   pause,10;
   //+   flag_for_ds9_window = 1;
   //+}

   writefits,"tmp.fits", image, clobber=1;
   write,"File tmp.fits ready for display";
   //+system,"dsplay tmp.fits a";

}

/* Function image2events */

func image2events( image, crpix1, crval1, cdelt1, crpix2, crval2, cdelt2, crd= )
/* DOCUMENT xy = image2events( image, crpix1, crval1, cdelt1,
                               crpix2, crval2, cdelt2, crd= )

   returns double array(2,num_events)
   where x = xy(1,) and y = xy(2,) are randomized events from a count image.
   Using FITS and ds9 convention that integer image indices refer to pixel
   midpoints.
   Keyword:    crd    is the array returned by 'get_crd' and will
                      override arguments

   2008-04-07/NJW
*/
{
   dms = dimsof(image);
   if( dms(1) != 2 ) {
      write,"image2events only operates on 2D images";
      return [];
   }

   im = long(image + 0.5);
   nim = sum(im);
   if( nim < 1 ) {
      write,"image2events found no counts in the image";
      return [];
   }

   if( is_void(crpix1) ) { // assume default values
      crpix1 = crval1 = crpix2 = crval2 = 0.0;
      cdelt1 = cdelt2 = 1.0;
   }
   if( numberof(crd) == 6 ) {
      crpix1 = crd(1,1); crval1 = crd(2,1); cdelt1 = crd(3,1);
      crpix2 = crd(1,2); crval2 = crd(2,2); cdelt2 = crd(3,2);
   }

   naxis1 = dms(2);
   naxis2 = dms(3);
   xi = yi = [];
   for(j=1;j<=naxis2;j++) {
      for(i=1;i<=naxis1;i++) {
         n = im(i,j);
         if( n ) {
            grow, xi, array(i,n);
            grow, yi, array(j,n);
         }
      }
   }

   r = random(nim) - 0.5;
   p = random(nim) - 0.5;

   xy = array(double,2,nim);

   xy(1,) = (xi + r - crpix1)*cdelt1 + crval1;
   xy(2,) = (yi + p - crpix2)*cdelt2 + crval2;

   return xy;

}

/* Function rebin */

func rebin( arr, dim1, .. )
/* DOCUMENT res = rebin( arr, dim1, .. )

   Rebin a 1 or 2-D array into new dimensions that are either
   multiples of or into the original dimensions.

   No attention to keeping level or sum (counts).

   SEE ALSO: remap

   2008-01-10/NJW
*/
{
   arr = double(arr);
   dms = dimsof(arr);
   newdms = [1,dim1];
   while( more_args() ) {
      grow, newdms, next_arg();
      newdms(1)++;
   }
   if( dms(1) != newdms(1) ) error,"REBIN dimensionality mismatch";
   if( dms(1) > 2 ) error,"REBIN number of dimensions may not exceed 2";
   // check modularity
   ndims = numberof(dms)-1;
   mod = array(long, ndims);
   for( i = 1; i <= ndims; i++ ) {
      if( newdms(i+1) == dms(i+1) ) {
         mod(i) = 1;
      } else if( newdms(i+1) < dms(i+1) ) {
         r = dms(i+1) / newdms(i+1);
         if( r*newdms(i+1) != dms(i+1) ) error,"REBIN requires integer fractions";
         mod(i) = -r;
      } else {
         r = newdms(i+1) / dms(i+1);
         if( r*dms(i+1) != newdms(i+1) ) error,"REBIN requires integer fractions";
         mod(i) =  r;
      }
   }

   // Do rebinning dimension by dimension

   xarr = array(double, newdms );
   for( i = 1; i <= newdms(2); i++ ) {
      if( mod(1) == 1 ) {
         io = i;
      } else if( mod(1) < 0 ) {
         io = indgen(-mod(1)) - (i-1)*mod(1);
      } else {
         io = (i-1)/mod(1) + 1;
      }
      if( ndims == 2 ) {
         for( j = 1; j <= newdms(3); j++ ) {
            if( mod(2) == 1 ) {
               jo = j;
            } else if( mod(2) < 0 ) {
               jo = indgen(-mod(2)) - (j-1)*mod(2);
            } else {
               jo = (j-1)/mod(2) + 1;
            }
            xarr(i,j) = sum(arr(io,jo));
         }
      } else {
         xarr(i) = sum(arr(io));
      }
   }

   return xarr;

}

/* Function remap */

func remap( arr, dim1, .. )
/* DOCUMENT res = remap( arr, dim1, .. )

   Remap a 1 or 2-D array into new dimensions of unrestricted
   values. Lowering the dimensionality may lead to an inaccurate
   result since the original array is sampled rather than
   average. (There is room for improvements).

   SEE ALSO: rebin

   2008-01-10/NJW
*/
{
   arr = double(arr);
   dms = dimsof(arr);
   newdms = [1,dim1];
   while( more_args() ) {
      grow, newdms, next_arg();
      newdms(1)++;
   }
   if( dms(1) != newdms(1) ) error,"REMAP dimensionality mismatch";
   if( dms(1) > 2 ) error,"REMAP number of dimensions may not exceed 2";
   delta = 1.0 / dms(2);
   //+ xiarr = delta/2 + (indgen(dms(2))-1)*delta;
   ndelta = 1.0 / newdms(2);
   nxiarr = ndelta/2 + (indgen(newdms(2))-1)*ndelta;
   oldi = long(nxiarr/delta) + 1;
   if( dms(1) > 1 ) {
      felta = 1.0 / dms(3);
      //+ yiarr = felta/2 + (indgen(dms(3))-1)*felta;
      nfelta = 1.0 / newdms(3);
      nyiarr = nfelta/2 + (indgen(newdms(3))-1)*nfelta;
      oldj = long(nyiarr/felta) + 1;
   }

   xarr = array( double, newdms );
   for( i = 1; i <= newdms(2); i++ ) {
      if( dms(1) > 1 ) {
         for( j = 1; j <= newdms(3); j++ ) {
            xarr(i,j) = arr(oldi(i),oldj(j));
         }
      } else {
         xarr(i) = arr(oldi(i));
      }
   }

   return xarr;

}

/* Function unwiden_image */

func unwiden_image( im, w )
/* DOCUMENT new_image = unwiden_image( im, w )

   Returns an image where the edge of width 'w' has been removed.

*/
{
   return im(1+w:-w,1+w:-w);
}

/* Function widen_image */

func widen_image( im, w, val= )
/* DOCUMENT new_image = widen_image( im, w, val= )

   Returns an image that has been enlarged by 'w' (int)
   in all directions and values have been filled out
   with the edge values of the original image ('im').
   The datatype is unchanged.

   If keyword 'val' is set then the filling will be with this.

   2009-11-04/NJW

*/
{
   dms = dimsof(im);
   v = !is_void(val);
   // create new image
   wim = array(structof(im),dms(2)+2*w,dms(3)+2*w);
   // --- fill out central part
   wim(w+1:w+dms(2),w+1:w+dms(3)) = im;
   // --- fill out left side
   if( v ) wim(1:w,w+1:w+dms(3)) = val;
   else wim(1:w,w+1:w+dms(3)) = im(1,)(-:1:w,);
   // --- fill out right side
   if(v)wim(w+dms(2)+1:0,w+1:w+dms(3)) = val;
   else wim(w+dms(2)+1:0,w+1:w+dms(3)) = im(0,)(-:1:w,);
   // --- fill out lower side
   if(v)wim(w+1:w+dms(2),1:w) = val;
   else wim(w+1:w+dms(2),1:w) = im(,1)(,-:1:w);
   // --- fill out upper side
   if(v)wim(w+1:w+dms(2),w+1+dms(3):0) = val;
   else wim(w+1:w+dms(2),w+1+dms(3):0) = im(,0)(,-:1:w);
   // --- fill out lower left corner
   if(v)wim(1:w,1:w) = val;
   else wim(1:w,1:w) = im(1,1);
   // --- fill out lower right corner
   if(v)wim(dms(2)+w+1:0,1:w) = val;
   else wim(dms(2)+w+1:0,1:w) = im(0,1);
   // --- fill out upper left corner
   if(v)wim(1:w,dms(3)+w+1:0) = val;
   else wim(1:w,dms(3)+w+1:0) = im(1,0);
   // --- fill out upper right corner
   if(v)wim(dms(2)+w+1:0,dms(3)+w+1:0) = val;
   else wim(dms(2)+w+1:0,dms(3)+w+1:0) = im(0,0);

   return wim;
}

/* Function getimval */

func getimval( im )
/* DOCUMENT image_value = getimval( im )
     or     getimval, im

   Retrieve a pixel value from an image previously displayed
   by function 'disp'.

   When called as a subroutine the indices and value will be
   printed on the screen.

   SEE ALSO: disp, curmark1, getimvals

   2010-08-06/NJW
*/
{
   pos = curmark1(prompt="Mark the pixel ... ",nomark=1);
   i = long(floor(pos(1)+0.5));
   j = long(floor(pos(2)+0.5));
   value = im(i,j);

   if( am_subroutine() ) {
      stim = structof(im);
      if( stim == long || stim == int || stim == char ) {
         write,format="(%i,%i) has value %i\n", i, j, value;
      } else if( stim == double || stim == float ) {
         if( abs(value) < 1.e-3 || abs(value) > 1.e3 ) {
            write,format="(%i,%i) has value %.5e\n", i, j, value;
         } else {
            write,format="(%i,%i) has value %.5f\n", i, j, value;
         }
      } else error,"Data type not supported";
   }

   return value;

}

/* Function getimvals */

func getimvals( im )
/* DOCUMENT image_values = getimvals( im )
     or     getimvals, im

   Retrieve several pixel values from an image previously displayed
   by function 'disp'.

   When called as a subroutine the indices and values will be
   printed on the screen.

   SEE ALSO: disp, curmark, getimval

   2010-08-06/NJW
*/
{
   vals = [];
   do {
      pos = curmark1(prompt="Mark the pixel (or right click to stop) ... ",nomark=1);
      if( is_void(pos) ) break;

      i = long(floor(pos(1)+0.5));
      j = long(floor(pos(2)+0.5));
      value = im(i,j);
      grow, vals, value;

      if( am_subroutine() ) {
         stim = structof(im);
         if( stim == long || stim == int || stim == char ) {
            write,format="(%i,%i) has value %i\n", i, j, value;
         } else if( stim == double || stim == float ) {
            if( abs(value) < 1.e-3 || abs(value) > 1.e3 ) {
               write,format="(%i,%i) has value %.5e\n", i, j, value;
            } else {
               write,format="(%i,%i) has value %.5f\n", i, j, value;
            }
         } else error,"Data type not supported";
      }

   } while( 1 );

   return vals;

}

/* Function imcut */

func imcut( im, lofac, hifac, pane= )
/* DOCUMENT rescaled_im = imcut( im, lofac, hifac, pane= )

   The highest and lowest image values are changed according
   to the following algorithm:

   A histogram of image values is produced and the peak is found
   with value vpeak.

   Moving upwards the value is found where the
   histogram has fallen to 40% of the peak, called v40p.
   All image pixels where the value exceeds vpeak + hifac*(v40p - vpeak)
   is set to this value.

   Moving downwards the value is found where the
   histogram has fallen to 40% of the peak, called v40m.
   All image pixels where the value undershoots vpeak - lofac*(vpeak - v40m)
   is set to this value.

   In many case lofac = 2 and hifac = 4 gives good results.

   2010-09-08/NJW

*/
{
   local h, x;

  /*
   *   Make histogram to decide where a sensible cut should be made
   */

   imw = double(im);
   imx = max(imw);
   imn = min(imw);
   bsize = (imx-imn)/200;
   histos, imw, h, x, binsize=bsize;
   if( !is_void(pane) ) {
      window,pane;
      plot,x,h,ps=10;
   }
   hmax = max(h);
   imax = where(hmax == h)(1);
   nh = numberof(h);
   if( imax == 1 || imax == nh ) {
      write,"IMCUT: image is not suited for this function";
      return imw;
   }
   if( hmax > 1.1 * max(h(imax-1), h(imax+1)) ) {
      hmax = h(imax) = 1.1 * max(h(imax-1), h(imax+1));
   }

   // find lower half

   for( i = imax; i > 0; i-- ) {
      if( h(i) < 0.4*hmax ) break;
   }

   // find upper half

   for( j = imax; j <= nh; j++ ) {
      if( h(j) < 0.4*hmax ) break;
   }

   if( j - i == 2 ) { // There must be one value that dominates
                      // Discard and set new value
      hmax = 1.1*max(h(i),h(j));
      if( !is_void(pane) ) {
         pause,1000;
         h(imax) = hmax;
         plot,x,h,ps=10;
      }

      // find lower half

      for( i = imax; i > 0; i-- ) {
         if( h(i) < 0.4*hmax ) break;
      }

      // find upper half

      for( j = imax; j <= nh; j++ ) {
         if( h(j) < 0.4*hmax ) break;
      }
   }

   dxhi = x(j) - x(imax);
   dxlo = x(imax) - x(i);

   // lower limit

   llim = x(imax) - lofac*dxlo;
   loreg = where( imw < llim );
   if( numberof(loreg) ) imw(loreg) = llim;

   // upper limit

   ulim = x(imax) + hifac*dxhi;
   hireg = where( imw > ulim );
   if( numberof(hireg) ) imw(hireg) = ulim;

   if( !is_void(pane) ) {
      oplot,x(i)*[1,1],[0,hmax],li=2;
      oplot,x(j)*[1,1],[0,hmax],li=2;
      oplot,llim*[1,1],[0,hmax];
      oplot,ulim*[1,1],[0,hmax];
   }

   return imw;

}

/* Function erase_source */

func erase_source( im, res )
/* DOCUMENT new_im = erase_source(im, res)

   Returns an image where the source region defined
   by 'peaksearch0' has been replaced by random
   values from the background annulus.

   res:

  [highest value, xpos, ypos, summed peak - bkg,significance,
                              src_rad,bkg_rad1,bkg_rad2].

   2010-09-20/NJW
*/
{
   dms = dimsof( im );
   d = distances(dms(2),dms(3),res(2),res(3));
   wsrc = where(d < res(6));
   wbkg = where(d > res(7) & d < res(8) );
   nsrc = numberof(wsrc);
   nbkg = numberof(wbkg);
   w = sort(random(nbkg))(1:nsrc);
   imr = im;
   imr(wsrc) = im(wbkg(w));

   return imr;
}

/* Function gflatfield */

func gflatfield( im, sigma, &gim, sel= )
/* DOCUMENT new_im = gflatfield( im, sigma[, >gim], sel= )

   The image 'im' is folded with a gaussian kernel
   with sigma = 'sigma' and then subtracted from the
   original image. The process is repeated with
   excluded source areas.
   Keyword 'sel' must be an array of same dimension
   as 'im' with 1 where pixels are useful and zero
   elsewhere.

   2007-06-19/NJW

*/
{
   require, "fconvol.i";

   di = dimsof(im);
   if( di(1) != 2 ) {
      write,"Not a 2D image";
      return [];
   }
   dosel = 0;
   if( !is_void(sel) ) {
      d = dimsof(sel);
      if( d(1) != 2 ) {
         write,"'sel' is not a 2D image";
         return [];
      }
      if( d(2) != di(2) || d(3) != di(3) ) {
         write,"'sel' is not commensurate with 'im'";
         return [];
      }
      dosel = 1;
   }
   wsel = dosel ? where( sel ) : indgen(di(2)*di(3));
   //   Avoid changing the input image
   im1 = im;
   gim = gfconvol( im, sigma );
   //    First subtraction
   diff  = im - gim;
   //    Substitute image parts that exceed 3sigma
   //    to avoid subtracting too much around sources
   rms_1 = wrms( diff(wsel) );
   q = where( abs(diff) > 3*rms_1 );
   if( numberof(q) > 0 ) {
      im1(q) = gim(q);
      gim = gfconvol( im1, sigma );
      diff = im - gim;
   }

   return diff;
}

/* Function fflatfield */

func fflatfield( im, freq, &ffim, sel= )
/* DOCUMENT new_im = fflatfield( im, freq[, >ffim], sel= )

   The image 'im' is Fourier transformed and
   frequencies above 'freq' are removed.
   'freq' is an integer or a two-element vector of
   integers where each is smaller than half of the
   corresponding dimension.
   The flattened image is then subtracted from the
   original image.
   Keyword 'sel' must be an array of same dimension
   as 'im' with 1 where pixels are useful and zero
   elsewhere.

   2010-09-20/NJW

*/
{
   dms = dimsof(im);
   o1 = dms(2)%2;
   o2 = dms(3)%2;
   if( dms(1) != 2 ) {
      write,"Not a 2D image";
      return [];
   }
   dosel = 0;
   if( !is_void(sel) ) {
      d = dimsof(sel);
      if( d(1) != 2 ) {
         write,"'sel' is not a 2D image";
         return [];
      }
      if( d(2) != dms(2) || d(3) != dms(3) ) {
         write,"'sel' is not commensurate with 'im'";
         return [];
      }
      dosel = 1;
   }
   wsel = dosel ? where( sel ) : indgen(dms(2)*dms(3));
   //   Avoid changing the input image
   freq1 = numberof(freq) > 1 ? freq(1) : freq;
   freq2 = numberof(freq) > 1 ? freq(2) : freq;
   im1 = im;
   fim = fft(im,-1);
   /*
    *   The higher frequencies are removed symmetrically
    *   so that the backwards transformation has zero
    *   imaginary part except for rounding-off errors.
    */
   i1 = 1 + freq1;
   i2 = dms(2) + 1 - freq1;
   j1 = 1 + freq2;
   j2 = dms(3) + 1 - freq2;
   fim(i1:i2,j1:j2) = 0.0;
   ffim = fft(fim,1).re/numberof(im);

   //    Subtraction
   diff  = im - ffim;
   //    Substitute image parts that exceed 3sigma
   //    to avoid subtracting too much around sources
   //+ rms_1 = wrms( diff(wsel) );
   //+ q = where( abs(diff) > 3*rms_1 );
   //+ if( numberof(q) > 0 ) {
   //+    im1(q) = gim(q);
   //+    gim = gfconvol( im1, sigma );
   //+    diff = im - gim;
   //+ }

   return diff;
}

/* Function signif */

func signif( im, pos=, src_rad=, bkg_rad1=, bkg_rad2= )
/* DOCUMENT significance = signif( im, pos=, src_rad=, bkg_rad1=, bkg_rad2= )

   Returns the significance defined as

     (im - avg(bkg))/rms(bkg)

   Keywords:    pos          a set of (i,j)
                src_rad      defaults to  3.0 pixels
                bkg_rad1     defaults to  4.0 pixels
                bkg_rad2     defaults to 10.0 pixels
    [The values are saved to externals _Src_rad, _Bkg_rad1, _Bkg_rad2
     so that they need not be supplied in the following call]

   If 'pos' is set as a two-element vector then a single value is
   returned, else the entire significance map is returned.
*/
{
   extern _Src_rad, _Bkg_rad1, _Bkg_rad2;

   dms = dimsof(im);
   im = double(im);

   if( is_void(src_rad) ) {
      if( is_void(_Src_rad) ) {
         src_rad = 3.0;
         _Src_rad = 3.0;
      } else src_rad = _Src_rad;
   } else {
      _Src_rad = src_rad;
   }
   if( is_void(bkg_rad1) ) {
      if( is_void(_Bkg_rad1) ) {
         bkg_rad1 = 4.0;
         _Bkg_rad1 = 4.0;
      } else bkg_rad1 = _Bkg_rad1;
   } else {
      _Bkg_rad1 = bkg_rad1;
   }
   if( is_void(bkg_rad2) ) {
      if( is_void(_Bkg_rad2) ) {
         bkg_rad2 = 10.0;
         _Bkg_rad2 = 10.0;
      } else bkg_rad2 = _Bkg_rad2;
   } else {
      _Bkg_rad2 = bkg_rad2;
   }

   if( numberof(pos) == 2 ) {
      d = distances(dms(2),dms(3),pos(1),pos(2));
      bkg_area = where( d >= bkg_rad1 & d < bkg_rad2 & im != 0.0 );
      if( !numberof(bkg_area) ) {
         sigim = 0.0;
      } else {
         g_bkg_avg = wavg(im(bkg_area));
         g_bkg_rms = wrms(im(bkg_area));
         sigim = (im(pos(1),pos(2)) - g_bkg_avg)/g_bkg_rms;
      }
      return sigim;
   } else {
      sigim = im;
      for( i = 1; i <= dms(2); i++ ) {
      for( j = 1; j <= dms(3); j++ ) {
         d = distances(dms(2),dms(3),i,j);
         bkg_area = where( d >= bkg_rad1 & d < bkg_rad2 & im != 0.0 );
         if( !numberof(bkg_area) ) {
            sigim(i,j) = 0.0;
         } else {
            g_bkg_avg = wavg(im(bkg_area));
            g_bkg_rms = wrms(im(bkg_area));
            sigim(i,j) = (im(i,j) - g_bkg_avg)/g_bkg_rms;
         }
      }}
      return sigim;
   }
}

/* Function cur_extract_box */

func cur_extract_box( im, over=, color=, thick= )
/* DOCUMENT box = cur_extract_box( im, over=, color=, thick= )

   Saves the part of image 'im' (previously displayed, or at least an image
   with identical or smaller dimensions) outlined by the use of the cursor.

   Keywords
     over       Causes overplotting the image with the extracted box outline
     color      Specifies overplotting color
     thick      Specifies overplotting line thickness

   2012-05-02/NJW
*/
{
   outline = curmark1(prompt="Click and draw to other corner ... ",style=2);
   x1 = long(outline(1)+0.5);
   y1 = long(outline(2)+0.5);
   x2 = long(outline(3)+0.5);
   y2 = long(outline(4)+0.5);
   if( x1 > x2 ) { x = x1; x1 = x2; x2 = x; }
   if( y1 > y2 ) { y = y1; y1 = y2; y2 = y; }

   if( over ) oplot,[x1,x2,x2,x1,x1],[y1,y1,y2,y2,y1],color=color,thick=thick;

   return im(x1:x2,y1:y2);
}

/* Function imhcut */

func imhcut( im, locut, hicut )
/* DOCUMENT cut_im = imhcut( im, locut, hicut )

    Return an image with the values cut.

    Giving an argument as void means no action.
*/
{
   res = im;

   if( !is_void(locut) ) {
      w = where( im < locut );
      if( numberof(w) ) {
         res(w) = locut;
      } else res(1,1) = locut;       
   }

   if( !is_void(hicut) ) {
      w = where( im > hicut );
      if( numberof(w) ) {
         res(w) = hicut;
      } else res(2,1) = hicut;       
   }

   return res;
}

/* Function imcolorbar */

func imcolorbar( im )
/* DOCUMENT imcolorbar, im

    Uses 'colorbar' to draw a colorbar to the right of the image
    with max and min from the image 'im'.

    2013-01-09/NJW
*/
{
   vx = max(im);
   vn = min(im);
   avn = abs(vn);
   avx = abs(vx);
   vn = ndeci(vn,2 - long(floor(log10(avn))));
   vx = ndeci(vx,2 - long(floor(log10(avx))));
   colorbar, vn, vx;
}
%FILE% image_src_cts.i
func image_src_cts( image, p_src=, r_src=, r_bi=, r_bo= )
/* DOCUMENT image_src_cts, image, p_src=, r_src=, r_bi=, r_bo=
            n_sigma = image_src_cts( image, p_src=, r_src=, r_bi=, r_bo= )

   Called as a function: Returns the detection significance measured as
        a number of sigmas:  N_s/sqrt(4 + N_b), no plot produced.

   Called as a subroutine: Shows a plot with indicated zones and
        prints results on the screen.

   In both cases values not given as keywords are asked for by cursor
   pointing (marking).

   2010-05-18/NJW
*/
{
   u = am_subroutine();
   q = anyof([is_void(p_src),is_void(r_src),is_void(r_bi),is_void(r_bo)]);
   v = u | q;

   angles = span(0,2*pi,100);
   dms = dimsof(image);
   if(v) disp, image;
   // Mark the alleged source
   if( is_void(p_src) ) {
      write,"Mark the source center ...";
      p_src = curmark1();
      write,format="Source at (%.3f,%.3f)\n",p_src(1),p_src(2);
   }
   r = distances( dms(2), dms(3), p_src(1), p_src(2) );

   if( is_void(r_src) ) {
      write,"Mark the source region ...";
      rr = curmark1();
      r_src = sqrt((p_src(1)-rr(1))^2 + (p_src(2)-rr(2))^2);
      write,format="Source radius = %.3f\n", r_src;
   }
   // show the source circle
   if(v) oplot,p_src(1)+r_src*cos(angles),p_src(2)+r_src*sin(angles),color="white";
   ws = where( r < r_src );
   ns_pix = numberof(ws);
   if( ns_pix == 0 ) error,"No source pixels";
   nstot = sum(image(ws));
   if(v) write,format="%i source pixels with %i counts\n", ns_pix, nstot;

   if( is_void(r_bi) ) {
      write,"Mark the inner background region ...";
      rbi = curmark1();
      r_bi = sqrt((p_src(1)-rbi(1))^2 + (p_src(2)-rbi(2))^2);
      write,format="Inner background radius = %.3f\n", r_bi;
   }
   // show the inner background circle
   if(v) oplot,p_src(1)+r_bi*cos(angles),p_src(2)+r_bi*sin(angles),color="white";

   if( is_void(r_bo) ) {
      write,"Mark the outer background region ...";
      rbo = curmark1();
      r_bo = sqrt((p_src(1)-rbo(1))^2 + (p_src(2)-rbo(2))^2);
      write,format="Outer background radius = %.3f\n", r_bo;
   }
   // show the outer background circle
   if(v) oplot,p_src(1)+r_bo*cos(angles),p_src(2)+r_bo*sin(angles),color="white";

   wb = where( r > r_bi & r < r_bo );
   nb_pix = numberof(wb);
   if( nb_pix == 0 ) error,"No background pixels";
   if(v) write,format="%i background pixels with %i counts\n", nb_pix, sum(image(wb));
   bkg_per_pix = sum(1.*image(wb))/nb_pix;
   nb = ns_pix * bkg_per_pix;
   if(v) write,format="%.3f bkg cts per pixel and %.2f bkg counts in source area\n", \
              bkg_per_pix, nb;
   ns = nstot - nb;
   if(v) write,format="%.2f net source counts\n", ns;
   if(v) write,format="A %.2f sigma detection\n", ns/sqrt(4+nb);

   if( !u ) return ns/sqrt(4+nb);

}
%FILE% iniparest2d_u.i
/* Function iniparest2d_u */

func iniparest2d_u( x, y, z, parlo, parhi, ntrials )
/* DOCUMENT parm = iniparest2d_u( x, y, z, parlo, parhi, ntrials )

   Unconstrained parameter estimate 

   2006-02-23/NJW
*/
{
   extern xval, yval, zval, n_points;

   xval = x;
   yval = y;
   zval = z;

   nterm = numberof(parlo);
   smin = funk(parlo);
   parmin = parlo;
   for( i = 1; i <= ntrials; ++i ) {
      r = random(nterm);
      parm = parlo + r*(parhi-parlo);
      s = funk(parm);
      if( s < smin ) {
         smin = s;
         parmin = parm;
      }
   }
   print,"INIPAREST2D_U best value: ", smin;
   return parmin;
}
%FILE% insert_plolo.i
/* Function insert_plolo */

func insert_plolo( x, y, &new_x, rlimx=, rlimy= )
/* DOCUMENT new_y = insert_plolo( x, y, >new_x, rlimx=, rlimy= )

    Add extra points - logarithmically interpolated - to table x,y
    so that the relative difference of y never exceeds 'rlimy'.
    rlimy defaults to 1.5.

    Since this function is aimed at curves where edges might be
    present a condition can be set on the corresponding relative
    difference of x, namely keyword 'rlimx'.

*/
{
   n = numberof(x);
   if( numberof(y) != n ) error,"Mismatching array sizes";
   if( is_void(rlimy) ) rlimy= 1.5;
   if( is_void(rlimx) ) rlimx= 1.0;

   new_y = y;
   new_x = x;

   for( i = 2; i <= n; i++ ) {
      rx = reldif(new_x(i-1),new_x(i));
      ry = reldif(new_y(i-1),new_y(i));
      if( ry > rlimy && rx > rlimx ) {
         write,"Here is a case:";
         write,"X  ",i,new_x(i-1),new_x(i);
         write,"Y  ",i,new_y(i-1),new_y(i);
         n_extra = long(log(ry)/log(rlimy));
         write,"Suggests "+itoa(n_extra)+" extra points";
         x_extra = spanl(new_x(i-1),new_x(i),n_extra+2);
         y_extra = exp(interp(log(new_y(i-1:i)),log(new_x(i-1:i)),log(x_extra)));
         x_extra = x_extra(2:-1);
         y_extra = y_extra(2:-1);
         new_x = grow( new_x(1:i-1), x_extra, new_x(i:0));
         new_y = grow( new_y(1:i-1), y_extra, new_y(i:0));
         n += n_extra;
         i += n_extra;
      }
   }
   return new_y;
}
%FILE% integrals.i
/*
    2d integration of function funxy
     funxy(x,y)

*/

func integr_funxy( ax, bx, ay, by, epsilon= )
{
   extern Y;

   if( is_void(epsilon) ) epsilon = 1.e-6;

   nsteps = 10;
   sumf_prev = 1.e50;
   sumf = [];

   do {
      if( !is_void(sumf) ) sumf_prev = sumf;
      write,"nsteps = "+itoa(nsteps);
      ybds = span(ay, by, nsteps);
      y = ybds(zcen);
      dy = ybds(dif);
      ny = numberof(y);
      sumf = 0.0;
      for( i = 1; i <= ny; i++ ) {
         Y = y(i);
         rint = romberg(funx, ax, bx, epsilon, notvector=1 );
         sumf += rint*dy(i);
      }
      nsteps += 10;
   } while( abs(sumf - sumf_prev) > epsilon );

   return sumf;

}

func funx( x )
{
   extern Y;
   return funxy(x,Y);
}

/*
 *   'funxy' below is just a sample for illustration
 */

func funxy( x, y )
{
   z = 1. - sqrt(x^2 + y^2)/11.25;
   return z < 0. ? 0.0 : z;
}
%FILE% irse_package.i

             irse_setup.i

/*************************************************
;
;  Image reconstruction statistical
;  experiment IRSE
;
;  Setup of mask pattern and sizes
;
;   2005-03-21/NJW
;   2005-04-06/NJW updated to use image size N+M-1
;                  and 'fkernel' as mask plus 'fconvol'
;
*********************************************************/

#include "image.i"
#include "string.i"
#include "idlx.i"
#include "plot.i"
#include "fconvol.i"
#include "irse_run.i"

/*   Pattern definition: */

cap_n = 53; // Size of mask
cap_m = 27; // Size of detector (acts a kernel for convolution)
//* cap_nn = cap_n + 2*(cap_m - 1) ; inflated mask
cap_r = cap_n + (cap_m-1); // Size of resulting image
spread = 0.4 * cap_r;

p = random(cap_n,cap_n);
w = where(p > 0.75);
nw = numberof(w);
print,nw," open holes";
m = array(0.,cap_n,cap_n);
m(w) = 1.0;
// reverse directions
mk = m;
idx = cap_n + 1 - indgen(cap_n);
mk = mk(,idx);
mk = mk(idx,);
// antimask:
am = 1.0 - mk;
fmask = fkernel(mk, cap_r, cap_r);
famask = fkernel(am, cap_r, cap_r);

open_frac = sum(m)/sum(m+am);
print,"Open fraction: ", open_frac;

             irse_analysis.i

#include "idlx.i"
#include "scom.i"
#include "plot.i"
#include "gaussfit_am.i"

func irse_analysis( num )
{
   list = read_slist("irse_v2_files.scm");
   nlist = numberof(list);
   // for(i=3;i<=3;i++) {
   if( num <= 3 || num > nlist ) {
      print,"outside range";
      return;
   }
   i = num;
      list(i) = strpart(list(i),11:36);
      n_cases = comget( list(i), "n_cases",fix=1);
      if( n_cases > 1000 ) {
         d = rscol(list(i),1);
         f = long(rscol(list(i),2));
         wf = where( f == 1 );
         wnf = where( f == 0 );
         histos, d, h, x, binsize=0.05;
         plot,x,h,ps=10,color="blue",title=list(i),xtitle="DETSIG value";
         if( numberof(wf) > 0 ) {
            histos, d(wf), hf, xf, binsize=0.05;
            oplot,xf,hf,ps=10,color="green";
         }
         if( numberof(wnf) > 0 ) {
            histos, d(wnf), hnf, xnf, binsize=0.05;
            oplot,xnf,hnf,ps=10,color="red";
         }
        /* do the fitting */
         w = where(hnf > 0.7*max(hnf));
         res = gaussfit_am( xnf(w), hnf(w) );
         yfit = res(1)*exp(-0.5*((xnf(w)-res(3))/res(2))^2);
         oplot,xnf(w),yfit;
      } else {
         print,"too few cases";
         return;
      }
   // }
}

             irse_batch.i

r = irse_run(300,n_c=20000,n_bkg=0.5);
r = irse_run(300,n_c=20000,n_bkg=1.0);
r = irse_run(300,n_c=20000,n_bkg=1.5);
r = irse_run(300,n_c=20000,n_bkg=2.0);
r = irse_run(300,n_c=20000,n_bkg=3.0);
r = irse_run(300,n_c=20000,n_bkg=4.0);
print,"IRSE batch, done 6 of 30";
r = irse_run(450,n_c=20000,n_bkg=0.5);
r = irse_run(450,n_c=20000,n_bkg=1.0);
r = irse_run(450,n_c=20000,n_bkg=1.5);
r = irse_run(450,n_c=20000,n_bkg=2.0);
r = irse_run(450,n_c=20000,n_bkg=3.0);
r = irse_run(450,n_c=20000,n_bkg=4.0);
print,"IRSE batch, done 12 of 30";
r = irse_run(500,n_c=20000,n_bkg=0.5);
r = irse_run(500,n_c=20000,n_bkg=1.0);
r = irse_run(500,n_c=20000,n_bkg=1.5);
r = irse_run(500,n_c=20000,n_bkg=2.0);
r = irse_run(500,n_c=20000,n_bkg=3.0);
r = irse_run(500,n_c=20000,n_bkg=4.0);
print,"IRSE batch, done 18 of 30";
r = irse_run(600,n_c=20000,n_bkg=0.5);
r = irse_run(600,n_c=20000,n_bkg=1.0);
r = irse_run(600,n_c=20000,n_bkg=1.5);
r = irse_run(600,n_c=20000,n_bkg=2.0);
r = irse_run(600,n_c=20000,n_bkg=3.0);
r = irse_run(600,n_c=20000,n_bkg=4.0);
print,"IRSE batch, done 24 of 30";
r = irse_run(800,n_c=20000,n_bkg=0.5);
r = irse_run(800,n_c=20000,n_bkg=1.0);
r = irse_run(800,n_c=20000,n_bkg=1.5);
r = irse_run(800,n_c=20000,n_bkg=2.0);
r = irse_run(800,n_c=20000,n_bkg=3.0);
r = irse_run(800,n_c=20000,n_bkg=4.0);
print,"IRSE batch, done 30 of 30";
print,"IRSE batch finished!";

             irse_case.i

/******************************************************

     IRSE project
;
;
******************************************************/

// Define the source counts - randomly distributed

   n_bkg = 1.0;

   num_src_counts = 1000;
   num_bkg_counts = long(n_bkg*cap_m*cap_m);

   spread = 0.4*(cap_n + cap_n -1);
   src_pos = long( random(2)*spread - 0.5*spread + 0.5);

   src = shift(m,src_pos(1),src_pos(2))*1.0;

   print,"Input source position: ", src_pos;
   print,"Expected source position: ", (cap_n+cap_m+2)/2 - src_pos;

   i1 = (cap_n - cap_m)/2;
   i2 = i1 + cap_m - 1;
   src = src(i1:i2,i1:i2);
   w = where( src > 0.5 );
   nw = numberof(w);
   if( nw == 0 ) print,"Ups 1";
   r = random(num_src_counts)*nw;
   src = src*0.0;
   for(i = 1;i<=num_src_counts;i++) {
      src(w(long(r(i)+1.0)))++;
   }

   // detector definition

   d_bkg = array(double,cap_m,cap_m);
   n_d = cap_m * cap_m;
   r = random(num_bkg_counts) * n_d;
   for(i=1;i<=num_bkg_counts;i++) {
      d_bkg(long(r(i)+1.0))++;
   }

   d = d_bkg + src;
   d(long(0.7*cap_m),*) = 0.0; // "Dead anode"
   d(long(0.2*cap_m),*) = 0.0; // "Dead anode"
   dd = array(double,cap_r,cap_r);
   i1 = (cap_n + 1) / 2;
   i2 = i1 + cap_m - 1;
   dd(i1:i2,i1:i2) = d;

   cplus = fconvol(dd,fmask);
   cminus = fconvol(dd,famask);

   c = (1 - open_frac)*cplus - open_frac * cminus;

   //-------------------------------------------

   maxim, c, xval, xc, yc;

   box_hl = 4;
   im_dim = cap_n + cap_m - 1;
   if(xc - box_hl < 1 || xc + box_hl > im_dim || \
      yc - box_hl < 1 || yc + box_hl > im_dim) {
      print,"Peak at ", xc, yc, " is outside region - skip";
   } else {

      box = c(xc-box_hl:xc+box_hl,yc-box_hl:yc+box_hl);
      box(box_hl,box_hl) = 0.;

      rootmsq = wrms(box);

      detsig = xval / rootmsq;

      print, "DETSIG = ", detsig;
      print, "Output source position: ", xc, yc;
   }


             irse_file_update.i

#include "idlx.i"
#include "scom.i"
func irse_file_update
{
   list = read_slist("irse_v2_files.scm");
   nlist = numberof(list);
   for(i=1;i<=nlist;i++) {
      list(i) = strpart(list(i),11:36);
      print,list(i);
      text = read_slist( list(i) );
      ntext = numberof(text);
      for( j = 1; j < ntext; j++ ) {
         if( strpart(text(j),1:3) == " //" ) {
            text(j) = strpart(text(j),2:999);
         }
      }
      write_slist, list(i), text;
   }
}

             irse_run.i

/******************************************************

     IRSE project
;
;
******************************************************/

// Define the source counts - randomly distributed

func irse_run(n_src_cts, n_c=, n_bkg= ) {
/* DOCUMENT res = irse_run( n_src_cts, n_c=, n_bkg= )

     IRSE run. Output goes to file irse_nnnn.scm

     2005-04-09/Niels J. Westergaard

     KEYWORDS: n_c     number of cases (defaults to 2000)
               n_bkg   number of bkg counts per detector pixel
                           defaults to 1.0
*/

   extern m, am, cap_n, cap_m, cap_r, num_bkg_counts;
   extern open_frac, fmask, famask, spread;

   extern d, c, cplus, cminus; // for output

   if( numberof(n_c) ) {
      n_cases = n_c;
   } else {
      n_cases = 2000;
   }
   if( numberof(n_bkg) == 0 ) {
      n_bkg = 1.0;
   }

   num_src_counts = n_src_cts;
   num_bkg_counts = long(n_bkg*cap_m*cap_m);

   print,"Running ", n_cases," cases: ", num_src_counts, num_bkg_counts;

   res = array(double, n_cases);
   fnd = array(int, n_cases);

   loop = 1;
   while( loop <= n_cases ) {

      src_pos = long( (random(2)-0.5)*spread + 0.5);
      exp_pos = (cap_m + cap_n +2)/2 - src_pos;
      src = shift(m,src_pos(1),src_pos(2))*1.0;
      i1 = (cap_n - cap_m)/2;
      i2 = i1 + cap_m - 1;
      src = src(i1:i2,i1:i2);
      w = where( src > 0.5 );
      nw = numberof(w);
      if( nw == 0 ) print,"Ups 1";
      r = random(num_src_counts)*nw;
      src = src*0.0;
      for(i = 1;i<=num_src_counts;i++) {
         src(w(long(r(i)+1.0)))++;
      }

      // detector definition

      d_bkg = array(double,cap_m,cap_m);
      n_d = cap_m * cap_m;
      r = random(num_bkg_counts) * n_d;
      for(i=1;i<=num_bkg_counts;i++) {
         d_bkg(long(r(i)+1.0))++;
      }

      d = d_bkg + src;
      d(long(0.7*cap_m),*) = 0.0; // "Dead anode"
      d(long(0.2*cap_m),*) = 0.0; // "Dead anode"
      dd = array(double,cap_r,cap_r);
      i1 = (cap_n + 1) / 2;
      i2 = i1 + cap_m - 1;
      dd(i1:i2,i1:i2) = d;

      cplus = fconvol(dd,fmask);
      cminus = fconvol(dd,famask);

      c = (1 - open_frac)*cplus - open_frac * cminus;

      //-------------------------------------------

      maxim, c, xval, xc, yc;

      box_hl = 4;
      im_dim = cap_n + cap_m - 1;
      if(xc - box_hl < 1 || xc + box_hl > im_dim || \
         yc - box_hl < 1 || yc + box_hl > im_dim) {
         print,"Peak at ", xc, yc, " is outside region - skip";
         continue;
      }

      box = c(xc-box_hl:xc+box_hl,yc-box_hl:yc+box_hl);
      box(box_hl,box_hl) = 0.;

      rootmsq = wrms(box);

      detsig = xval / rootmsq;

      res(loop) = detsig;
      if( xc == exp_pos(1) && yc == exp_pos(2) ) fnd(loop) = 1;

      if( loop % 100 == 0 ) print,loop,n_cases;

      //print, 'DETSIG = ', detsig;

      loop++;

   }

   hdr = array(string,6);
   hdr(1) = "// IRSE version 2 results     "+ndate(3);
   hdr(2) = "// n_cases = "+swrite(n_cases);
   hdr(3) = "// num_src_counts = "+swrite(num_src_counts);
   hdr(4) = "// num_bkg_counts = "+swrite(num_bkg_counts);
   hdr(5) = "// det_dim = "+swrite(cap_m);
   hdr(6) = "// mask_dim = "+swrite(cap_n);

   fname = get_next_filename( "irse_????.scm","." );
   wstab, fname, res, fnd, hdr=hdr;

   histo, res, h, x, binsize=0.05;
   plot,x,h,ps=10;

   return res;

}
%FILE% island.i
/***************************************************
   Find islands in an ocean consisting of a 2D array

   ocean(M,N) must be an integer array with values 0 and 1 only.

   Locate a pixel with value of one - open a new island
   island array - i,j,side1(up), side2(right), side3(down), side4(left)

     add_isle   -  update ocean with an island
     erase_isle -  return ocean without the given isle
     erase_lake -  remove lake from island
     get_lake   -  find a lake on a single island
     island     -  find and define an island
     isle_area  -  return the area of an isle
     outline    -  find the delimiting polygon of an isle
     sdf        -  ( - )
     squariness -  ( - )

   2009-10-29/NJW

*******************************************************/

func island( ocean )
/* DOCUMENT isle = island( ocean )

   Returns a 6xN array where
     isle(1,k),isle(2,k)  are indices (i,j) of pixel in 'ocean'
                          belonging to the island.
     isle(3:6,k)          are 1 if side up, right, down, left
                          has a neighbor
     N  is the number of pixels belonging to the island

     Argument 'ocean' must be a 2D integer array

    2009-10-28/NJW
*/
{

   extern include_map;

   di = [0,1,0,-1];
   dj = [1,0,-1,0];

   dms = dimsof(ocean);
   include_map = array(int,dms);
   M = dms(2);
   N = dms(3);
   w = where(ocean);
   if( !numberof(w) ) {
      //+ write,"Sorry, no pixels have been set";
      return [];
   }
   i = (w(1)-1)%M+1;
   j = (w(1)-1)/M+1;
   k = 1;
   n_included = 1;
   // define size to begin with - will be increased if needed
   isize = 1000;
   isle = array(int,6,isize);
   isle(1,k) = i;
   isle(2,k) = j;
   include_map(i,j) = 1;

   // see if neighboring pixels should be added
   for(s=1; s<=4; s++) {
      i2 = i+di(s);
      j2 = j+dj(s);
      if( i2 < 1 || i2 > M ) continue;
      if( j2 < 1 || j2 > N ) continue;
      if( ocean(i2,j2) && ocean(i2,j2) ) {
               // yes, this belongs to current island
         isle(2+s,k) = 1;
         if( n_included == isize ) { // used all space
            // double the size
            grow, isle, isle*0;
            isize *= 2;
         }
         n_included++;
         isle(1,n_included) = i2;
         isle(2,n_included) = j2;
         include_map(i2,j2) = 1;
      } else isle(2+s,k) = 0;
   }
   if( !sum(isle(3:6,k)) ) write,"Single pixel island";
   k++;

   while( k <= n_included ) {

      i = isle(1,k); j = isle(2,k);
      is_explored = sum(isle(3:6,k));

      if( !is_explored ) {
         for(s=1; s<=4; s++) {
            i2 = i+di(s);
            j2 = j+dj(s);
            if( i2 < 1 || i2 > M ) continue;
            if( j2 < 1 || j2 > N ) continue;
            if( ocean(i2,j2) && ocean(i2,j2) ) {
                         // yes, this belongs to current island
               isle(2+s,k) = 1;
               // only enlarge island if pixel is not already included
               //+ already_in = 0;
               //+ vv = where(isle(1,1:n_included)==i2);
               //+ if( numberof(vv) ) {
               //+    vvv = where(isle(2,vv)==j2);
               //+    if( numberof(vvv) ) already_in = 1;
               //+ }
               if( !include_map(i2,j2) ) { // add to island
                  if( n_included == isize ) {
                     grow, isle, isle*0;
                     isize *= 2;
                  }
                  n_included++;
                  isle(1,n_included) = i2;
                  isle(2,n_included) = j2;
                  include_map(i2,j2) = 1;
               }
            } else isle(2+s,k) = 0;
         }
      }

      k++;

   }

   //+ disp,ocean;
   //+ oplot,isle(1,),isle(2,),ps=5;

   return isle(,1:n_included);

}

/* Function c_outline */

func c_outline( isle, ocean, &x, &y, &nseg, &pseg )
/* DOCUMENT c_outline, isle, ocean, >x, >y, >nseg, >pseg

   Returns 1D arrays with island outline in array coordinates
   If there are lakes on the island the outline will consist of
   several disjunct pieces.
   'nseg' is an array with the length of each piece and 'pseg'
   is the start index for each piece.

   SEE ALSO: island, get_lake
*/
{

   local p, q;
   outline, isle, p, q;
   nseg = numberof(p);
   pseg = 1;
   x = p;
   y = q;
   lake = get_lake( isle, ocean );
   while( !is_void(lake) ) {
      outline, lake, p, q;
      grow, nseg, numberof(p);
      grow, pseg, numberof(x)+1;
      grow, x, p;
      grow, y, q;
      ocean = erase_lake( lake, ocean );
      lake = get_lake( isle, ocean );
   }

}

/* Function outline */

func outline( isle, &x, &y )
/* DOCUMENT outline, isle, >x, >y

   Returns 1D arrays with island outline in array coordinates

   SEE ALSO: island, get_lake
*/
{

   // for display purposes

   extern X, Y;

   if( is_void(isle) ) return;

   // locate pixel with open side facing down

   dms = dimsof(isle);
   if( dms(1) != 2 ) error,"Mark 1";
   if( dms(2) != 6 ) error,"Mark 2";
   N = dms(3); // Number of pixels
   for( k = 1; k <= N; k++ ) {
      if( isle(5,k) == 0 ) break;
   }
   if( k > N ) error,"Mark 3";

   i = isle(1,k);
   j = isle(2,k);
   side = 5;
   x = [isle(1,k)-0.5,isle(1,k)+0.5];
   y = [isle(2,k)-0.5,isle(2,k)-0.5];
   X = x; Y = y;

   while( !near(x(1),x(0),0.01) || !near(y(1),y(0),0.01) ) {

      if( side == 3 ) {

         // pixel at (i,j) has a up-open-side; find the
         // open side that connects to this up-side. It can be
         //    1) (i-1,j+1) if it has open right-side
         //    2) (i-1,j) if it has open up-side
         //    3) (i,j) if it has open left-side

         // Case: we have up-open pixel, what is next?

         if( isle(6,k) == 0 ) {
            // continues with itself
            grow,x, isle(1,k)-0.5;
            grow,y, isle(2,k)-0.5;
            X = x; Y = y;
            side = 6;
         } else {
            // locate (i-1,j) pixel
            w = where( isle(1,) == i-1 & isle(2,) == j & isle(3,) == 0 );
            if( numberof(w) ) {
               // continues with pixel to the left
               k = w(1);
               grow,x, isle(1,k)-0.5;
               grow,y, isle(2,k)+0.5;
               X = x; Y = y;
               side = 3;
               i--;
            } else {
               // continues with pixel to the left+up
               // MUST have open right-side
               w = where( isle(1,) == i-1 & isle(2,) == j+1 & isle(4,) == 0 );
               if( !numberof(w) ) error,"Mark 4";
               k = w(1);
               grow,x, isle(1,k)+0.5;
               grow,y, isle(2,k)+0.5;
               X = x; Y = y;
               side = 4;
               i--; j++;
            }
         }

      } else if( side == 4 ) {

         // pixel at (i,j) has a right-open-side; find the
         // open side that connects to this right-side. It can be
         //    1) (i+1,j+1) if it has open down-side
         //    2) (i,j+1) if it has open right-side
         //    3) (i,j) if it has open up-side

         // Case: we have right-open pixel, what is next?

         if( isle(3,k) == 0 ) {
            // continues with itself
            grow,x, isle(1,k)-0.5;
            grow,y, isle(2,k)+0.5;
            X = x; Y = y;
            side = 3;
         } else {
            // locate (i,j+1) pixel with open right-side
            w = where( isle(1,) == i & isle(2,) == j+1 & isle(4,) == 0 );
            if( numberof(w) ) {
               // continues with pixel above
               k = w(1);
               grow,x, isle(1,k)+0.5;
               grow,y, isle(2,k)+0.5;
               X = x; Y = y;
               side = 4;
               j++;
            } else {
               // continues with pixel to the right+up
               // MUST have open down-side
               w = where( isle(1,) == i+1 & isle(2,) == j+1 & isle(5,) == 0 );
               if( !numberof(w) ) error,"Mark 4";
               k = w(1);
               grow,x, isle(1,k)+0.5;
               grow,y, isle(2,k)-0.5;
               X = x; Y = y;
               side = 5;
               i++; j++;
            }
         }

      } else if( side == 5 ) {

         // pixel at (i,j) has a down-open-side; find the
         // open side that connects to this down-side. It can be
         //    1) (i+1,j-1) if it has open left-side
         //    2) (i+1,j) if it has open down-side
         //    3) (i,j) if it has open right-side

         // Case: we have down-open pixel, what is next?

         if( isle(4,k) == 0 ) {
            // continues with itself on the right side
            grow,x, isle(1,k)+0.5;
            grow,y, isle(2,k)+0.5;
            X = x; Y = y;
            side = 4;
         } else {
            // locate (i+1,j) pixel with open down side
            w = where( isle(1,) == i+1 & isle(2,) == j & isle(5,) == 0 );
            if( numberof(w) ) {
               // continues with pixel to the right
               k = w(1);
               grow,x, isle(1,k)+0.5;
               grow,y, isle(2,k)-0.5;
               X = x; Y = y;
               side = 5;
               i++;
            } else {
               // continues with pixel to the right+down
               // MUST have open left-side
               w = where( isle(1,) == i+1 & isle(2,) == j-1 & isle(6,) == 0 );
               if( !numberof(w) ) error,"Mark 4";
               k = w(1);
               grow,x, isle(1,k)-0.5;
               grow,y, isle(2,k)-0.5;
               X = x; Y = y;
               side = 6;
               i++; j--;
            }
         }

      } else if( side == 6 ) {

         // pixel at (i,j) has a left-open-side; find the
         // open side that connects to this left-side. It can be
         //    1) (i-1,j-1) if it has open up-side
         //    2) (i,j-1) if it has open left-side
         //    3) (i,j) if it has open down-side

         // Case: we have left-open pixel, what is next?

         if( isle(5,k) == 0 ) {
            // continues with itself
            grow,x, isle(1,k)+0.5;
            grow,y, isle(2,k)-0.5;
            X = x; Y = y;
            side = 5;
         } else {
            // locate (i,j-1) pixel
            w = where( isle(1,) == i & isle(2,) == j-1 & isle(6,) == 0 );
            if( numberof(w) ) {
               // continues with pixel below
               k = w(1);
               grow,x, isle(1,k)-0.5;
               grow,y, isle(2,k)-0.5;
               X = x; Y = y;
               side = 6;
               j--;
            } else {
               // continues with pixel to the left+down
               // MUST have open up-side
               w = where( isle(1,) == i-1 & isle(2,) == j-1 & isle(3,) == 0 );
               if( !numberof(w) ) error,"Mark 4";
               k = w(1);
               grow,x, isle(1,k)-0.5;
               grow,y, isle(2,k)+0.5;
               X = x; Y = y;
               side = 3;
               i--; j--;
            }
         }
      } else {
         error,"Mark 999 - you should never come here";
      }

   }

}

func sdf( void )
{
   extern Cshift;
   if( is_void(Cshift) ) Cshift = 1;
   if( Cshift ) {
      oplot,X,Y,color="red",thick=3;
   } else {
      oplot,X,Y,color="green",thick=3;
   }
   Cshift = 1 - Cshift;
}

func isle_area( isle )
{
   return dimsof(isle)(3);
}

func squariness( isle, &limit )
/* DOCUMENT sq = squariness( isle, >limit )
*/
{
   delx = max(isle(1,)) - min(isle(1,)) + 1;
   dely = max(isle(2,)) - min(isle(2,)) + 1;
   q = max(delx,dely);
   area = isle_area( isle );
   limit = double((q-1)^2 + 1)/q^2;
   return double(area)/q^2;
}

func erase_isle( isle, ocean )
/* DOCUMENT new_ocean = erase_isle( isle, ocean )
*/
{
   new_ocean = ocean;
   n = isle_area( isle );
   for( k = 1; k <= n; k++ ) new_ocean(isle(1,k),isle(2,k)) = 0;
   return new_ocean;
}

func erase_lake( lake, ocean )
/* DOCUMENT new_ocean = erase_lake( lake, ocean )
*/
{
   new_ocean = ocean;
   n = isle_area( lake );
   for( k = 1; k <= n; k++ ) new_ocean(lake(1,k),lake(2,k)) = 1;
   return new_ocean;
}

func get_lake( isle, ocean )
/* DOCUMENT lake = get_lake( isle, ocean )

    Return a lake (if it exists) defined like an isle
*/
{
   naeco = 1 - ocean;
   continent = island( naeco );
   without_cont = erase_isle( continent, naeco );
   lake = island( without_cont );
   return lake;
}

func add_isle( isle, ocean, reset= )
/* DOCUMENT new_ocean = add_isle( isle, ocean, reset= )

    Returns new ocean with island added
    Keyword 'reset' will reset the ocean ie. only keep the dimensions.
*/
{
   new_ocean = ocean;
   if( reset ) new_ocean *= short(0);
   n = isle_area( isle );
   for( k = 1; k <= n; k++ ) new_ocean(isle(1,k),isle(2,k)) = 1;
   return new_ocean;
}
%FILE% j_comb_spectra.i
func j_comb_spectra( num_of_spec, filelist, outspe=, noplot= )
/* DOCUMENT j_comb_spectra, num_of_spec, filelist, outspe=, noplot=

   Get several spectra combined from data e.g. produced with j_bin_spectra

   Assumes PHAII representation of spectra i.e. in a vector columns: RATE and
   STAT_ERR
   Argument 'num_of_spec' is the row number of the requested spectrum.

    2008-01-30/NJW Cloned from collect_spectra.i

*/
{
   local strnum;

   if( ! numberof(filelist) ) {
      write,"There is no indication of where to find the spectra ...";
      return [];
   }

   pflag = is_void(noplot);

   nlist = numberof(filelist);
   filelist = filelist(sort(filelist));
   filelist_used = filelist;
   nlist_used = 0;


   // Prepare the output files jmxi_nnnn_spe.fits
   // in the current directory but only if keyword outspe is set

   if( !numberof(outspe) ) {

      fname_spe = get_next_filename("jemx_????_spe.fits", strnum);
      logfile = "j_comb_spectra"+strnum+".log";

   } else {

      fname_spe = outspe;
      logfile = get_next_filename("j_comb_spectra????.log");

   }

   system,"cp /home/njw/jemx/spectra/jmx1_coll_spe.fits "+fname_spe;

   tot_spec = array(float,256);
   tot_err2 = array(float,256);
   tot_expo = 0.0;

   write,"Output logging data in "+logfile;
   lun = open(logfile,"w");

   write,lun,"  Logging of j_comb_spectra   "+ndate(3);
   write,lun;
   write,lun,"Resulting SPE file: "+fname_spe;

   for( i = 1; i <= nlist; i++ ) {

      write,"Analyzing "+itoa(i)+" of "+itoa(nlist);
      write,lun,"-------------------------------";
      write,lun,filelist(i);
      // Get header
      hdr = headfits(filelist(i)+"+1");
      naxis2 = fxpar(hdr,"NAXIS2");
      if( naxis2  <=  0 ) {
         write,"Skip - no rows";
         write,lun,"Skip this one, there are no rows";
         continue;
      }
      if( naxis2 < num_of_spec ) {
         write,"Too few rows in file";
         write,lun,"Too few rows in file";
         continue;
      }

      pick_swid_str, filelist(i), swid;
      swid = numberof(swid) ? swid(1) : "Unknown SWID";

      // read the exposure times
      exposure = rdfitscol(filelist(i)+"+1","EXPOSURE");

      // Get the spectrum etc.

      rate =     rdfitscol(filelist(i)+"+1","RATE");
      stat_err = rdfitscol(filelist(i)+"+1","STAT_ERR");

      if( pflag ) {
         dataplot,indgen(256),rate(,num_of_spec),stat_err(,num_of_spec);
         xyouts,0.25,0.82,swid,charsize=1.3,device=1;
         xyouts,0.25,0.80,swrite(format="Exposure %10.2f s",exposure(num_of_spec)), \
                      charsize=1.3,device=1;
      }

       //  Apply ad hoc selection

      sumrate = sum(rate(46:85));
      if( !near( sumrate, 4.1, 0.4) ) {
         write,"Rejected because of excess count rate";
         write,lun,"Rejected because of excess count rate";
         pause, 1000;
         continue;
      }
      write,"Accepted ...";
      write,lun,"Accepted ...";

      // include this one in the list of used spectral files;
      filelist_used(++nlist_used) = filelist(i);

      write,lun,format="Exposure time is %10.2f s\n",exposure(num_of_spec);

      tot_spec += reform(rate(,num_of_spec),256)*exposure(num_of_spec);
      tot_err2 += (reform(stat_err(,num_of_spec),256)*exposure(num_of_spec))^2;
      tot_expo += exposure(num_of_spec);

   }

   write,lun,"// total_exposure = ", tot_expo," ; s";
   write,lun,"//  --- Normal exit ---";

   close,lun;

   tot_spec = tot_spec / tot_expo;
   tot_err  = sqrt(tot_err2) / tot_expo;

   if( pflag ) dataplot,indgen(256),tot_spec,tot_err;

   //  Update standard file with collected spectrum;

   write,"New spectrum file: "+fname_spe;

   fh = headfits( fname_spe+"+1" );
   colnum = get_colnum( fh, "rate" );
   fits_bintable_poke, fname_spe+"+1",  1, colnum, float(tot_spec);
   colnum = get_colnum( fh, "stat_err" );
   fits_bintable_poke, fname_spe+"+1",  1, colnum, float(tot_err);
   colnum = get_colnum( fh, "exposure" );
   fits_bintable_poke, fname_spe+"+1",  1, colnum, double(tot_expo);


   //  Update the checksum;

   system,"fchecksum "+fname_spe+" update=yes";


}
%FILE% j_dete_mod_no_crab.i
/*
   A function to change the file
     /r9/njw/jemx/analysis7/jmx1_dete_mod_flex.fits
   to contain a map that excludes the footprint of the Crab
   irradiation.

   jmx1_imod_grp_0934.fits .. jmx1_imod_grp_0937.fits

   have been updated to point to /r9/njw/jemx/analysis7/jmx1_dete_mod_flex.fits
   instead of the original JMX1-DETE-MOD extension.

   2008-05-28/NJW

     Using new functions: j_get_scz (jemx.i)
                          j_src_on_shadowgram (jemx.i)

*/


// (A) Open jmx1_dete_mod_flex.fits and 1) get header 2) get image

// (B) Get pointing for SWID (get_pointing_for_swid)

// (C) Get map of Crab illumination on shadowgram (j_src_on_shadowgram)

// (D) Update detector map

// (E) Write result back to jmx1_dete_mod_flex.fits with original header
//     and new map

func j_dete_mod_no_crab( swid )
{
   flexfile = "/r9/njw/jemx/analysis7/jmx1_dete_mod_flex.fits";
   flexfile_orig = "/r9/njw/jemx/analysis7/jmx1_dete_mod_flex.fits.001";

   //  Reset to original

   cp, flexfile_orig, flexfile;

   // (A)
   hdr = headfits(flexfile+"+1");
   detemap = readfits(flexfile+"+1");

   // (B)
   local ra_scx, dec_scx, roll;
   get_pointing_for_swid, swid, ra_scx, dec_scx, roll;

   // (C)
   ra_src = 83.633; // Crab RA
   dec_src = 22.014; // Crab declination
   crabmap = j_src_on_shadowgram( ra_scx, dec_scx, roll, ra_src, dec_src );

   // (D)
   w = where( detemap > 0 & crabmap == 1 );
   if( numberof(w) > 0 ) detemap(w) = 16;

   // (E)
   fits_copy_keys, hdr, tokwds=1;
   writefits, flexfile, detemap, clobber=1;

   write,"done!";

}
%FILE% j_do_gain.i
/* Function j_do_gain */

func j_do_gain( numjemx, rev_start, rev_stop, nmax= )
/* DOCUMENT j_do_gain, numjemx, rev_start, rev_stop, nmax=
 *
 *  Produce the gain values used in OSA6 for a range
 *  of revolutions with a value for each ScW with
 *  an existing event list
 *
 *     2007-01-26/NJW
 *
 */

{
   require,"jemx.i";
   require,"mfits.i";
   require,"idlx.i";

// Get an available project name
   proj_names = ["q061","q062","q063","q064","q065","q066","q067","q068"];
   for(iflag=1;iflag<=8;iflag++) {
      flag_file = "/r9/njw/jemx/analysis6/in_use_"+proj_names(iflag);
      if( !file_test(flag_file) ) {
         system,"touch "+flag_file;
         break;
      }
   }
   if( iflag == 9 ) {
      write,"No available projects - skip";
      return;
   }
   proj = proj_names(iflag);

   for( rnum = rev_start; rnum <= rev_stop; rnum++ ) {
      // Get list of directories of this revolution in the archive
      revol = swrite(format="%04i", rnum );
      arcdir = "/r8/jemx/arc/rev_2/scw/"+revol;
      dlist = file_search(revol+"*.001",arcdir);
      ndlist = numberof(dlist);
      if( ndlist == 0 ) continue;
      list = [];
      // For each directory check the existence of the event file
      for( i = 1; i <= ndlist; i++ ) {
         alist = file_search("jmx1_events.fits.gz", dlist(i));
         if( !is_void(alist) ) grow, list, alist;
      }
      if( is_void(list) ) continue; // No events files in this revol.
      list = list(sort(list));
      if( nmax ) list = list(1:min([nmax,numberof(list)]));
      nswid = pick_swid_str( list, swid_list );
      if( nswid == 0 ) continue;
      result = array(double,4,nswid);

      for( i = 1; i <= nswid; i++ ) {
         res = j_gain_values( 1, swid_list(i), diag=0, proj=proj );
         if( is_void(res) ) {
            result(,i) = array(-1.0,4);
         } else {
            result(,i) = res;
         }

         wrmfitscols,"/r6/jemx/gain_history/jmx1_"+revol+".fits", \
            "SWID", swid_list, "AVG_GAIN", result(1,), \
            "G_SLOPE", result(2,), "TIMEGAIN", result(3,), \
            "QUALITY", int(result(4,)),clobber=1;

         // system,"/bin/rm /net/uhuru/pool/pool1/gz_proxy_*.fits";
      }

   }

   write,"Unflag the current project: "+proj_names(iflag);
   system,"/bin/rm "+flag_file;

}
%FILE% j_evts2shd.i
/* Function j_evts2shd */

func j_evts2shd( jemxNum, swid, outfile, chanmin=, chanmax=, nrt= )
/* DOCUMENT j_evts2shd, jemxNum, swid, outfile, chanmin=, chanmax=, nrt=
   or shd = j_evts2shd( jemxNum, swid, outfile, chanmin=, chanmax=, nrt= )
*/
{
   revolstr = strpart( swid, 1:4 );
   if( nrt ) {
      archive = "/r6/jemx/sci_data/pvphase/nrt/ops_1/scw/";
   } else {
      archive = "/jemx/arc/rev_2/scw/";
   }

   jstr = "jmx"+itoa(jemxNum);
   direc = archive+revolstr+"/"+swid+".000";
   if( !file_test(direc) ) {
      direc = archive+revolstr+"/"+swid+".001";
      if( !file_test(direc) ) {
         direc = archive+revolstr+"/"+swid+".002";
         if( !file_test(direc) ) {
            write,"I give up ..."
            return [];
         }
      }
   }
   write,"Succeeded with "+direc;
   filename = gz_proxy_file(direc+"/"+jstr+"_events.fits");

   detx = rdfitscol(filename+"+3","detx");
   dety = rdfitscol(filename+"+3","dety");
   api  = rdfitscol(filename+"+3","pi");
   fh = headfits(filename+"+3");

   if( chanmin ) {
      w = where( api >= chanmin );
      if( numberof(w) ) {
         detx = detx(w);
         dety = dety(w);
         api = api(w);
      }
   } else chanmin = 0;
   if( chanmax ) {
      w = where( api <= chanmax );
      if( numberof(w) ) {
         detx = detx(w);
         dety = dety(w);
         api = api(w);
      }
   } else chanmax = 256;

   shd = makeimageu( [256,256],detx,dety,xr=[-128.,128.],yr=[-128.,128.] );
   axi = span(-127.5,127.5,256);

   if( am_subroutine() && is_void(outfile) ) {
      outfile = get_next_filename(jstr+"_shd_"+swid+"_??.fits");
   }
   if( !is_void(outfile) ) {
      fits_copy_keys,fh,tokwds=1;
      kwds_set,"CHANMIN",chanmin,"Min value of PI";
      kwds_set,"CHANMAX",chanmax,"Max value of PI";
      kwds_set,"EXTNAME",strupcase(jstr)+"-EVTS-SHD","Name of this data structure";
      writefits, outfile, shd, xax=axi, yax=axi;
   }

}
%FILE% j_exposure_skymap.i
file = openb("/home/njw/jemx/DGXE/IJWarr.ysav");
write, "Restoring";
s = get_vars(file);
*s(1);
restore, file;
close, file;

func j_exposure_skymap( jemxNum, rev= )
/* DOCUMENT map = j_exposure_skymap( jemxNum, rev= )

   returns a map of accumulated TELAPSE of revolutions defined by
   'rev' in 360 x 180

   Use map2fits (in globe_mapping.i) to convert to Aitoff projection

   2008-08-25/NJW
*/
{

   local swid, ra, dec, posangle, ut, ijd, telapse, mode1, mode2;

   base = get_env("J_POINTINGS");

   map = array(double,360,180); // will receive the result

   silent = 0;

   // Get the pointing files of the requested revolutions
   if( numberof(rev) ) {
      if( typeof(rev) == "string" ) {
         revarr = str2arr( rev );
      } else {
         if( numberof( rev ) == 2 ) {
            revarr = indgen(long(rev(2)-rev(1))+1) + long(rev(1)) - 1;
         } else {
            revarr = long(rev)
         }
      }
      nrev = numberof(revarr);
      for( i = 1; i <= nrev; i++ ) {
         revstr = swrite(revarr(i),format="%4.4i");
         tmp = base+"/pointings_"+revstr+"p.dat";
         if( !silent ) write,tmp;
         ybase = base+"/ysav"+swrite(revarr(i)/100,format="%1.1i/");
         ytmp = ybase+"pointings_"+revstr+"p.ysav";
         if( !silent ) write,ytmp;
         if( i == 1 ) {
            pf_list = tmp;
            ypf_list = ytmp;
         } else {
            grow,pf_list,tmp;
            grow,ypf_list,ytmp;
         }
      }
   } else {
      // or - if no revolutions are spcified - get all available
      pf_list = file_search("pointings_*p.dat", base);
      ypf_list = pf_list;
      npf_list = numberof(pf_list);
      for( i = 1; i <= npf_list; i++ ) {
         pos = strpos( pf_list(i),"_" );
         revstra = strpart(pf_list(i), pos+1:pos+4 );
         drevstra = strpart(pf_list(i),pos+2:pos+2);
         ybase = base+"/ysav"+drevstra;
         ytmp = ybase+"/pointings_"+revstra+"p.ysav";
         ypf_list(i) = ytmp;
      }
   }
   npf_list = numberof(pf_list);
   if( npf_list == 0 ) {
      write,"j_exposure_skymap error: no pointing files of required kind found";
      return -1;
   }


   ntotal = 0;
   for( ipf_list = 1; ipf_list <= npf_list; ipf_list++ ) {

      if( file_test(ypf_list(ipf_list)) ) {
         if( !silent ) write,"Reading binary file "+ypf_list(ipf_list);
         bfile = openb( ypf_list(ipf_list) );
         restore,bfile, swid, ra, dec, posangle, ut, ijd, telapse, \
                     mode1, mode2;
         close, bfile;
      } else {
         if( !silent ) write,"Reading usual text file "+pf_list(ipf_list);
         if( ! file_test(pf_list(ipf_list)) ) {
            if( !silent ) write,pf_list(ipf_list)+" was not found";
            continue;
         }
         swid = rscol( pf_list(ipf_list),1, str=1, silent=1);
         ra = rscol( pf_list(ipf_list), 2, silent=1);
         dec = rscol( pf_list(ipf_list), 3, silent=1);
         posangle = rscol( pf_list(ipf_list), 4, silent=1);
         ut = rscol( pf_list(ipf_list), 5, str=1, silent=1);
         ijd = rscol( pf_list(ipf_list), 6, silent=1);
         telapse = rscol( pf_list(ipf_list),7, silent=1);
         mode1 = rscol( pf_list(ipf_list), 8, str=1, silent=1);
         mode2 = rscol( pf_list(ipf_list), 9, str=1, silent=1);

         bfile = createb( ypf_list(ipf_list) );
         save, bfile,  swid, ra, dec, posangle, ut, ijd, telapse, \
                 mode1, mode2;
         close, bfile;
      }


      glb = galactic( ra, dec );

      for( i = 1; i <= numberof(swid); i++ ) {

        /*
         *  Find pixel in map for update
         */

         if( jemxNum == 1 ) {
            if( mode1(i) != "F" ) continue;
         } else {
            if( mode2(i) != "F" ) continue;
         }
         
         conv_lonlat2map, glb(i,1), glb(i,2), ix, iy;

         if( iy > 180 || iy <= 0 ) {
            write,format="Warning: iy = %i - out of range, reset\n", iy;
            iy = iy > 180 ? 180 : 1;
         }

         value = telapse(i);

         lindx = IDXARR(iy);
         lindx_end = iy == 180 ? IDXARR(0) : IDXARR(iy+1)-1;
         for( k = lindx; k <= lindx_end; k++ ) {
            ii = IIARR(k) + ix - 180;
            if( ii > 360 ) ii -= 360;
            if( ii <=  0 ) ii += 360;
            ii = 361 - ii; // to make image agree with coord.syst.
            jj = JJARR(k);
            map(ii,jj) += value*WARR(k);
         }
      }

   }

   return map;
}

%FILE% j_gain_arr20.i
func j_gain_arr20( numjemx, swid, diag= )
/* DOCUMENT res = j_gain_arr20( numjemx, swid, diag= )

    Returns an array res(2,20) where res(1,) is the
    IJD time and res(2,) is the averaged gain.

    To be run on 'gauss'

    2007-01-25/NJW
*/

{
   require, "plot.i";
   require, "idlx.i";
   require, "mfits.i";
   require, "jemx.i";

   local selection;

   num_bins = 20;

   events = j_get_events( numjemx, swid, proj=proj );
   gain = j_get_used_gain( numjemx, swid, events, selection );
   // gain is an array with a gain value per selected event (status < 33)
   if( is_void(gain) ) return [];
   events = events(selection);
   w = where(gain < 50.);
   ngain = numberof(w);
   if( ngain == 0 ) {
      write,"No gain values below 50 - skip";
      return [];
   }
   gain = gain(w);
   ev_time = events(w).evtime;
   if( ngain < num_bins ) num_bins = ngain;
   n_per_bin = ngain / num_bins;
   // gain_bin = array(float, num_bins);
   // time_bin = array(double, num_bins);
   result = array(double,2,num_bins);
   for( i = 1; i <= num_bins; i++ ) {
      i1 = (i-1)*n_per_bin + 1;
      i2 = i * n_per_bin;
      result(2,i) = avg(gain(i1:i2));
      result(1,i) = 0.5*(ev_time(i1)+ev_time(i2));
   }
   ev_time0 = 0.5*(ev_time(1)+ev_time(0));

   if( diag ) {
      jmxstr = swrite(format="JMX%1i", numjemx);
      plot, (ev_time-ev_time0)*86400.0, gain, ps=1,yr=[0,50];
      xyouts, 0.5,0.8, swid, align=0.5,device=1;
      oplot, (time_bin-ev_time0)*86400.0, gain_bin+3;
   }

   return result;

}
%FILE% j_get_spe_proj_list.i
func j_get_spe_proj_list( jemxNum, proj )
/* DOCUMENT list = j_get_spe_proj_list( jemxNum, proj )

   Returns a list of spectral files assuming that
   /r9/njw/jemx/analysis9/do_project jemxNum proj
   has been run beforehand with END_LVL=SPE (or higher)

   This function returns spectral files from
   /scratch/jemx/njw rather than from
   /jemx/njw/srcl_res

   Since /scratch is not the same for 'maxwell' and 'tesla'
   this yorick session shold be run on the same machine as
   was used for 'do_project'.

   2008-01-17/NJW
   2011-05-19/NJW updated
*/
{
   final_list = [];
   jemxNum = swrite(format="%1i", jemxNum);
   dir = "/scratch/jemx/njw";

   // find subdirectories for the actual project
   //  (one subdirectory exists per block)

   list = lsdir( dir, subdirs );
   subdirs = subdirs(where(strmatch( subdirs, proj )));
   nsubs = numberof(subdirs);

   for( i = 1; i <= nsubs; i++ ) {
      block = strpart(subdirs(i),-1:0);

      // define directory just above the data files

      ddir = dir+"/"+subdirs(i) \
        +"/obs/"+proj+"_"+jemxNum+"_block_"+block+"/scw";

      // each ScW is a subdirectory

      scw = lsdir( ddir, subdd );
      nsubdd = numberof(subdd);

      // loop over ScWs in this block

      for( j = 1; j <= nsubdd; j++ ) {
         // if a spectral file exists it must have this name:
         spename = ddir+"/"+subdd(j)+"/jmx"+jemxNum+"_srcl_spe.fits";
         if( file_test( spename ) ) {
            grow, final_list, spename;
         }
      }
   }

   return final_list;

}
%FILE% j_mk_arr20.i
func j_mk_arr20( rev )
/* DOCUMENT j_mk_arr20, swid

     2007-02-22/NJW
*/

{

   require, "idlx.i";
   require, "jfits.i";
   require, "mfits.i";
   require, "jemx.i";
   require, "j_gain_arr20.i";

   if( "node2" == get_env("HOST") || "gauss" == get_env("HOST") ) {
      basdir = "/net/uhuru/pool/pool28/njw/";
   } else {
      basdir = "/pool28/njw/";
   }

   single = 0;
   if( typeof(rev) == "string" ) {
      revol = strpart(rev,1:4);
      if( strlen(rev) == 12 ) {
         swid = rev;
         single = 1;
      }
   } else {
      revol = swrite(format="%04i", rev);
   }

   if( single ) {
      list = file_search( "j1_"+swid+".ysav", basdir+revol );
   } else {
      list = file_search( "j1_*.ysav", basdir+revol );
   }
   nlist = numberof(list);
   if( nlist == 0 ) {
      if( single ) {
         write,format="Sorry, no .ysav file for this SWID: %s\n", swid;
      } else {
         write,format="Sorry, no .ysav files for this revolution: %s\n", revol;
      }
      return;
   }
   pick_swid_str, list, swids;
   nswids = numberof(swids);
   if( nswids != nlist ) {
      write,format="nlist = %i, but nswids = %i - terminate\n", nlist, nswids;
      return;
   }

   kwds_init;
   kwds_set,"REVOL",atoi(revol),"INTEGRAL revolution number";
   kwds_set,"TELESCOP","INTEGRAL","Mission name";
   kwds_set,"INSTRUME","JMX1","Instrument name";
   kwds_set,"CREATOR","j_mk_arr20.i","made this file";
   for( i = 1; i <= nswids; i++ ) {

      res = j_gain_arr20( 1, swids(i) );
      if( is_void(res) ) continue;
      kwds_set,"DATE",ndate(3),"Date of file creation";
      kwds_set,"SWID",swids(i),"Science Window ID";

      wrmfitscols, basdir+revol+"/jmx1_gain_arr20_"+swids(i)+".fits", \
             "TIME", res(1,), "GAIN", res(2,), clobber=1;

      write,format="%s has been written\n", basdir+revol+"/jmx1_gain_arr20_"+swids(i)+".fits";

   }

}
%FILE% jabscrab_a.i
func jabscrab_a( revol, lg=, shw= )
/* DOCUMENT res = jabscrab_a( revol, lg=, shw= )

   Collect the information from the run of 'do_project 1 q135' and
   'do_project 1 q136' and present
    - DET and CBJ spectra


    Keyword   lg :  If set to 1, output logging file
                    If no set (i.e. value 'void') output to screen
                    If set to 0 (zero) suppress output entirely
             shw :  Causes screen plotting

   2008-02-26/NJW
   2008-02-28/NJW, updated to return a struct s_Spec with results
   2008-05-16/NJW, cloned from dgxe_ana_swid.i
*/
{

   extern NEBINS;

   if( is_void(NEBINS) ) {
      write,"You must first include 'jabscrab_i.i'";
      return [];
   }

   local ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp;
   local ob1_dspb, ob2_dspb, orate_dspb, orate_err_dspb;

   if( is_void(lg) ) lg = 2;
   if( lg==1 ) {
      logname = get_next_filename("jabscrab_log_????.txt");
      write,"Log output in "+logname;
      flog = open(logname,"w");
      write,flog,format="JABSCRAB log for JMX1 and REVOL %i/%s\n", \
                    revol, ndate(3);
   }

   res = s_Spec();

   YRANGE1 = 0.02;

   //    2008-05-16/NJW
   // Assume that project q135 has been run for JMX1 for DET spectra
   // Assume that project q136 has been run for JMX1 for DET spectra for background
   // with resulting files in  /r9/njw/jemx/analysis7/srcl_res


   analysis7_dir = get_env("J_ANALYSIS7");
   scdir = analysis7_dir+"/srcl_res/";
   revolstr = swrite(format="%04i", revol);


// *******************************************************************************

   // *******  Get the detector spectrum *********
   //      from the output of level BIN_S in 'dspfile'
   //  Values have been normalized to 100 cm2; change back to counts/s

   if( revol == 170 ) {
      swid = "017000810010";
   } else if( revol == 239 ) {
      swid = "023900030010";
   } else if( revol == 300 ) {
      swid = "030000160010";
   } else if( revol == 365 ) {
      swid = "036500790010";
   } else if( revol == 422 ) {
      swid = "042200800010";
   } else if( revol == 483 ) {
      swid = "048300410010";
   } else if( revol == 541 ) {
      swid = "054100140010";
   } else if( revol == 605 ) {
      swid = "060500580010";
   } else {
      write,"No such revolution";
      return [];
   }

   dspfile = scdir+"jmx1_full_dsp_q135_"+swid+".fits";

   usedarea = fxpar(headfits(dspfile+"+1",nocheck=1),"usedarea");
   if( !numberof(usedarea)) error,"##11## trouble with usedarea";
   rate = (rdfitscol(dspfile+"+1", "rate" )*usedarea/100.)(,1);
   rate_err = (rdfitscol(dspfile+"+1", "stat_err" )*usedarea/100.)(,1);
   spe_expo = rdfitscol(dspfile+"+1", "exposure" )(1);

   // Rebin from very fine bins to fine bins

   specrebinning, Eb1, Eb2, rate, rate_err, Rebin, \
          ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp;

   res.detnbins = numberof(orate_dsp);
   ii = indgen(res.detnbins);
   res.deteb1(ii) = ob1_dsp;
   res.deteb2(ii) = ob2_dsp;
   res.detspec(ii) = orate_dsp;
   res.detspec_err(ii) = orate_err_dsp;
   if(lg==1)write,flog,format="Total DSP ctr: %8.3f\n", res.detspec(sum);
   if(lg==2)write,format="Total DSP ctr: %8.3f\n", res.detspec(sum);
   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";


// *******************************************************************************

   // *******  Get the detector spectrum for background i.e. project q136 *********
   //      from the output of level BIN_S in 'dspfile'
   //  Values have been normalized to 100 cm2; change back to counts/s

   swid = "017000370010";
   if( revol == 170 ) {
      swids = ["017000370010","017000420010","017000690010",\
               "017000730010","017000890010","017000930010"];
      swid = swids(1);
   } else if( revol == 239 ) {
      swids = ["023900900010","023900940010","023900980010"];
      swid = swids(1);
   } else if( revol == 300 ) {
      swid = "030000160010";
   } else if( revol == 365 ) {
      swids = ["036500830010","036500870010"];
      swid = swids(1);
   } else if( revol == 422 ) {
      swids = ["042200060010","042200220010","042200260010"];
      swid = swids(1);
   } else if( revol == 483 ) {
      swids = ["048300110010","048300120010","048300320010"];
      swid = swids(1);
   } else if( revol == 541 ) {
      swids = ["054100060010","054100220010","054100260010",\
               "054100270010","054100280010","054100310010",\
               "054100360010","054100370010","054100460010",\
               "054100470010","054100480010","054100510010"];
      swid = swids(1);
   } else if( revol == 605 ) {
      swids = ["060500080010","060500240010","060500280010",\
               "060500290010","060500320010","060500330010",\
               "060500340010","060500430010","060500440010",\
               "060500490010","060500520010","060500530010"];
      swid = swids(1);
   }
   dspfile = scdir+"jmx1_full_dsp_q136_"+swid+".fits";

   usedareab = fxpar(headfits(dspfile+"+1",nocheck=1),"usedarea");
   if( !numberof(usedareab)) error,"##11## trouble with usedarea";
   rateb = (rdfitscol(dspfile+"+1", "rate" )*usedarea/100.)(,1);
   rate_errb = (rdfitscol(dspfile+"+1", "stat_err" )*usedarea/100.)(,1);
   spe_expob = rdfitscol(dspfile+"+1", "exposure" )(1);

   // Rebin from very fine bins to fine bins

   specrebinning, Eb1, Eb2, rateb, rate_errb, Rebin, \
          ob1_dspb, ob2_dspb, orate_dspb, orate_err_dspb;

   res.dtbnbins = numberof(orate_dspb);
   ii = indgen(res.dtbnbins);
   res.dtbeb1(ii) = ob1_dspb;
   res.dtbeb2(ii) = ob2_dspb;
   res.dtbspec(ii) = orate_dspb;
   res.dtbspec_err(ii) = orate_err_dspb;
   if(lg==1)write,flog,format="Total DSP ctr: %8.3f\n", res.dtbspec(sum);
   if(lg==2)write,format="Total DSP ctr: %8.3f\n", res.dtbspec(sum);
   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";

// *******************************************************************************

  // *******  Subtract background from spectrum with source (Crab)

   netspec = orate_dsp - orate_dspb;
   netspec_err = sqrt(orate_err_dsp^2 + orate_err_dspb^2);

// *******************************************************************************


   // *******  Get the CBJ source fluxes *********

   cbjdir = "/home/njw/yorick/dete_imod/";
   if( revol == 170 ) {
      cbjname = "17008100";
   } else if( revol == 239 ) {
      cbjname = "23900300";
   } else if( revol == 300 ) {
      cbjname = "30001600";
   } else if( revol == 365 ) {
      cbjname = "36507900";
   } else if( revol == 422 ) {
      cbjname = "42208000";
   } else if( revol == 483 ) {
      cbjname = "48304100";
   } else if( revol == 541 ) {
      cbjname = "54101400";
   } else if( revol == 605 ) {
      cbjname = "60505800";
   }
   cbjfile = cbjdir+"cbj_"+cbjname+".dat";

   ecbj = rscol( cbjfile, 1, silent=1 );
   rate_cbj = rscol( cbjfile, 2, silent=1 );
   res.cbjnbins = numberof(ecbj);

   local ecbj1, ecbj2;
   get_boundaries, ecbj, ecbj1, ecbj2;
   ii = indgen(res.cbjnbins);
   res.cbjeb1(ii) = ecbj1;
   res.cbjeb2(ii) = ecbj2;
   res.cbjspec(ii) = rate_cbj;
   rate_cbj_err = sqrt(rate_cbj*spe_expo)/spe_expo;
   res.cbjspec_err(ii) = sqrt(rate_cbj*spe_expo)/spe_expo;


// *******************************************************************************


   // *******  Do the spectral plotting     *********

   if(shw) window, 1,style="boxed.gs";


   tmp = max((orate_dsp+orate_err_dsp)/(ob2_dsp-ob1_dsp)); // BIN_S spectrum
   grow, tmp, max((orate_dspb+orate_err_dspb)/(ob2_dspb-ob1_dspb)); // BIN_S bkg spectrum

   // plot (BIN_S) detector spectrum in fine energy bins

   if(shw) {
      plot_spectrum, ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp, itype=3, \
            xr=[2,40],yr=[YRANGE1,1.3*max(tmp)], title="JMX1 "+swid;
   
      oplot_spectrum, ob1_dspb, ob2_dspb, orate_dspb, orate_err_dspb;
   
      oplot_spectrum, ecbj1, ecbj2, rate_cbj, rate_cbj_err, color="green";

      oplot_spectrum, ob1_dsp, ob2_dsp, netspec, netspec_err, color="red";

   }



// ***********************************************************************************


   if(lg==1)close, flog;

   return res;

}
%FILE% jabscrab_b.i
func jabscrab_b( specfile, bkgfile, lg=, shw= )
/* DOCUMENT res = jabscrab_b( specfile, bkgfile, lg=, shw= )

   Collect the information from the run of 'do_project 1 q135' and
   'do_project 1 q136' and present
    - DET and CBJ spectra


    Keyword   lg :  If set to 1, output logging file
                    If no set (i.e. value 'void') output to screen
                    If set to 0 (zero) suppress output entirely
             shw :  Causes screen plotting

   2008-02-26/NJW
   2008-02-28/NJW, updated to return a struct s_Spec with results
   2008-05-16/NJW, cloned from dgxe_ana_swid.i
*/
{

   extern NEBINS;

   if( is_void(NEBINS) ) {
      write,"You must first include 'jabscrab_i.i'";
      return [];
   }

   local ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp;
   local ob1_dspb, ob2_dspb, orate_dspb, orate_err_dspb;

   if( is_void(lg) ) lg = 2;
   if( lg==1 ) {
      logname = get_next_filename("jabscrab_log_????.txt");
      write,"Log output in "+logname;
      flog = open(logname,"w");
      write,flog,format="JABSCRAB log for JMX1,  %s\n", ndate(3);
      write,flog,format="Spectrum file: %s\n", specfile;
      write,flog,format="Background file: %s\n", bkgfile;
   }

   res = s_Spec();

   YRANGE1 = 0.02;

   //    2008-05-19/NJW, cloned from jabscrab_a.i
   // Assume that project q135 has been run for JMX1 for DET spectra
   // Assume that project q136 has been run for JMX1 for DET spectra for background



// *******************************************************************************

   // *******  Get the detector spectrum *********
   //      from the output of level BIN_S in 'dspfile'
   //  Values have been normalized to 100 cm2; change back to counts/s


   dspfile = specfile;

   usedarea = fxpar(headfits(dspfile+"+1",nocheck=1),"usedarea");
   if( !numberof(usedarea)) error,"##11## trouble with usedarea";
   rate = (rdfitscol(dspfile+"+1", "rate" )*usedarea/100.)(,1);
   rate_err = (rdfitscol(dspfile+"+1", "stat_err" )*usedarea/100.)(,1);
   spe_expo = rdfitscol(dspfile+"+1", "exposure" )(1);

   // Rebin from very fine bins to fine bins

   specrebinning, Eb1, Eb2, rate, rate_err, Rebin, \
          ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp;

   res.detnbins = numberof(orate_dsp);
   ii = indgen(res.detnbins);
   res.deteb1(ii) = ob1_dsp;
   res.deteb2(ii) = ob2_dsp;
   res.detspec(ii) = orate_dsp;
   res.detspec_err(ii) = orate_err_dsp;
   if(lg==1)write,flog,format="Total DSP ctr: %8.3f\n", res.detspec(sum);
   if(lg==2)write,format="Total DSP ctr: %8.3f\n", res.detspec(sum);
   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";


// *******************************************************************************

   // *******  Get the detector spectrum for background i.e. project q136 *********
   //      from the output of level BIN_S in 'dspfile'
   //  Values have been normalized to 100 cm2; change back to counts/s

   dspfile = bkgfile;

   usedareab = fxpar(headfits(dspfile+"+1",nocheck=1),"usedarea");
   if( !numberof(usedareab)) error,"##11## trouble with usedarea";
   rateb = (rdfitscol(dspfile+"+1", "rate" )*usedarea/100.)(,1);
   rate_errb = (rdfitscol(dspfile+"+1", "stat_err" )*usedarea/100.)(,1);
   spe_expob = rdfitscol(dspfile+"+1", "exposure" )(1);

   // Rebin from very fine bins to fine bins

   specrebinning, Eb1, Eb2, rateb, rate_errb, Rebin, \
          ob1_dspb, ob2_dspb, orate_dspb, orate_err_dspb;

   res.dtbnbins = numberof(orate_dspb);
   ii = indgen(res.dtbnbins);
   res.dtbeb1(ii) = ob1_dspb;
   res.dtbeb2(ii) = ob2_dspb;
   res.dtbspec(ii) = orate_dspb;
   res.dtbspec_err(ii) = orate_err_dspb;
   if(lg==1)write,flog,format="Total DSP ctr: %8.3f\n", res.dtbspec(sum);
   if(lg==2)write,format="Total DSP ctr: %8.3f\n", res.dtbspec(sum);
   if(lg==1)write,flog,"----------------------------------------";
   if(lg==2)write,"----------------------------------------";

// *******************************************************************************

  // *******  Subtract background from spectrum with source (Crab)

   netspec = orate_dsp - orate_dspb;
   netspec_err = sqrt(orate_err_dsp^2 + orate_err_dspb^2);

// *******************************************************************************


   // *******  Get the CBJ source fluxes *********

   cbjdir = "/home/njw/yorick/dete_imod/";
   cbjname = "60505800";

   cbjfile = cbjdir+"cbj_"+cbjname+".dat";

   ecbj = rscol( cbjfile, 1, silent=1 );
   rate_cbj = rscol( cbjfile, 2, silent=1 );
   res.cbjnbins = numberof(ecbj);

   local ecbj1, ecbj2;
   get_boundaries, ecbj, ecbj1, ecbj2;
   ii = indgen(res.cbjnbins);
   res.cbjeb1(ii) = ecbj1;
   res.cbjeb2(ii) = ecbj2;
   res.cbjspec(ii) = rate_cbj;
   rate_cbj_err = sqrt(rate_cbj*spe_expo)/spe_expo;
   res.cbjspec_err(ii) = sqrt(rate_cbj*spe_expo)/spe_expo;


// *******************************************************************************


   // *******  Do the spectral plotting     *********

   if(shw) window, 1,style="boxed.gs";


   tmp = max((orate_dsp+orate_err_dsp)/(ob2_dsp-ob1_dsp)); // BIN_S spectrum
   grow, tmp, max((orate_dspb+orate_err_dspb)/(ob2_dspb-ob1_dspb)); // BIN_S bkg spectrum

   // plot (BIN_S) detector spectrum in fine energy bins

   if(shw) {
      plot_spectrum, ob1_dsp, ob2_dsp, orate_dsp, orate_err_dsp, itype=3, \
            xr=[2,40],yr=[YRANGE1,1.3*max(tmp)], title="JMX1 80 ks, Rev 0605";
   
      oplot_spectrum, ob1_dspb, ob2_dspb, orate_dspb, orate_err_dspb;
   
      oplot_spectrum, ecbj1, ecbj2, rate_cbj, rate_cbj_err, color="green";

      oplot_spectrum, ob1_dsp, ob2_dsp, netspec, netspec_err, color="red";

   }



// ***********************************************************************************


   if(lg==1)close, flog;

   return res;

}
%FILE% jabscrab_i.i
/*********************************************
     Part of jabscrab project
     This initializes for ana_swid, dgxe_... etc.

     2008-05-16/NJW
**********************************************/
#include "common.i"
#include "euler.i"
#include "plot_spectrum.i"
#include "tempus.i"
#include "jabscrab_a.i"

NEBINS = 200;

// Setup struct for spectral results

struct s_Spec {
   double exposure;
   double gain;
   long   detnbins;
   double deteb1(NEBINS);
   double deteb2(NEBINS);
   double detspec(NEBINS);
   double detspec_err(NEBINS);
   long   dtbnbins;
   double dtbeb1(NEBINS);
   double dtbeb2(NEBINS);
   double dtbspec(NEBINS);
   double dtbspec_err(NEBINS);
   long   cbjnbins;
   double cbjeb1(NEBINS);
   double cbjeb2(NEBINS);
   double cbjspec(NEBINS);
   double cbjspec_err(NEBINS);
}

write,"Defining external variables Eb1 and Eb2 (PI energy boundaries)";

j_get_pi_ebds, Eb1, Eb2;

write,"Defining rebinning array in external variable Rebin";

Rebin = [30,1,1,1,1,1];
grow,Rebin,array(2,20);
grow,Rebin,array(3,70);

%FILE% jemx.i
/* Function jemx */

extern jemxdoc;
/* DOCUMENT jemx package 2.5

    Specific JEMX related Yorick functions

     _read_catalog                 j_get_scz                     
     best_skypos                   j_get_sloc_res_sources        
     bti_info                      j_get_src_spectrum            
     build_swid_time_table         j_get_srcl_res_sources        
     cat_compare                   j_get_srcl_res_sources_a      
     cbj_image_name                j_get_srcl_res_spectra        
     crab_count_rate               j_get_srcl_res_spectrum       
     dattim2ijd                    j_get_used_gain               
     find_src_by_name              j_mk_vignet                   
     find_swid_galac               j_src_on_shadowgram           
     find_swid_radec               j_std_rebin                   
     find_swid_slice               j_thruput                     
     get_exposure_for_swid         jconv_axes2posang             
     get_gain_for_swid             jconv_posang2axes             
     get_pointing_for_swid         jmx1_offaxis_azim             
     get_revol_no                  misalign                      
     get_revol_start_time          mk_reg                        
     get_time_for_swid             mk_swid_lists                 
     gti_print                     mk_unique_cat                 
     ijd2dattim                    nearby_sources                
     j_add_spectra                 nearest_source                
     j_collect_spectra             pointing_plot                 
     j_comb_dsp_spectra            qidsrcs                       
     j_cor2raw                     read_catalog                  
     j_gain_values                 srcl2txt                      
     j_get_arc_events              timeconv                      
     j_get_events                  upd_ancrfile                  
     j_get_pi_ebds                 validate_swid_list            
     j_get_point_info_for_swid     

************************************************************/

write,"You are using jemx.i-2.5";

//+ #include "kfits.i"
//+ #include "mfits.i"
//+ #include "idlx.i"
//+ #include "basic.i"

/* Function crab_count_rate */

func crab_count_rate( ener1, ener2, gain= )
/* DOCUMENT rate = crab_count_rate( ener1, ener2, gain= )

    where the energies are given in keV.
    The gain should be given in PHA/keV - the default value is 20.0

   2007-06-14/NJW

*/
{

   if( is_void(gain) ) gain = 20.0;
   eb = spanl( ener1, ener2, 301 );
   de = eb(2:0) - eb(1:-1);
   e = eb(1:-1);
   basdir = get_env("IC_BASE")+"/imod_grp";
   imodfiles = file_search("jmx1_imod_grp_????.fits", basdir );
   imodfiles = imodfiles(sort(imodfiles));
   imodfile = imodfiles(0); // Choose latest

   //   Get the quantum efficiency

   eqeff = rdfitscol(imodfile+"[JMX1-QEFF-MOD]","ENERGY");
   qeff  = rdfitscol(imodfile+"[JMX1-QEFF-MOD]","QUANTEFF");

   //   Get the thermal foil transmission

   efoil = rdfitscol(imodfile+"[JMX1-FOIL-MOD]","ENERGY");
   foil  = rdfitscol(imodfile+"[JMX1-FOIL-MOD]","TRANSCOEF");

   //   Get the electronic efficiency

   peeff = rdfitscol(imodfile+"[JMX1-EEFF-MOD]","LINPHA");
   eeff  = rdfitscol(imodfile+"[JMX1-EEFF-MOD]","ELEC_EFF");

   q_area = 80. * interp( qeff, eqeff, e ) * interp( foil, efoil, e ) \
                * interp( eeff, peeff, e*gain );

   flux = 9.7 * e^(-2.1); // photons/cm2/s/keV

   return sum(flux*q_area*de);

}

/* Function get_gain_for_swid */

func get_gain_for_swid( jemxNum, swid )
/* DOCUMENT gain = get_gain_for_swid( jemxNum, swid )

   looks up the gain value from /r6/jemx/pointings/pointings_RRRR.fits

   2008-08-13/NJW
*/
{
   if( jemxNum != 1 && jemxNum != 2 ) {
      write,"J_READ_GAIN_FOR_SWID: Bad JEMX instrument number";
      return [];
   }
   colname = jemxNum == 1 ? "gain_j1" : "gain_j2";

   if( typeof(swid) != "string" ) {
      write,"J_READ_GAIN_FOR_SWID: Bad SWID indication";
      return [];
   }

   nswids = numberof(swid);
   len = strlen(swid) - 12;
   if( anyof(len) ) {
      write,"J_READ_GAIN_FOR_SWID: Bad SWID string length";
      return [];
   }

   if( nswids > 1 ) {
      isort = sort(swid);
      swid = swid(isort);
   }

   revol = strpart(swid,1:4);
   u = uniq(revol);
   nu = numberof(u);
   up = nswids == 1 ? u : shift(u-1,1);
   up(0) = nswids;

   res = array(double, nswids );

   for(i = 1; i <= nu; i++ ) {
      rev = revol(u(i));
      filename = "pointings_"+rev+".fits";
      pswids = rdfitscol("/r6/jemx/pointings/"+filename+"+1", "swid");
      gain = rdfitscol("/r6/jemx/pointings/"+filename+"+1", colname);
      for(j = u(i); j <= up(i); j++ ) {
         w = where( swid(j) == pswids );
         if( numberof(w) != 1 ) {
            write,format="Failed to find gain for SWID: %s\n", swid(j);
            gainx = -1.;
         } else {
            gainx = gain(w(1));
         }
         res(j) = gainx;
      }
   }

   if( nswids > 1 ) {
 // Returns values in same order as the input
      return res(sort(isort));
   } else {
      return res(1);
   }

}

/* Function get_exposure_for_swid */

func get_exposure_for_swid( jemxNum, swid )
/* DOCUMENT exposure = get_exposure_for_swid( jemxNum, swid )

   looks up the exposure value from /r6/jemx/pointings/pointings_RRRR.fits

   2009-11-23/NJW, cloned from get_gain_for_swid
*/
{
   if( jemxNum != 1 && jemxNum != 2 ) {
      write,"GET_EXPOSURE_FOR_SWID: Bad JEMX instrument number";
      return [];
   }
   colname = jemxNum == 1 ? "exposure_j1" : "exposure_j2";

   if( typeof(swid) != "string" ) {
      write,"GET_EXPOSURE_FOR_SWID: Bad SWID indication";
      return [];
   }

   nswids = numberof(swid);
   len = strlen(swid) - 12;
   if( anyof(len) ) {
      write,"GET_EXPOSURE_FOR_SWID: Bad SWID string length";
      return [];
   }

   if( nswids > 1 ) {
      isort = sort(swid);
      swid = swid(isort);
   }

   revol = strpart(swid,1:4);
   u = uniq(revol);
   nu = numberof(u);
   up = nswids == 1 ? u : shift(u-1,1);
   up(0) = nswids;

   res = array(double, nswids );

   for(i = 1; i <= nu; i++ ) {
      rev = revol(u(i));
      filename = "pointings_"+rev+".fits";
      pswids = rdfitscol("/r6/jemx/pointings/"+filename+"+1", "swid");
      exposure = rdfitscol("/r6/jemx/pointings/"+filename+"+1", colname);
      for(j = u(i); j <= up(i); j++ ) {
         w = where( swid(j) == pswids );
         if( numberof(w) != 1 ) {
            write,format="Failed to find exposure for SWID: %s\n", swid(j);
            exposurex = -1.;
         } else {
            exposurex = exposure(w(1));
         }
         res(j) = exposurex;
      }
   }

   if( nswids > 1 ) {
 // Returns values in same order as the input
      return res(sort(isort));
   } else {
      return res(1);
   }

}

/* Function find_swid_radec */

func find_swid_radec( ra0, dec0, rad1, .., offax=, rev=, tstart=, \
                      tstop=, list=, nof=, silent=, lst=, gal= )
/* DOCUMENT list = find_swid_radec( ra0, dec0, rad1[, rad2][, offax=]
                       [,rev=][, tstart=][, tstop=][, list=]
                       [,nof=][, silent=][, lst=][, gal=] )

   Find the INTEGRAL SWIDs where the pointing is less than 'rad1'
   away from (ra0,dec0) or - if 'rad2' is greater than rad1 - greater than 'rad1'
   and less than 'rad2' away

    Ca. 2003-05/NJW
    2006-10-02/NJW  translated to Yorick language
    2007-11-16/NJW  updated with 'gal' keyword

     If rad2 (in degrees) is not given or less than rad1 then the
     pointings with distance < rad1 (in degrees) will be presented
     else the pointings with distance rad1 < dist < rad2
     will be presented

   Keywords:
             offax:  When set the result will be sorted
                     by increasing off-axis angle
             rev:    Either scalar integer or 2 element integer
                     array with min and max revolution number
             tstart: Time in IJD for start of interval
             tstop:  Time in IJD for end of interval
             list :  Makes returned list a list of SWIDs (default)
             lst  :  Makes returned list a list of SWIDs in jemx.lst format
                         (overrides setting of 'list')
             nof  :  Flag to avoid file writing
             gal  :  Flag to interpret input coordinates as galactic
*/
{

   local swid, ra, dec, posangle, ut, ijd, telapse, mode1, mode2;

   if( is_void(rad1) ) {
      write,"Syntax: list = find_swid_radec(ra,dec,rad1[,rad2], keywords... )";
      return [];
   }
   //
   //  Initialize
   //
   if( is_void(silent) ) silent = 0;
   first = 1;
   tbegin = is_void( tstart ) ? 0.0 : tstart;
   // if( tstart ) { tbegin = tstart; } else { tbegin = 0.0; }
   tend = is_void( tstop ) ? 1.0e9 : tstop;
   // if( tstop ) { tend = tstop; } else { tend = 1.0e9; }
   ra0 = double(ra0);
   dec0 = double(dec0);
   rad1 = double(rad1);
   if( gal ) {
      lon0 = ra0;
      lat0 = dec0;
      radec0 = equatorial( ra0, dec0 );
      ra0 = radec0(1);
      dec0 = radec0(2);
   } else {
      galac0 = galactic( ra0, dec0 );
      lon0 = galac0(1);
      lat0 = galac0(2);
   }

   rad2 = 0.0;
   if( more_args() ) {
      rad2 = double(next_arg());
   }
   //
   // Get list of pointing files
   //
   base = get_env("J_POINTINGS");

   if( numberof(rev) ) {
      if( typeof(rev) == "string" ) {
         revarr = str2arr( rev );
      } else {
         if( numberof( rev ) == 2 ) {
            revarr = indgen(long(rev(2)-rev(1))+1) + long(rev(1)) - 1;
         } else {
            revarr = long(rev)
         }
      }
      nrev = numberof(revarr);
      for( i = 1; i <= nrev; i++ ) {
         revstr = swrite(revarr(i),format="%4.4i");
         tmp = base+"/pointings_"+revstr+"p.dat";
         if( !silent ) write,tmp;
         ybase = base+"/ysav"+swrite(revarr(i)/100,format="%02i/");
         ytmp = ybase+"pointings_"+revstr+"p.ysav";
         if( !silent ) write,ytmp;
         if( i == 1 ) {
            pf_list = tmp;
            ypf_list = ytmp;
         } else {
            grow,pf_list,tmp;
            grow,ypf_list,ytmp;
         }
      }
   } else {
      pf_list = file_search("pointings_*p.dat", base);
      ypf_list = pf_list;
      npf_list = numberof(pf_list);
      for( i = 1; i <= npf_list; i++ ) {
         pos = strpos( pf_list(i),"_" );
         revstra = strpart(pf_list(i), pos+1:pos+4 );
         drevstra = strpart(pf_list(i),pos+1:pos+2);
         ybase = base+"/ysav"+drevstra;
         ytmp = ybase+"/pointings_"+revstra+"p.ysav";
         ypf_list(i) = ytmp;
      }
   }
   npf_list = numberof(pf_list);
   if( npf_list == 0 ) {
      if(!silent) write,"find_swid_radec error: no pointing files of required kind found";
      return [];
   }

   if( !nof ) {

      // Open output file

      outfilename = get_next_filename("find_swid_radec_???.dat");
      fout = open(outfilename,"w");
      n = write(fout,format="%s\n","// Results from find_swid_radec");
      n = write(fout,format="// created %s\n", ndate(3));
      n = write(fout,format="// ra0  = %7.3f; deg\n", ra0);
      n = write(fout,format="// dec0 = %7.3f; deg\n", dec0);
      n = write(fout,format="// lon0 = %7.3f; deg\n", lon0);
      n = write(fout,format="// lat0 = %7.3f; deg\n", lat0);
      if( rad2 < rad1 ) {
         n = write(fout,format="// radius = %7.3f; deg\n", rad1);
      } else {
         n = write(fout,format="%s\n","// selection in annulus");
         n = write(fout,format="// rad1 = %7.3f; deg\n", rad1);
         n = write(fout,format="// rad2 = %7.3f; deg\n", rad2);
      }
      if( tstart ) {
         n = write(fout,format="// tstart = %14.8f; IJD\n", tstart);
      }
      if( tstop ) {
         n = write(fout,format="// tstop = %14.8f; IJD\n", tstop);
      }
      if( numberof(rev) ) {
         if( nrev == 1 ) {
            n = write(fout,format="// rev_begin = %4i\n", revarr(1));
            n = write(fout,format="// rev_end   = %4i\n", revarr(1));
         } else {
            n = write(fout,format="// rev_begin = %4i\n", revarr(1));
            n = write(fout,format="// rev_end   = %4i\n", revarr(0));
         }
      }

   }

   ntotal = 0;
   for( ipf_list = 1; ipf_list <= npf_list; ipf_list++ ) {

      if( file_test(ypf_list(ipf_list)) ) {
         if( !silent ) write,"Reading binary file "+ypf_list(ipf_list);
         bfile = openb( ypf_list(ipf_list) );
         restore,bfile, swid, ra, dec, posangle, ut, ijd, telapse, \
                     mode1, mode2;
         close, bfile;
      } else {
         if( !silent ) write,"Reading usual text file "+pf_list(ipf_list);
         if( ! file_test(pf_list(ipf_list)) ) {
            if( !silent ) write,pf_list(ipf_list)+" was not found";
            continue;
         }
      /*
       * swid = rscol( pf_list(ipf_list),1, str=1, silent=1);
       * ra = rscol( pf_list(ipf_list), 2, silent=1);
       * dec = rscol( pf_list(ipf_list), 3, silent=1);
       * posangle = rscol( pf_list(ipf_list), 4, silent=1);
       * ut = rscol( pf_list(ipf_list), 5, str=1, silent=1);
       * ijd = rscol( pf_list(ipf_list), 6, silent=1);
       * telapse = rscol( pf_list(ipf_list),7, silent=1);
       * mode1 = rscol( pf_list(ipf_list), 8, str=1, silent=1);
       * mode2 = rscol( pf_list(ipf_list), 9, str=1, silent=1);
       */

         rstab,pf_list(ipf_list),9,swid,ra,dec,posangle,ut,ijd,telapse, \
              mode1, mode2,typ="sfffsffss",silent=1;

         bfile = createb( ypf_list(ipf_list) );
         save, bfile,  swid, ra, dec, posangle, ut, ijd, telapse, \
                 mode1, mode2;
         close, bfile;
      }

      dist = arcdist(ra0, dec0, ra, dec);

      if( abs(rad2) < 1.e-10 ) {

         w = where( dist < rad1);
         nw = numberof(w);

      } else {

         w = where( dist > rad1 & dist < rad2);
         nw = numberof(w);

      }

      if( nw > 0 ) {

         if( first ) {
            first = 0;
            swid_all = swid(w);
            ra_all = ra(w);
            dec_all = dec(w);
            posangle_all = posangle(w);
            ut_all = ut(w);
            ijd_all = ijd(w);
            telapse_all = telapse(w);
            mode1_all = mode1(w);
            mode2_all = mode2(w);
            dist_all = dist(w);
         } else {
            grow,swid_all,swid(w);
            grow,ra_all,ra(w);
            grow,dec_all,dec(w);
            grow,posangle_all,posangle(w);
            grow,ut_all,ut(w);
            grow,ijd_all,ijd(w);
            grow,telapse_all,telapse(w);
            grow,mode1_all,mode1(w);
            grow,mode2_all,mode2(w);
            grow,dist_all,dist(w);
         }

         ntotal += nw;

      }

   }
   if( ntotal == 0 ) {
      if(!silent) write,"Sorry, no pointings found!";
      return [];
   }

   if( offax ) {
      is = sort(dist_all);
      swid_all = swid_all(is);
      ra_all = ra_all(is);
      dec_all = dec_all(is);
      posangle_all = posangle_all(is);
      ut_all = ut_all(is);
      ijd_all = ijd_all(is);
      telapse_all = telapse_all(is);
      mode1_all = mode1_all(is);
      mode2_all = mode2_all(is);
      dist_all = dist_all(is);
   }

   noutput = 0;
   list = "";
   list_list = [];
   expo_tot = 0.0;
   for( i = 1; i <= ntotal; i++ ) {
      // apply the time selection
      if( ijd_all(i) > tbegin && ijd_all(i) < tend ) {
         //+ eff_factor = 1. - dist_all(i)/6.4;
         eff_factor = 1. - dist_all(i)/5.0;
         expo_contrib = eff_factor > 0.0 ? telapse_all(i) * eff_factor : 0.0;
         expo_tot += expo_contrib;
         grow,list_list,swid_all(i);
         if( !nof) {
            write,fout,format="%s%10.4f%9.4f%9.3f  %s%10.3f%6.0f  %s  %s %8.2f %7.0f\n",
            swid_all(i),ra_all(i),dec_all(i),posangle_all(i),
            ut_all(i),ijd_all(i),telapse_all(i),
            mode1_all(i),mode2_all(i),dist_all(i), expo_contrib;
         }
         noutput++;
      }
   }

   lst_list = array("",ntotal);
   for( i = 1; i <= ntotal; i++ ) {
      lst_list(i) = "./scw/"+strpart(swid_all(i),1:4)+"/"+swid_all(i)+".001/swg.fits[1]";
   }

   if( !nof ) {
      write,fout,format="//\n// Total exposure for selected position is %14.5e s\n", \
                expo_tot;
      close,fout;
   }

   if( !silent ) {
      write,format="Found %i SWIDs in selected revolutions\n", ntotal;
      if( noutput == 1 ) {
         write,format="%i has been selected by time\n", noutput;
      } else {
         write,format="%i have been selected by time\n", noutput;
      }
      write,format="Total exposure for selected position is %14.4e s\n", expo_tot;
      if( !nof ) write,"Output is directed to "+outfilename;

   }

   if( !is_void(lst) ) { return lst_list; } else {return list_list;}

}


/* Function j_get_sloc_res_sources */

func j_get_sloc_res_sources( dol_list, outfile=, comb=, silent= )
/* DOCUMENT j_get_sloc_res_sources, dol_list, outfile=, comb=, silent=

   Accepts a list of sloc_res DOLs and will extract the source information
   Keyword 'outfile' is the output FITS filename (default "resfile.fits").
   Keyword 'comb' will choose between all, combined or exclude combined:
            comb = 0 or not given : include all
            comb = 1   :  include only combined results
            comb = -1  :  exclude combined results

   If dol_list is just a file list then 1. extension will be assumed.

   The SLOC-RES DS is a result from j_ima_src_locator

   2006-11-13/NJW  Cloned from j_get_srcl_res_sources

*/
{

   if( is_void(outfile) ) outfile = "resfile.fits";
   chat = is_void(silent);
   if( is_void(comb) ) comb = 0;
   if( comb > 0 ) comb = 1;
   if( comb < 0 ) comb = -1;
   kwds_init;
   if( comb == 0 ) {
      kwds_set,"COMMENT","Both individual results and combinations of sources";
   } else if( comb == 1 ) {
      kwds_set,"COMMENT","Only combined source results are included";
   } else {
      kwds_set,"COMMENT","Combined source results are excluded";
   }


   name_arr = [];
   // sourceid_arr = [];
   swid_arr = [];
   instr_arr = [];
   ra_arr = [];
   dec_arr = [];
   err_rad_arr = [];
   ra_cat_arr = [];
   dec_cat_arr = [];
   detsig_arr = [];
   sigma_arr = [];
   kval_arr = [];
   chi2_arr = [];
   // offaxis_arr = [];
   // cosy_arr = [];
   // cosz_arr = [];
   // flux_arr = [];
   peaksize_arr = [];
   e_min_arr = [];
   e_max_arr = [];
   // ra_scx_arr = [];
   // dec_scx_arr = [];
   // posang_arr = [];
   dol_arr = [];
   swid_nosrcs = [];
   tot_nrows = 0;

   nfiles = numberof(dol_list);

   for( i = 1; i <= nfiles; i++ ) {

      dolres = dol_list(i);
      get_exten_no, dolres, fileres, extres;
     /*  apply default extension if filename is given */
      if( extres == 0 ) {
         extres = 1;
         dolres = dolres+"+1";
      }
      hdr = headfits( dolres );
      if( chat ) write,format="dolres: %s\n", dolres;

     /*
      * First try to get SWID from header, then
      * from file name - else give up
      */

      swid = fxpar(hdr,"SWID");
      if( typeof(swid) != "string" ) {
         pick_swid_str,dolres,swid;
         if( typeof( swid ) != "string" ) swid = "000000000000";
      } else if( swid(1) == "String" ) {
         pick_swid_str,dolres,swid;
         if( typeof( swid ) != "string" ) swid = "000000000000";
      }
      swid = swid(1);
     /*
      * First try to get INSTRUME from header, then
      * from file name - else give up
      */
      instrin = fxpar(hdr,"INSTRUME");
      if( typeof(instrin) != "string" ) {
         if( strpos(fileres,"jmx1",1) > 0 ) instrin = "JMX1";
         if( strpos(fileres,"JMX1",1) > 0 ) instrin = "JMX1";
         if( strpos(fileres,"jmx2",1) > 0 ) instrin = "JMX2";
         if( strpos(fileres,"JMX2",1) > 0 ) instrin = "JMX2";
         if( typeof(instrin) != "string" ) instrin = "XXXX";
      } else if( instrin(1) == "String" ) {
         instrin = "XXXX";
      }

      nebin = fxpar(hdr,"EBIN_NUM");
      if( is_void(nebin) ) nebin = 1;
      if( typeof(nebin) == "string" ) nebin = 1;

      rain = rdfitscol(dolres,"RA_OBJ",silent=silent);
      nrows = numberof(rain);
      //tot_nrows += nrows;
      if( chat ) write,format="%i rows found\n", nrows;
      if( nrows >= 1 ) {

         decin = rdfitscol(dolres,"DEC_OBJ");
         err_radin = rdfitscol(dolres,"ERR_RAD");
         ra_catin = rdfitscol(dolres,"RA_CAT");
         if( is_void(ra_catin) ) ra_catin = float(rain*0.0 - 99.0);
         dec_catin = rdfitscol(dolres,"DEC_CAT");
         if( is_void(dec_catin) ) dec_catin = float(decin*0.0 - 99.0);
         detsigin = rdfitscol(dolres,"DETSIG");
         namein = rdfitscol(dolres,"NAME");
         // sourceidin = rdfitscol(dolres,"SOURCE_ID");
         // fluxin = rdfitscol(dolres,"FLUX");
         peaksizein = rdfitscol(dolres,"PEAKSIZE");
         sigmain = rdfitscol(dolres,"SIGMA");
         selw = where( sigmain == 0.0 );
         selm = where( sigmain > 0.0 );
         kvalin = rdfitscol(dolres,"KVAL");
         chi2in = rdfitscol(dolres,"CHI2");
         // cosy = rdfitscol(dolres,"COSY_JMX");
         // cosz = rdfitscol(dolres,"COSZ_JMX");
         // fluxin = transpose(fluxin(,1:nebin));
         e_minin = rdfitscol(dolres,"E_MIN");
         e_maxin = rdfitscol(dolres,"E_MAX");

         if( comb == 1 ) {
            nr = numberof(selw);
            tot_nrows += nr;
            if( nr > 0 ) {
               grow, swid_arr, array(swid, nr);
               grow, instr_arr, array(instrin, nr);
               grow, name_arr, namein(selw);
               grow, ra_arr, rain(selw);
               grow, dec_arr, decin(selw);
               grow, err_rad_arr, err_radin(selw);
               grow, ra_cat_arr, ra_catin(selw);
               grow, dec_cat_arr, dec_catin(selw);
               grow, detsig_arr, detsigin(selw);
               grow, peaksize_arr, peaksizein(selw);
               grow, sigma_arr, sigmain(selw);
               grow, kval_arr, kvalin(selw);
               grow, chi2_arr, chi2in(selw);
               grow, e_min_arr, e_minin(1,selw);
               grow, e_max_arr, e_maxin(1,selw);
               grow, dol_arr, array(dolres, nr);
            }
         } else if( comb == -1 ) {
            nr = numberof(selm);
            tot_nrows += nr;
            if( nr > 0 ) {
               grow, swid_arr, array(swid, nr);
               grow, instr_arr, array(instrin, nr);
               grow, name_arr, namein(selm);
               grow, ra_arr, rain(selm);
               grow, dec_arr, decin(selm);
               grow, err_rad_arr, err_radin(selm);
               grow, ra_cat_arr, ra_catin(selm);
               grow, dec_cat_arr, dec_catin(selm);
               grow, detsig_arr, detsigin(selm);
               grow, peaksize_arr, peaksizein(selm);
               grow, sigma_arr, sigmain(selm);
               grow, kval_arr, kvalin(selm);
               grow, chi2_arr, chi2in(selm);
               grow, e_min_arr, e_minin(1,selm);
               grow, e_max_arr, e_maxin(1,selm);
               grow, dol_arr, array(dolres, nr);
            }
         } else {
            tot_nrows += nrows;
            grow, swid_arr, array(swid, nrows);
            grow, instr_arr, array(instrin, nrows);
            grow, name_arr, namein;
            grow, ra_arr, rain;
            grow, dec_arr, decin;
            grow, err_rad_arr, err_radin;
            grow, ra_cat_arr, ra_catin;
            grow, dec_cat_arr, dec_catin;
            grow, detsig_arr, detsigin;
            grow, peaksize_arr, peaksizein;
            grow, sigma_arr, sigmain;
            grow, kval_arr, kvalin;
            grow, chi2_arr, chi2in;
            grow, e_min_arr, e_minin(1,);
            grow, e_max_arr, e_maxin(1,);
            grow, dol_arr, array(dolres, nrows);
         }

      } else {
         if( chat ) write,format="No sources found in %s\n", dolres;
         grow, swid_nosrcs, swid;
      }
      if( chat ) write,format="----------------------------%s\n","";

   }

   if( tot_nrows > 0 ) {
      wrmfitscols,outfile,"SWID",swid_arr,"NAME",name_arr, \
             "RA_OBJ",ra_arr,"DEC_OBJ",dec_arr, "ERR_RAD", err_rad_arr, \
             "RA_CAT",ra_cat_arr,"DEC_CAT",dec_cat_arr, \
             "DETSIG",detsig_arr, \
             "PEAKSIZE",peaksize_arr,"E_MIN",e_min_arr, \
             "E_MAX",e_max_arr, "SIGMA", sigma_arr, "KVAL", kval_arr, \
             "CHI2", chi2_arr, \
             "INSTRUME",instr_arr,\
             "DOL_SRCL",dol_arr,clobber=1;
      if( chat ) write,format="Information on %i sources is found in: %s\n", tot_nrows, outfile;
   } else {
      if( chat ) write,format="No sources found at all%s\n","";
   }
   nsno = numberof(swid_nosrcs);
   if( nsno > 0 ) {
      wrmfitscols,"not_"+outfile,"SWID",swid_nosrcs,clobber=1;
      if( chat ) write,format="The %i SWIDs for empty fields are found in: %s\n", nsno, "not_"+outfile;
   } else {
      if( chat ) write,format="There were sources in all SLOC-RES files%s\n","";
   }

}




/* Function j_get_srcl_res_sources */

func j_get_srcl_res_sources( dol_list, outfile=, silent= )
/* DOCUMENT j_get_srcl_res_sources, dol_list, outfile=, silent=

   Accepts a list of srcl_res DOLs and will extract the source information
   Keyword 'outfile' is the output FITS filename (default "resfile.fits").
   If dol_list is just a file list then 1. extension will be assumed.

   This version produces a row for each energy interval which means that
   the same source from the same SWID is given several times if there are
   more than one energy interval.
   The advantage is that SRCL-RES files with different number of energy
   intervals can be combined.

   SEE ALSO: j_get_srcl_res_sources_a

   NJW/2004-01-09
   2006-08-16/NJW  Converted to yorick
   2006-08-22/NJW  Updated for better handling of SWID, INSTRUME
   2006-11-13/NJW  Updated for including E_MIN & E_MAX
   2006-04-27/NJW  Updated for proper handling of auxiliary 'not_' file

*/
{

   if( is_void(outfile) ) outfile = "resfile.fits";
   chat = is_void(silent); // chattiness


   name_arr = [];
   sourceid_arr = [];
   swid_arr = [];
   instr_arr = [];
   ra_arr = [];
   dec_arr = [];
   err_rad_arr = [];
   detsig_arr = [];
   offaxis_arr = [];
   cosy_arr = [];
   cosz_arr = [];
   flux_arr = [];
   flux_err_arr = [];
   e_min_arr = [];
   e_max_arr = [];
   ra_scx_arr = [];
   dec_scx_arr = [];
   posang_arr = [];
   dol_arr = [];
   swid_nosrcs = [];
   tot_nrows = 0;

   nfiles = numberof(dol_list);

   for( i = 1; i <= nfiles; i++ ) {

      dolres = dol_list(i);
      get_exten_no, dolres, fileres, extres;
     /*  apply default extension if filename is given */
      if( extres == 0 ) {
         extres = 1;
         dolres = dolres+"+1";
      }
      hdr = headfits( dolres );
      if( chat ) write,format="dolres: %s\n", dolres;

     /*
      * First try to get SWID from header, then
      * from file name - else give up
      */

      swidx = fxpar(hdr,"SWID");
      if( typeof(swidx) != "string" ) {
         pick_swid_str,dolres,swidx;
         if( typeof( swidx ) != "string" ) swidx = "000000000000";
      } else if( swidx(1) == "String" ) {
         pick_swid_str,dolres,swidx;
         if( typeof( swidx ) != "string" ) swidx = "000000000000";
      }
      swidx = swidx(1);
      if( chat ) write,format="swid: %s\n", swidx;
     /*
      * First try to get INSTRUME from header, then
      * from file name - else give up
      */
      instrin = fxpar(hdr,"INSTRUME");
      if( typeof(instrin) != "string" ) {
         if( strpos(fileres,"jmx1",1) > 0 ) instrin = "JMX1";
         if( strpos(fileres,"JMX1",1) > 0 ) instrin = "JMX1";
         if( strpos(fileres,"jmx2",1) > 0 ) instrin = "JMX2";
         if( strpos(fileres,"JMX2",1) > 0 ) instrin = "JMX2";
         if( typeof(instrin) != "string" ) instrin = "XXXX";
      }

      nebin = fxpar(hdr,"EBIN_NUM");
      if( is_void(nebin) || typeof(nebin) == "string" ) nebin = 1;

      rain = rdfitscol(dolres,"RA_OBJ",silent=silent);
      nrows = numberof(rain);
      tot_nrows += nrows;
      if( chat ) write,format="%i rows found\n", nrows;
      if( nrows >= 1 ) {

         decin = rdfitscol(dolres,"DEC_OBJ",silent=silent);

         // get offaxis angle
         status = get_pointing_for_swid(swidx,ra_scx,dec_scx,posang,silent=silent);
         if( status == 0 ) {
            offaxis = arcdist( rain, decin, ra_scx, dec_scx);
         } else {
            write,"Cannot get pointing for swid: "+swidx;
            offaxis = 7.0;
         }
         err_radin = rdfitscol(dolres,"ERR_RAD",silent=silent);
         detsigin = rdfitscol(dolres,"DETSIG",silent=silent);
         namein = rdfitscol(dolres,"NAME",silent=silent);
         sourceidin = rdfitscol(dolres,"SOURCE_ID",silent=silent);
         fluxin = rdfitscol(dolres,"FLUX",silent=silent);
         fluxerrin = rdfitscol(dolres,"FLUX_ERR",silent=silent);
         cosy = rdfitscol(dolres,"COSY_JMX",silent=silent);
         cosz = rdfitscol(dolres,"COSZ_JMX",silent=silent);
         e_minin = rdfitscol(dolres,"E_MIN",silent=silent);
         e_maxin = rdfitscol(dolres,"E_MAX",silent=silent);

         for( iebin = 1; iebin <= nebin; iebin++ ) {
            grow, swid_arr, array(swidx, nrows);
            grow, instr_arr, array(instrin, nrows);
            grow, name_arr, namein;
            grow, sourceid_arr, sourceidin;
            grow, ra_arr, rain;
            grow, dec_arr, decin;
            grow, err_rad_arr, err_radin;
            grow, detsig_arr, detsigin;
            grow, offaxis_arr, offaxis;
            grow, cosy_arr, cosy*100;
            grow, cosz_arr, cosz*100;
            grow, flux_arr, fluxin(iebin,);
            grow, flux_err_arr, fluxerrin(iebin,);
            grow, e_min_arr, e_minin(iebin,);
            grow, e_max_arr, e_maxin(iebin,);
            grow, ra_scx_arr, array(ra_scx, nrows);
            grow, dec_scx_arr, array(dec_scx, nrows);
            grow, posang_arr, array(posang, nrows);
            grow, dol_arr, array(dolres, nrows);
         }

      } else {
         if( chat ) write,format="No sources found in %s\n", dolres;
         if( chat ) write,format="grow swid_nosrcs with swid: %s\n", swidx;
         grow, swid_nosrcs, swidx;
      }
      if( chat ) write,format="----------------------------%s\n","";

   }

   kwds_init;
   kwds_set,"EXTNAME","COMB-SRCL-RES","Name of extension";
   kwds_set,"DATE", ndate(3),"Date/time of creation";
   kwds_set,"ORIGIN","j_get_srcl_res_sources","Yorick program";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible for this file";
   kwds_set,"TELESCOP","INTEGRAL","Name of mission";
   kwds_set,"INSTRUME","JEMX","Recorded the data";
   kwds_set,"EBIN_NUM",nebin,"Number of energy bins";

   if( tot_nrows > 0 ) {
      wrmfitscols,outfile,"SWID",swid_arr,"SOURCE_ID",sourceid_arr,"NAME",name_arr, \
             "RA_OBJ",ra_arr,"DEC_OBJ",dec_arr, "ERR_RAD", err_rad_arr, \
             "DETSIG",detsig_arr,"OFFAXIS",offaxis_arr, "COSY_JMX",cosy_arr, \
             "COSZ_JMX",cosz_arr,"FLUX",flux_arr,"FLUX_ERR", flux_err_arr, "E_MIN",e_min_arr, \
             "E_MAX",e_max_arr,"RA_SCX",ra_scx_arr, \
             "DEC_SCX",dec_scx_arr,"ROLL",posang_arr,"INSTRUME",instr_arr,\
             "DOL_SRCL",dol_arr,clobber=1;
      if( chat ) write,format="Information on %i sources is found in: %s\n", tot_nrows, outfile;
   } else {
      if( chat ) write,format="No sources found at all%s\n","";
   }
   nsno = numberof(swid_nosrcs);
   if( nsno > 0 ) {
      splitfname, outfile, dir_outfile, name_outfile;
      wrmfitscols,dir_outfile+"/not_"+name_outfile,"SWID",swid_nosrcs,clobber=1;
      if( chat ) write,format="The %i SWIDs for empty fields are found in: %s\n", nsno, \
            dir_outfile+"/not_"+name_outfile;
   } else {
      if( chat ) write,format="There were sources in all SRCL-RES files%s\n","";
   }

}


/* Function j_get_srcl_res_sources_a */

func j_get_srcl_res_sources_a( dol_list, srcname=, outfile=, silent= )
/* DOCUMENT j_get_srcl_res_sources_a, dol_list, srcname=, outfile=, silent=

   Accepts a list of srcl_res DOLs and will extract the source information
   Keyword 'srcname' is the source name (exact match) to be given if results
   from a specific source are requested.
   Keyword 'outfile' is the output FITS filename (default "resfile.fits").
   If dol_list is just a file list then 1. extension will be assumed.

   This version reproduces one row per source per SWID. The FLUX etc.
   columns are vector columns. It might fail if the number of energy
   intervals is not the same for all SRCL-RES tables given in the list.

   NJW/2004-01-09
   2006-08-16/NJW  Converted to yorick
   2006-08-22/NJW  Updated for better handling of SWID, INSTRUME
   2006-11-13/NJW  Updated for including E_MIN & E_MAX
   2007-04-27/NJW  Changed to give one row per source
   2008-06-24/NJW  Updated to include RA_CAT and DEC_CAT
   2009-07-22/NJW  Updated to include CLASS

*/
{

   if( is_void(outfile) ) outfile = "resfile.fits";
   chat = is_void(silent);


   name_arr = [];
   sourceid_arr = [];
   swid_arr = [];
   instr_arr = [];
   ra_arr = [];
   dec_arr = [];
   racat_arr = [];
   deccat_arr = [];
   class_arr = [];
   err_rad_arr = [];
   detsig_arr = [];
   offaxis_arr = [];
   cosy_arr = [];
   cosz_arr = [];
   flux_arr = [];
   flux_err_arr = [];
   e_min_arr = [];
   e_max_arr = [];
   ra_scx_arr = [];
   dec_scx_arr = [];
   posang_arr = [];
   dol_arr = [];
   swid_nosrcs = [];
   tot_nrows = 0;

   nfiles = numberof(dol_list);

   for( i = 1; i <= nfiles; i++ ) {

      dolres = dol_list(i);
      get_exten_no, dolres, fileres, extres;
     /*  apply default extension if filename is given */
      if( extres == 0 ) {
         extres = 1;
         dolres = dolres+"+1";
      }
      hdr = headfits( dolres );
      if( chat ) write,format="dolres: %s\n", dolres;

     /*
      * First try to get SWID from header, then
      * from file name - else give up
      */

      swidx = fxpar(hdr,"SWID");
      if( typeof(swidx) != "string" ) {
         pick_swid_str,dolres,swidx;
         if( typeof( swidx ) != "string" ) swidx = "000000000000";
      } else if( swidx(1) == "String" ) {
         pick_swid_str,dolres,swidx;
         if( typeof( swidx ) != "string" ) swidx = "000000000000";
      }
      swidx = swidx(1);
      if( chat ) write,format="swid: %s\n", swidx;
     /*
      * First try to get INSTRUME from header, then
      * from file name - else give up
      */
      instrin = fxpar(hdr,"INSTRUME");
      if( typeof(instrin) != "string" ) {
         if( strpos(fileres,"jmx1",1) > 0 ) instrin = "JMX1";
         if( strpos(fileres,"JMX1",1) > 0 ) instrin = "JMX1";
         if( strpos(fileres,"jmx2",1) > 0 ) instrin = "JMX2";
         if( strpos(fileres,"JMX2",1) > 0 ) instrin = "JMX2";
         if( typeof(instrin) != "string" ) instrin = "XXXX";
      }

      nebin = fxpar(hdr,"EBIN_NUM");
      if( is_void(nebin) || typeof(nebin) == "string" ) nebin = 1;

      rain = rdfitscol(dolres,"RA_OBJ",silent=silent);
      nrows = numberof(rain);
      tot_nrows += nrows;
      if( chat ) write,format="%i rows found\n", nrows;
      if( nrows >= 1 ) {

         decin = rdfitscol(dolres,"DEC_OBJ",silent=silent);
         racatin = rdfitscol(dolres,"RA_CAT",silent=silent);
         deccatin = rdfitscol(dolres,"DEC_CAT",silent=silent);

         // get offaxis angle
         offaxis = array(7.0, nrows);
         if( swidx != "000000000000" ) { // try to get the offaxis angle
            status = get_pointing_for_swid(swidx,ra_scx,dec_scx,posang,silent=silent);
            if( status == 0 ) {
               offaxis = arcdist( rain, decin, ra_scx, dec_scx);
            } else {
               write,"Cannot get pointing for swid: "+swidx;
            }
         }
         err_radin = rdfitscol(dolres,"ERR_RAD",silent=silent);
         detsigin = rdfitscol(dolres,"DETSIG",silent=silent);
         namein = rdfitscol(dolres,"NAME",silent=silent);
         classin = rdfitscol(dolres,"CLASS",silent=silent);
         if( is_void(classin) ) classin = array(0n,nrows);
         w = where(strlen(namein)==0);
         nw = numberof(w); if( nw ) namein(w) = "INPUT ERR";
         sourceidin = rdfitscol(dolres,"SOURCE_ID",silent=silent);
         w = where(strlen(sourceidin)==0);
         nw = numberof(w); if( nw ) sourceidin(w) = "INPUT ERR";
         fluxin = rdfitscol(dolres,"FLUX",silent=silent);
         fluxerrin = rdfitscol(dolres,"FLUX_ERR",silent=silent);
         cosy = rdfitscol(dolres,"COSY_JMX",silent=silent);
         cosz = rdfitscol(dolres,"COSZ_JMX",silent=silent);
         e_minin = rdfitscol(dolres,"E_MIN",silent=silent);
         e_maxin = rdfitscol(dolres,"E_MAX",silent=silent);

         if( numberof(srcname) ) {
            w = where( strtrim(srcname) == strtrim(namein) );
            nrows = numberof(w);
            if( nrows ) {
               rain = rain(w);
               decin = decin(w);
               racatin = racatin(w);
               deccatin = deccatin(w);
               offaxis = offaxis(w);
               err_radin = err_radin(w);
               detsigin = detsigin(w);
               namein = namein(w);
               sourceidin = sourceidin(w);
               fluxin = fluxin(,w);
               fluxerrin = fluxerrin(,w);
               cosy = cosy(w);
               cosz = cosz(w);
               e_minin = e_minin(,w);
               e_maxin = e_maxin(,w);
            } else {
               if( chat ) write,format="%s not found in %s\n", dolres;
            }
         }
         if( nrows ) {
            grow, swid_arr, array(swidx, nrows);
            grow, instr_arr, array(instrin, nrows);
            grow, name_arr, namein;
            grow, sourceid_arr, sourceidin;
            grow, ra_arr, rain;
            grow, dec_arr, decin;
            grow, class_arr, classin;
            grow, racat_arr, racatin;
            grow, deccat_arr, deccatin;
            grow, err_rad_arr, err_radin;
            grow, detsig_arr, detsigin;
            grow, offaxis_arr, offaxis;
            grow, cosy_arr, cosy*100;
            grow, cosz_arr, cosz*100;
            grow, flux_arr, fluxin(1:nebin,);
            grow, flux_err_arr, fluxerrin(1:nebin,);
            grow, e_min_arr, e_minin(1:nebin,);
            grow, e_max_arr, e_maxin(1:nebin,);
            grow, ra_scx_arr, array(ra_scx, nrows);
            grow, dec_scx_arr, array(dec_scx, nrows);
            grow, posang_arr, array(posang, nrows);
            grow, dol_arr, array(dolres, nrows);
         }

      } else {

         if( chat ) write,format="No sources found in %s\n", dolres;
         if( chat ) write,format="grow swid_nosrcs with swid: %s\n", swidx;
         grow, swid_nosrcs, swidx;
      }
      if( chat ) write,format="----------------------------%s\n","";

   }

   kwds_init;
   kwds_set,"EXTNAME","COMB-SRCL-RES","Name of extension";
   kwds_set,"DATE", ndate(3),"Date/time of creation";
   kwds_set,"ORIGIN","j_get_srcl_res_sources_a","Yorick program";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible for this file";
   kwds_set,"TELESCOP","INTEGRAL","Name of mission";
   kwds_set,"INSTRUME","JEMX","Recorded the data";
   kwds_set,"EBIN_NUM",nebin,"Number of energy bins";
   if( tot_nrows > 0 ) {
      name_arr = strpart(name_arr,1:20);
      name_arr(1) = strpadd(name_arr(1),20," "); // make sure that name has length 20
      sourceid_arr = strpart(sourceid_arr,1:16);
      sourceid_arr(1) = strpadd(sourceid_arr(1),16," "); // make sure that source_id has length 16
      dol_arr = strpart(dol_arr,1:128);
      dol_arr(1) = strpadd(dol_arr(1),128," "); // make sure that dol has length 128
      wrmfitscols,outfile,"SWID",swid_arr,"SOURCE_ID",sourceid_arr,"NAME",name_arr, \
             "CLASS", class_arr, \
             "RA_OBJ", ra_arr,"DEC_OBJ", dec_arr, "ERR_RAD", err_rad_arr, \
             "RA_CAT", racat_arr,"DEC_CAT", deccat_arr, \
             "DETSIG", detsig_arr, "OFFAXIS", offaxis_arr, "COSY_JMX", cosy_arr, \
             "COSZ_JMX",cosz_arr,"FLUX",flux_arr,"FLUX_ERR", flux_err_arr, \
             "E_MIN", e_min_arr, "E_MAX", e_max_arr, "RA_SCX", ra_scx_arr, \
             "DEC_SCX", dec_scx_arr,"ROLL",posang_arr,"INSTRUME",instr_arr,\
             "DOL_SRCL",dol_arr,clobber=1;
      if( chat ) write,format="Information on %i sources is found in: %s\n", tot_nrows, outfile;
   } else {
      if( chat ) write,format="No sources found at all%s\n","";
   }
   nsno = numberof(swid_nosrcs);
   if( nsno > 0 ) {
      splitfname, outfile, dir_outfile, name_outfile;
      wrmfitscols,dir_outfile+"/not_"+name_outfile,"SWID",swid_nosrcs,clobber=1;
      if( chat ) write,format="The %i SWIDs for empty fields are found in: %s\n", nsno, \
             dir_outfile+"/not_"+name_outfile;
   } else {
      if( chat ) write,format="There were sources in all SRCL-RES files%s\n","";
   }

}



/* Function get_pointing_for_swid */

func get_pointing_for_swid( swid_in, &ra_scx, &dec_scx, &posang, silent= )
/* DOCUMENT status = get_pointing_for_swid( swid, >ra_scx, >dec_scx, >posang, silent= )

    Get RA and Dec for an INTEGRAL pointing characterized by the SWID by
    scalar argument 'swid' (of type string)
    from the pointing file 'pointings_RRRRp.dat' in directory given by
    the environment variable 'J_POINTINGS'.

    Returns a value of zero for succesful running (a negative value otherwise)
    and ra_scx, dec_scx, posang in the arguments.

    2003-02-05/NJW
    2006-12-28/NJW, updated to look for binary Yorick saved pointings files
*/
{

   local swid, ra, dec, posangle, posang_arr, swid_list;

   status = 0;
   swid_in = swid_in(1); // Make sure it is a scalar

   ra_scx = 0.0;
   dec_scx = 0.0;
   posang = 0.0;

   if( is_void(silent) ) silent = 0;

   if( strlen( swid_in ) != 12 ) {
      write,format="Invalid SWID value%s\n","";
      return -1;
   }
   revstr = strpart( swid_in, 1:4 );
   str = strpart( revstr, 1:2 );
   //+ point_dir = "/r6/jemx/pointings/";
   //+ ypoint_dir = "/r6/jemx/pointings/ysav"+str+"/";
   point_dir = get_env("J_POINTINGS")+"/";
   ypoint_dir = point_dir + "ysav"+str+"/";

   filenam = "pointings_"+revstr+"p.";

// check if data already in memory

   if( 0 == mem_restore( filenam+"ra", ra ) ) {
      if( !silent ) write,"Restoring from memory";
      status = mem_restore( filenam+"dec", dec );
      status = mem_restore( filenam+"swid", swid_list );
      status = mem_restore( filenam+"posang", posang_arr );

// check for existence of binary file

   } else if( file_test( ypoint_dir+filenam+"ysav") ) {

      if( !silent ) write,"Reading binary file "+ypoint_dir+filenam+"ysav";
      bfile = openb( ypoint_dir+filenam+"ysav" );
      restore,bfile, swid, ra, dec, posangle;
      close, bfile;
      swid_list = swid;
      posang_arr = posangle;

   } else {

      filename = filenam + "dat";
      if( !silent ) write,"Reading text file: "+point_dir+filename;
      if( !file_test(point_dir+filename) ) {
         write,format="%s was not found\n", point_dir+filename;
         return -2;
      }

   /*
    * swid_list = rscol(point_dir+filename,1,str=1,silent=1);
    * ra = rscol(point_dir+filename,2,silent=1);
    * dec = rscol(point_dir+filename,3,silent=1);
    * posang_arr = rscol(point_dir+filename,4,silent=1);
    */

      rstab,point_dir+filename,4,swid_list,ra,dec,posang_arr,typ="sfff",silent=1;

   }

// Save to memory to save time in case of repeated calls with same revolution

   if( 0 == mem_save( filenam+"ra", ra, silent=1 ) ) {
      status = mem_save( filenam+"dec", dec, silent=1 );
      status = mem_save( filenam+"swid", swid_list, silent=1 );
      status = mem_save( filenam+"posang", posang_arr, silent=1 );
   }
   w = where( swid_list == swid_in );
   nw = numberof(w);
   if( nw == 0 ) {
      write,format="Pointing for SWID %s was not found\n", swid_in;
      return -3;
   }

   ra_scx = ra(w(1));
   dec_scx = dec(w(1));
   posang = posang_arr(w(1));

   return 0;

}



/* Function j_get_pi_ebds */

func j_get_pi_ebds( &eb1, &eb2 )
/* DOCUMENT j_get_pi_ebds, eb1, eb2

  2005-11-11/NJW
  2006-02-20/NJW Yorick version

   Return the standard PI energy boundaries [keV]
   and set the externals '_PI_Energy_bds_lo' and ' _PI_Energy_bds_hi'.

*/
{
   extern _PI_Energy_bds_lo, _PI_Energy_bds_hi;

   basdir = get_env("IC_BASE")+"/imod_grp";
   imodfiles = file_search("jmx2_imod_grp_0???.fits",basdir);
   imodfiles = imodfiles(sort(imodfiles));
   imod_grp = imodfiles(0);

   eb1 = rdfitscol( imod_grp+"[JMX2-FBDS-MOD]","E_MIN");
   eb2 = rdfitscol( imod_grp+"[JMX2-FBDS-MOD]","E_MAX");
   _PI_Energy_bds_lo = eb1;
   _PI_Energy_bds_hi = eb2;

}

/* Function j_thruput */

func j_thruput( off_axis_angle, radius_lim, omega )
/* DOCUMENT res = j_thruput( off_axis_angle, radius_lim, omega )

   Calculates the throughput of JEMX for a pointing at
   off_axis_angle [deg] with an angle "omega" [deg]
   with respect to a collimator grid direction

    NJW  970221
    2006-09-08/NJW Updated to handle detector radius limit
    2007-01-02/NJW Translated to Yorick

*/
{
   // --- off axis angle

   alpha = off_axis_angle * pi / 180.0; // converted to radians

   // --- area of the two circles

   d = tan(alpha) * 3401.0;   // Det-Mask distance is 3401 mm
   f = circ_area1(d, 267.5, radius_lim) / (pi * radius_lim^2);
   //+ write,"rel. circ area = ", f

   // --- through collimator

   q = (57./6.6) * tan(alpha);
   //+ write,"q = ", q
   t = (1 - q * cos(omega*pi/180.0)) * (1. - q * sin(omega*pi/180.0));
   //+ write," thru coll = ", t

   return t > 0.0 ? f*t : 0.0;

}

func cbj_image_name( swid )
/* DOCUMENT cbj_name = cbj_image_name( swid )

   Return the image file name following the CBJ convention
   from a given SWID (12 characters).

   2007-01-09/NJW
*/
{

   revno = atoi(strpart(swid,1:4));
   pidno = atoi(strpart(swid,5:8));
   return  "skyimage_1_5_"+swrite(format="%i",revno)+"_"+swrite(format="%i",pidno)+"_0.fits";
}


/* Function dattim2ijd */

func dattim2ijd( dattim )
/* DOCUMENT ijd = dattim2ijd ( dattim )

   Convert a (array of) date/time string (such as 2003-01-27T10:48:17) to
   IJD i.e. number of days since Jan 01, 00:00, 2000

   Including 64.184 s offset prior to year 2000 and leap seconds at
      2005-12-31, 2008-12-31, and 2012-06-30 at the end of the day.

   2003-01-27/NJW
   2006-10-03/NJW translated to Yorick
   2006-12-21/NJW updated to account for difference between TT and UTC

*/

{


// Initial data definition

   days_in_month = [31,28,31,30,31,30,31,31,30,31,30,31];
   days_in_month_leap = [31,29,31,30,31,30,31,31,30,31,30,31];
   ijd_tmp = -1.0;
   ijd = -1.0;

   acc_days = array(long,12);
   acc_days_leap = array(long,12);
   for( i = 1; i <= 11; i++ ) {
      acc_days(i+1) = acc_days(i) + days_in_month(i);
      acc_days_leap(i+1) = acc_days_leap(i) + days_in_month_leap(i);
   }

   first = 1;

   // Analyze input (array of) string(s) and check format

   if( typeof( dattim ) != "string" ) {
      write,"1. argument is not of type string";
      return;
   }
   nelem = numberof(dattim);

   for( i = 1; i <= nelem; i++ ) {

      istr = swrite(format="%i", i);
      curstr = strcompress(dattim(i),all=1);
      len = strlen(curstr);

      if( len  <  13 ) {
         write,format="# %s %s invalid format (too short)", istr, dattim(i);
         continue;
      }

   //  Requirements   2002-11-16T23:45:56
   //            or   2002-11-16T23:45
   //            or   2002-11-16T23
   //      One "T", two "-"s

      ch = strpart(curstr,11:11)

      if( ch  !=  "T" ) {
         write,format="# %s %s invalid format (no 'T' in pos 11)",\
                    istr, dattim(i);
         continue;
      }

      ch = strpart(curstr,5:5);

      if( ch  !=  "-" ) {
         write,format="# %s %s invalid format (no '-' in pos 5)",\
                    istr, dattim(i);
         continue;
      }

      ch = strpart(curstr,8:8);

      if( ch  !=  "-" ) {
         write,format="# %s %s invalid format (no '-' in pos 8)",\
                    istr, dattim(i);
         continue;
      }

      year = strpart(curstr,1:4);

      if( !is_digit(year) ) {
         write,format="# %s %s invalid format (year is not a number)",\
                    istr, dattim(i);
         continue;
      }

      iyear = atoi(year);
      if( iyear  <  2000 || iyear  >  2099 ) {
         write,format="# %s %s invalid format (requirement: 2000 <= year <= 2100)",\
                    istr, dattim(i);
         continue;
      }

      cur_year_is_leap = ( iyear%4 == 0 ) ? 1 : 0;

      month = strpart(curstr,6:7);

      if( !is_digit(month) ) {
         write,format="# %s %s invalid format (month is not a number)",\
                    istr, dattim(i);
         continue;
      }

      imonth = atoi(month);
      if( imonth  <  1 || imonth  >  12 ) {
         write,format="# %s %s invalid format (illegal month number)",\
                    istr, dattim(i);
         continue;
      }

      day = strpart(curstr,9:10);

      if( !is_digit(day) ) {
         write,format="# %s %s invalid format (day is not a number)",\
                    istr, dattim(i);
         continue;
      }
      iday = atoi(day);

      daymax = days_in_month(imonth);
      if( cur_year_is_leap && imonth == 2 ) ++daymax;

      if( iday  <  1 || iday  >  daymax ) {
         write,format="# %s %s invalid format (invalid day number)",\
                    istr, dattim(i);
         continue;
      }

      hour = strpart(curstr,12:13);

      if( !is_digit(hour) ) {
         write,format="# %s %s invalid format (hour is not a number)",\
                    istr, dattim(i);
         continue;
      }

      if( atoi(hour) < 0 || atoi(hour) > 23 ) {
         write,format="# %s %s invalid format (invalid hour number)",\
                    istr, dattim(i);
         continue;
      }

      minute = "0";
      second = "0";

      if( len >= 16 ) { // The minute is given as well

         ch = strpart(curstr,14:14);
         if( ch != ":" ) {
            write,format="# %s %s invalid format (no ':' in pos 14)",\
                    istr, dattim(i);
            continue;
         }

         minute = strpart(curstr,15:16);

         if( !is_digit(minute) ) {
            write,format="# %s %s invalid format (minute is not a number)",\
                    istr, dattim(i);
            continue;
         }

         if( atoi(minute) < 0 || atoi(minute) > 59 ) {
            write,format="# %s %s invalid format (invalid minute number)",\
                    istr, dattim(i);
            continue;
         }

         if( len >= 19 ) { // The second is given as well

            ch = strpart(curstr,17:17);
            if( ch  !=  ":" ) {
               write,format="# %s %s invalid format (no ':' in pos 17)",\
                    istr, dattim(i);
               continue;
            }

            second = strpart(curstr,18:19);

            if( !is_digit(second) ) {
               write,format="# %s %s invalid format (second is not a number)",\
                    istr, dattim(i);
               continue;
            }

            if( atoi(second) < 0 || atoi(second) > 59 ) {
               write,format="# %s %s invalid format (invalid second number)",\
                    istr, dattim(i);
               continue;
            }

         }

      }

      num_years = long(iyear - 2000);
      num_leap_years = (num_years+3L)/4; // before current year

      num_days = num_years * 365 + num_leap_years;

      if( cur_year_is_leap ) {
         num_days = num_days + acc_days_leap(imonth) + iday - 1;
      } else {
         num_days = num_days + acc_days(imonth) + iday - 1;
      }
      num_seconds = atoi(hour)*3600.0 + atoi(minute)*60.0 + atoi(second);

      // account for leap seconds
      t_dif_s = 64.184;
      if( iyear >= 2006 ) t_dif_s = 65.184;               // at end of 2005
      if( iyear >= 2009 ) t_dif_s = 66.184;               // at end of 2008
      if( iyear == 2012 && imonth > 6 ) t_dif_s = 67.184; // mid 2012
      if( iyear >= 2013 ) t_dif_s = 67.184;               // after mid 2012

      t_dif_ijd = t_dif_s / 86400.0;
      ijd_tmp = num_days + num_seconds/(24.0*3600.0) + t_dif_ijd;

      if( first ) {
         ijd = ijd_tmp;
         first = 0;
      } else {
          grow, ijd, ijd_tmp;
      }



   }

   return ijd;

}


/* Function ijd2dattim */

func ijd2dattim( ijd )
/* DOCUMENT dattim = ijd2dattim( ijd )

    Converts scalar or array of IJD values to 'Gregorian' strings:
     YYYY-MM-DDTHH:MM:SS UTC

   Including 64.184 s offset prior to year 2000 and leap seconds at
      2005-12-31, 2008-12-31, and 2012-06-30 at the end of the day.

   SEE ALSO: dattim2ijd
*/
{
   ijd = double(ijd);
   if( is_scalar(ijd) ) return _ijd2dattim( ijd );
   n = numberof( ijd );
   res = array(string, n );
   for(i = 1; i <= n; i++ ) res(i) = _ijd2dattim( ijd(i) );
   return res;
}

func _ijd2dattim( ijd )
/* DOCUMENT dattim = _ijd2dattim( ijd )

   Work function for 'dattim2ijd', takes only a scalar.

   2006-10-03/NJW

*/
{

   if( ijd < 0.1 ) {
      write,format="Does not work for IJD = %f\n",ijd;
      return "";
   }

   days_in_month = [31,28,31,30,31,30,31,31,30,31,30,31];

// Including the difference between TT (Terrestrial Time) and UTC
// See FAQ of ISDC home page

   t_dif_s = 64.184;
   // leap second end of year 2005
   if( ijd > 2192.0007428704 ) t_dif_s = 65.184;
   // leap second end of year 2008
   if( ijd > 3288.0007544444 ) t_dif_s = 66.184;
   // leap second mid year 2012
   if( ijd > 4565.0007660185 ) t_dif_s = 67.184;
   t_dif_ijd = t_dif_s / 86400.0;
   ijd_utc = ijd - t_dif_ijd;

   dat = "2000-01-01T00:00:00";

   // Get year

   for( year = 2001; year <= 2099; year++ ) {

      str_year = swrite(format="%4.4i",year);
      dat = strput( dat, str_year, 1 );
      t = dattim2ijd(dat);
      if( t > ijd ) break;

   }

   year = year - 1;
   str_year = swrite(format="%4.4i", year);
   dat = strput(dat, str_year, 1 );
   if( year%4 == 0 ) days_in_month(2) = 29; // leap year

   // Get month

   for( month = 1; month <= 12; month++ ) {

      str_month = swrite(format="%2.2i", month);
      dat = strput(dat,str_month,6);
      t = dattim2ijd(dat);
      if( t > ijd ) break;

   }

   month--;
   str_month = swrite(format="%2.2i", month );
   dat = strput(dat,str_month,6);

   // Get day

   for( day = 1; day <= days_in_month(month); day++ ) {

      str_day = swrite(format="%2.2i", day );
      dat = strput(dat,str_day,9);
      t = dattim2ijd(dat);
      if( t > ijd ) break;

   }

   day--;
   str_day = swrite(format="%2.2i", day);
   dat = strput(dat,str_day,9);

   frac = ijd_utc - floor(ijd_utc);
   h = frac * 24;
   hour = toint(h);
   m = (h - hour) * 60;
   minute = toint(m);
   s = (m - minute) * 60;
   second = toint(s);

   str_hour = swrite(format="%2.2i", hour);
   dat = strput(dat,str_hour,12);

   str_minute = swrite(format="%2.2i", minute);
   dat = strput(dat,str_minute,15);

   str_second = swrite(format="%2.2i", second);
   dat = strput(dat,str_second,18);

   return dat;

}



/* Function j_get_used_gain */

func j_get_used_gain( jemxNum, swid, events, &selection )
/* DOCUMENT gain = j_get_used_gain( jemxNum, swid, events, >selection )

   Derive the gain [linPHA per keV] by comparing PHA and PI
   for processed data

   events is a struct with members: detx, dety, rawx, rawy, piarr,
	pha, status, evtime

   2005-11-03/NJW. Based on "predict_arf"


   Define the local gain as the number of linPHA channels per keV:

      local_gain = linPHA / Energy

   The local gain is both a function of detector position and of time

   Define the global gain (global_gain) as

      global_gain = average[ linPHA / (Energy * f_spag) ]

   where f_spag is the local spatial gain factor and the average
   is taken over a suitable area of the detector

   The global gain is a function of time i.e. "global" refers to the
   detector surface

   2007-01-23/NJW translated from 0idl/proc/j_get_used_gain.pro
*/
{

   if( is_void(events) ) {
      write,"Syntax: gain = j_get_used_gain( jemxNum, swid, events )";
      write,"   'events' is a struct as returned by 'j_get_events'";
      return [];
   }

   jmxstr = swrite(format="jmx%1i",jemxNum);
   JMXstr = swrite(format="JMX%1i",jemxNum);
   jstr = swrite(format="%1i",jemxNum);

   system,"get_insta_swijd -swid "+swid+" "+jstr+" imod 8 > tmpa";
   insta_imod = read_slist("tmpa");

   //  Define "flag" array to make sure that each detector position is only
   //  counted once when making the average

   flag = array( int, 256,256);

   //  Get the PI energy boundaries

   imod = get_env("IC_BASE")+"/imod_grp/"+jmxstr+"_imod_grp_"+insta_imod+".fits";
   //+ dol_fbds = imod+"["+JMXstr+"-FBDS-MOD]";
   //+ write,"Reading e_min, e_max ...";
   //+ e_min = rdfitscol( dol_fbds, "e_min" );
   //+ e_max = rdfitscol( dol_fbds, "e_max" );

   //  Get the PHA rebinning table i.e. from linear PHA to PHA in telemetry

   dol_fulb = imod+"["+JMXstr+"-FULB-MOD]";
   fulb = rdfitscol( dol_fulb, "channel" );

   //  Get the spatial gain array with two components

   dol_spag = imod+"["+JMXstr+"-SPAG-MOD]";
   write,"Reading SPAG ...";
   spag = readfits( dol_spag );

   //  Make an event selection based on STATUS flag

   nrows = numberof(events);
   selection = where( events.status  <  33 );
   nw = numberof(selection);
   write,itoa(nw)+" were selected from "+itoa(nrows)+" events";
   if( nw == 0 ) {
      return [];
   }
   evs = events(selection);

   lin_pha = array( float, nw);

   // Since the global gain is a function of time an array
   // is made

   global_gain_arr = array( float, nw);

   n_used = 0;

   //   Loop over the selected events

   for( i = 1; i <= nw; i++ ) {

      //  assign the linPHA value randomly between given limits

      lin_pha_min = fulb(evs(i).pha) + 1;
      lin_pha_max = fulb(evs(i).pha+1);
      if( evs(i).pha  <=  128 ) {
         lin_pha(i) = lin_pha_max;
      } else {
         lin_pha(i) = lin_pha_min + \
            float(toint(random([])*(lin_pha_max-lin_pha_min)+0.5));
      }

      //  "lin_pha" is (close to) the linPHA signal as delivered from the DFEE

      //  assign an energy between PI limits

      f_spag = ((1. + 0.01*spag(evs(i).rawx+1,evs(i).rawy+1,1)) \
                *spag(evs(i).rawx+1,evs(i).rawy+1,2));

      global_gain_arr(i) = lin_pha(i) / (evs(i).energy * f_spag);

   }

   return global_gain_arr;

}

/* Function j_get_events */

struct Event {
       float detx;
       float dety;
       int   rawx;
       int   rawy;
       double evtime;
       double energy;
       int   pha;
       int piarr;
       int status; }

func j_get_events( jemxNum, swid, silent= )
/* DOCUMENT res = j_get_events( jemxNum, swid, silent= )

   Returns an array of struct 'Event' with events from the
   specified SWID read from 'jmxi_full_cor.fits.gz'

   Keyword 'silent' is transmitted to gz_proxy_file

    2007-01-25/NJW
    2008-02-11/NJW updated to use OSA7 and optional running of COR level
    2010-01-28/NJW removed the automatic jmxi_full_cor.fits production
*/
{

   local Events;
   local dummy, extno;

   jmxstr = swrite(format="JMX%1i",jemxNum);
   jstr = swrite(format="%1i",jemxNum);
   revol = strpart(swid,1:4);

// Set externals (_PI_Energy_bds_lo/hi) with PI energy boundaries

   if( is_void(_PI_Energy_bds_lo) ) j_get_pi_ebds;

//  prepare filenames for useful files

   savname = "/net/uhuru/pool/pool28/njw/"+revol+"/j"+jstr+"_"+swid+".ysav";
   corname = "/jemx/arc/rev_2/scw/"+revol+"/"+swid+".001/jmx"+jstr+"_full_cor.fits";

//  Check for previously saved event file for faster reading

   if( file_test(savname) ) { // The easy way

      stream = openb(savname);
      restore, stream, Events;
      close, stream;

   } else { // Find and read the jmxi_full_cor.fits file

      cor = 0;
      if( file_test(corname) || file_test(corname+".gz") ) {

// Check for jmxi_full_cor.fits file in JEM-X archive

         full_cor = gz_proxy_file( corname, silent=silent );
         cor = 1;

      } else {

         write,"full_cor file is not available, try using jmxi_events.fits";

      }

   //     The event file is to be found in the data archive:
      evts_file = "/jemx/arc/rev_2/scw/"+revol+"/"+swid+".001/jmx"+jstr+"_events.fits";
      evts_file_p = gz_proxy_file( evts_file, silent=silent );
      if( is_void(evts_file_p) ) {
         write,"Failed to find: "+evts_file;
         return [];
      }

      rhdr = headfits( evts_file_p+"+1" );
      rswid = itoa(fxpar(rhdr, "SWID"));
      rinstr = itoa(fxpar(rhdr, "INSTRUME"));

      if( cor ) {
         fhdr = headfits( full_cor+"+1" );
         fswid = itoa(fxpar(fhdr, "SWID"));
         finstr = itoa(fxpar(fhdr, "INSTRUME"));
         if( fswid  !=  rswid ) {
            write,"Mismatching SWIDs: ", fswid+"  "+rswid;
            return [];
         }
         if( finstr  !=  rinstr ) {
            write,"Mismatching INSTRUMEs: ", finstr+"  "+rinstr;
            return [];
         }
      }

      //  Get the events
      //  Since jmxi_full_cor.fits.gz with columns DETX, DETY, PI, ENERGY, STATUS
      //  may have better correction than jmxi_events.fits[JMXi-FULL-ALL]
      //  these values are loaded afterwards

      extnam = cor ? finstr+"-FULL-ALL" : rinstr+"-FULL-ALL";
      get_exten_no, evts_file_p+"["+extnam+"]", dummy, extno;
      if( extno == -1 ) {
         write,"No FULL-ALL extension found in jxmi_events.fits, quit!";
         return [];
      }
      dol = evts_file_p+"+"+itoa(extno);
      hdr = headfits( dol );
      ptr = rdfitsbin( dol );
      rawx   = *ptr(fits_colnum( hdr, "RAWX"));
      rawy   = *ptr(fits_colnum( hdr, "RAWY"));
      detx   = *ptr(fits_colnum( hdr, "DETX"));
      dety   = *ptr(fits_colnum( hdr, "DETY"));
      pha    = *ptr(fits_colnum( hdr, "PHA"));
      evtime = *ptr(fits_colnum( hdr, "TIME"));
      piarr  = *ptr(fits_colnum( hdr,"PI"));
      status = *ptr(fits_colnum( hdr,"STATUS"));
      cn = fits_colnum(hdr,"ENERGY",silent=silent);
      if( cn ) energy = *ptr(cn);
      nrows = numberof(rawx);

      if( cor ) { // if jmxi_full_cor.fits exists then override some values
         dol = full_cor+"+1";
         hdr = headfits( dol );
         ptr = rdfitsbin( dol );
         detx   = *ptr(fits_colnum( hdr, "DETX"));
         dety   = *ptr(fits_colnum( hdr, "DETY"));
         piarr  = *ptr(fits_colnum( hdr,"PI"));
         cn = fits_colnum(hdr,"ENERGY",silent=silent);
         if( cn ) energy = *ptr(cn);
         status = *ptr(fits_colnum(hdr,"STATUS"));
      }
      if( nrows == 0 ) {
         write,"No events in  file";
         return [];
      }

      Events = array(Event, nrows);
      Events.rawx = toint(rawx);
      Events.rawy = toint(rawy);
      Events.pha  = toint(pha);
      Events.evtime  = evtime;
      if( cn ) {
         Events.energy  = energy;
      } else {
          Events.energy = _PI_Energy_bds_lo(piarr+1) + \
            random(nrows)*(_PI_Energy_bds_hi(piarr+1) - _PI_Energy_bds_lo(piarr+1));
      }

      Events.detx = detx;
      Events.dety = dety;
      Events.piarr = toint(piarr);
      Events.status = toint(status);

//  Save this event array for quicker read next time it is requested

      savname = "/net/uhuru/pool/pool28/njw/"+revol+"/j"+jstr+"_"+swid+".ysav";
      stream = createb(savname);
      save, stream, Events;
      close, stream;

   }

   return Events;

}


/* Function j_gain_values */

func j_gain_values( jemxNum, swid, diag=, proj= )
/* DOCUMENT res = j_gain_values( jemxNum, swid, diag=, proj= )

    To be run on 'gauss'
    Uses project q101 for JMX1 to run the COR level of the JEMX
    science analysis of OSA7

    2007-01-25/NJW
*/

{

   local selection;

   num_bins = 20;

   events = j_get_events( jemxNum, swid, proj=proj );
   gain = j_get_used_gain( jemxNum, swid, events, selection );
   if( is_void(gain) ) return [];
   events = events(selection);
   w = where(gain < 50.);
   ngain = numberof(w);
   if( ngain == 0 ) {
      write,"No gain values below 50 - skip";
      return [];
   }
   gain = gain(w);
   ev_time = events(w).evtime;
   if( ngain < num_bins ) num_bins = ngain;
   n_per_bin = ngain / num_bins;
   gain_bin = array(float, num_bins);
   time_bin = array(double, num_bins);
   for( i = 1; i <= num_bins; i++ ) {
      i1 = (i-1)*n_per_bin + 1;
      i2 = i * n_per_bin;
      gain_bin(i) = avg(gain(i1:i2));
      time_bin(i) = 0.5*(ev_time(i1)+ev_time(i2));
   }
   ev_time0 = 0.5*(ev_time(1)+ev_time(0));
   coefs = lin_regress( time_bin - ev_time0, gain_bin, 0*gain_bin+1 );
   fit = coefs(1) + coefs(2)*(time_bin - ev_time0);
   chi2 = sum((gain_bin - fit)^2);
   quality = chi2 > 20. ? 1.0 : 0.0;

   if( diag ) {
      jmxstr = swrite(format="JMX%1i", jemxNum);
      plot, (ev_time-ev_time0)*86400.0, gain, ps=1,yr=[0,50];
      xyouts, 0.5,0.8, swid, align=0.5,ndc=1;
      oplot, (time_bin-ev_time0)*86400.0, gain_bin+3;
      oplot, (time_bin-ev_time0)*86400.0, fit+3;
   }

   return [coefs(1),coefs(2),ev_time0,quality];

}

/* Function pointing_plot */

func pointing_plot( rev, zoom=, read=, nn=, flog=, pane= )
/* DOCUMENT pointing_plot, rev, zoom=, read=, nn=, flog=, pane=

   plot the INTEGRAL pointings from a revolution.

   Keywords:

   If 'zoom' is given as a 3 element array: (ra,dec,radius)
      then a close-up of that region is shown.
   If 'flog' is a filename (string) then various information is put there.
   Keyword 'pane' defines the window number (defaults to zero).
   Keyword 'read' opens the possibility to get a close-up of a region,
      whose center can be selected by a cursor click. The value of 'read'
      determines the radius of zoomed area.
   Keyword 'nn' prevents putting the pointing numbers on the plot

   2005-00-00/NJW
   2008-05-28/NJW, added keyword pane.
*/

{

   local swid, ra, dec;

   mon = 0;
   if( numberof(flog) )  {
      if( "string" == typeof( flog ) ) {
         lun = create(flog);
         mon = 1;
      } else {
         write,"Keyword 'flog' was not a string - skip logging";
      }
   }

   if( is_void(pane) ) pane = 0;

   revstr = swrite(format="%4.4i",rev);
   basdir = app_slash(get_env("J_POINTINGS"));
   filename = basdir+"pointings_"+revstr+"p.dat";
   if( mon ) write,lun,filename;

/*
 * swid = rscol( filename, 1, silent=1, str=1);
 * ra = rscol( filename, 2, silent=1);
 * dec = rscol( filename, 3, silent=1);
 */

   rstab, filename, 3, swid, ra, dec, typ="sff",silent=1;

   if( mon ) {
      for( imon = 1; imon <= numberof(swid); imon++ ) {
         write,lun,swid(imon),ra(imon),dec(imon);
      }
   }

   if( numberof(zoom) == 3 )  {

      window,pane,style="boxed.gs";

      r = arcdist( zoom(1), zoom(2), ra, dec );
      w = where( r < zoom(3) );
      nw = numberof(w);
      if( nw == 0 )  {
         write,"Sorry, no pointings were close enough";
         if( mon )  {
            write,lun,"Sorry, no pointings were close enough";
            close,lun;
         }
         return 0;
      }

      swid = swid(w);
      ra = ra(w);
      dec = dec(w);

      plot, ra, dec, ps=3, symsize=2, \
         xr=zoom(1)+zoom(3)*[1,-1]/cos(zoom(2)*pi/180), \
         yr=zoom(2)+zoom(3)*[-1,1], xtitle="R.A. [degrees]", \
         ytitle="Declination [degrees]";
      // res = convert_coord([0.12,0.88],/normal,/to_data);
      plt,"Revol: "+swrite(format="%3.3i",rev),0.4,0.89,justify="CA",height=20;
      oplot,[zoom(1)],[zoom(2)],ps=12, symsize=0.5;
      oplot,[zoom(1)],[zoom(2)],ps=13, symsize=0.5;

      // Add text for each point with PID except when inhibited
      if( !nn ) {
         for( i = 1; i <= nw; i++) {
            pid = strpart(swid(i),5:8);
            sub = strpart(swid(i),11:11);
            off = 0.06;
            for( j = 1; j <= i; j++ ) {
               if( arcdist(ra(j),dec(j),ra(i),dec(i)) < 0.1 ) off = off + 0.06;
            }
            plt,pid+"/"+sub,ra(i),dec(i)+zoom(3)*off,tosys=1,justify="CA",height=8;
         }
      }

   } else  {

      window,pane,style="nobox.gs";

      /*  Plot the grid */

      plot,[0],[0],xr=[180,-180],yr=1.4*[-90,90];

      /* lon grid */

      b = span(-90,90,100);
      for( lon = -179.99; lon < 180.1; lon += 89.99 ) {
         l = array(0,100) + lon;
         xy = aitoff(l,b);
         listy = 2;
         if( lon < -179 || lon > 179 ) listy = 1;
         oplot,xy(1,),xy(2,),li=listy;
      }

      /* lat grid */

      l = span(-179.999,180,100);
      for( lat = -60.; lat < 60.01; lat += 30. ) {
         b = array(0,100) + lat;
         xy = aitoff(l,b);
         oplot,xy(1,),xy(2,),li=2;
      }

      //+ plt,"Revol: "+swrite(rev),0,70,tosys=1,height=20,justify="CA";
      plt,"Revol: "+swrite(rev),0.39,0.85,height=20,justify="CA";

      // Overplot the pointings;

      glb = galactic(ra, dec);

      if( mon ) {
         for( imon = 1; imon <= numberof(swid); imon++ ) {
            write,lun,swid(imon),glb(imon,1),glb(imon,2);
         }
      }

      xy = aitoff(glb(,1),glb(,2));

      oplot, xy(1,), xy(2,), ps=3,symsize=1;

      xyouts,0.4,0.88,"INTEGRAL pointings",align=0.5,ndc=1,charsize=1.3;

      // Include selected sources

      seso_dol = "/r6/jemx/catalogs/selected_sources.fits+1";
      seso_name = strtrim(rdfitscol(seso_dol,"name"));
      seso_ra_obj = rdfitscol(seso_dol,"ra_obj");
      seso_dec_obj = rdfitscol(seso_dol,"dec_obj");
      nseso = numberof(seso_name);

      for( i = 1; i <= nseso; i++ ) {
         xysrc = galactic(seso_ra_obj(i),seso_dec_obj(i));
         xysrc = aitoff(xysrc(1), xysrc(2));
         oplot,xysrc(1,),xysrc(2,),ps=13,color="red",symsize=0.2;
         oplot,xysrc(1,),xysrc(2,),ps=13,color="red",symsize=0.15;
         oplot,xysrc(1,),xysrc(2,),ps=13,color="red",symsize=0.1;
         oplot,xysrc(1,),xysrc(2,),ps=13,color="red",symsize=0.05;
         dx = seso_name(i) == "Crab" ? 5.0 : 0.0;
         dy = 3.;
         xyouts,xysrc(1,1)+dx,xysrc(2,1)+dy,seso_name(i),align=0.5,charsize=0.5,color="red";
      }

      if( read ) {
         res = curmark1( style=0, prompt="Click on the sky position : ..." );
         write,format="Coords in plot: %f %f\n", res(1), res(2);
         gala = rever_aitoff( res(1), res(2) );
         write,format="L,B: %8.3f, %8.3f\n", gala(1), gala(2);
         equa = equatorial( gala(1), gala(2) );
         write,format="RAdec: %8.3f, %8.3f\n", equa(1), equa(2);
         grow,equa,read;
         pointing_plot,rev,zoom=equa,nn=nn,pane=pane;
      }

   }

   if( mon ) close,lun;

}

/* Function validate_swid_list */

func validate_swid_list( swid_arr, jemxNum, ign_bti=, chat=, silent= )
/* DOCUMENT new_swid_arr = validate_swid_list( swid_arr, jemxNum,
                   ign_bti=, chat=, silent= )

   'swid_arr' is assumed to be an array of SWIDs. Here
   they will be checked against the FITS pointing file
   /r6/jemx/pointings/pointings_RRRR.fits

   Keyword 'ign_bti' will cause the function to ignore BTI information.

    2007-02-14/NJW
    2008-01-14/NJW, updated to use ../RRRR/jmxi_shd.list
    2008-05-29/NJW, updated to use /r6/jemx/pointings/pointings_RRRR.fits
    2012-04-19/NJW, updated to check new BTI columns as well
*/

{

   if( is_void(chat) ) chat = 0;

   if( is_void(jemxNum) ) {
      write,"Syntax: new_swid_arr = validate_swid_list( swid_arr, jemxNum )";
      return [];
   }
   jstr = itoa(jemxNum);
   nswids = numberof(swid_arr);
   new_swid_arr = [];
   revol_prev = "0000";
   prev_pointfile = "asdf";
   for( i = 1; i <= nswids; i++ ) {
      revol = strpart(swid_arr(i),1:4);
      if( revol != revol_prev ) {
         pointfile = "/r6/jemx/pointings/pointings_"+revol+".fits";
         if( !file_test( pointfile ) ) {
            if( prev_pointfile != pointfile ) write,format="%s not found\n", pointfile;
            prev_pointfile = pointfile;
            continue;
         }
         if( chat > 1 ) write,"Reading new pointdata "+revol;
         swids_tab = rdfitscol( pointfile+"+1", "swid" );
         shd_flag  = ( rdfitscol( pointfile+"+1", "shd_j"+jstr ) == 1 );
         bti_flag  = strmatch( rdfitscol( pointfile+"+1", "bti_j"+jstr ), "N" );
         if( !ign_bti ) shd_flag = ( shd_flag & bti_flag );
         revol_prev = revol;
      }
      w = where( swids_tab == swid_arr(i) );
      if( numberof(w) == 0 ) {
         if( !silent ) write,format="SWID %s not in %s\n", swid_arr(i), \
                         pointfile;
         continue;
      }
      if( shd_flag(w(1)) == 1 ) {
         grow, new_swid_arr, swid_arr(i);
         if( !bti_flag(w(1)) ) write,"BTI warning for SWID "+swid_arr(i);
      } else {
         if( !silent ) write,format="%s was rejected, shd_flag & bti_flag != 1\n", swid_arr(i);
      }
   }

   return new_swid_arr;

}

/* Function nearby_sources */

func nearby_sources( ra_in, dec_in, radius, force=, clog= )
/* DOCUMENT res = nearby_sources( ra_in, dec_in, radius, force=, clog= )
      or:   nearby_sources, ra_in, dec_in, radius, force=, clog=

  2007-08-15/NJW copied from nearest_source.i

   When called as a function it
   returns string array with source name, RA_cat, DEC_cat, and distance [deg]
   for each source within the given radius.
   If there are no sources within the given radius then [] is returned

   If called as a subroutine output will be given on the terminal.

  Keyword  force:   Force reading the catalog contents
           clog :   The DOL of the catalogue
*/

{

   extern Source_cat, Source_cat_dol, Source_cat_num;

   if( is_void(radius) ) {
      write,"Syntax: str = NEARBY_SOURCES( ra, dec, radius[,force=][,clog=])";
      write,"         Unit is decimal degrees";
      write,"         Set force=1 if catalog has changed";
      write,"         Define catalog by clog=DOL_of_CAT";
      return [];
   }

   if( dimsof(ra_in)(1)  !=  0 || dimsof(dec_in)(1)  !=  0 ) {
      write,"Input coordinate must be scalar";
      return [];
   }

   read_catalog, force=force, clog=clog; // Will read catalog if required

   ra_in = double(ra_in);
   dec_in = double(dec_in);

   dista = arcdist(Source_cat.ra_obj,Source_cat.dec_obj,ra_in,dec_in);

   w = where( dista < radius );
   nw = numberof(w);
   if( nw == 0 ) return [];

   if( am_subroutine() ) {
      len_name = max(strlen(strtrim(Source_cat.name)));
      s1 = strpadd("",len_name," ");
      write,"Name"+s1+"  RA        DEC    Distance";
      write,"    "+s1+"  deg       deg      deg";
      fmt = swrite(format="%%%is  %%8.4f  %%8.4f  %%8.4f\n",len_name+3);
   }
   is = sort(dista(w));
   res = array(string,4,nw);
   for( i = 1; i <= nw; i++ ) {
      res(1,i) = Source_cat(w(is(i))).name;
      res(2,i) = itoa(Source_cat(w(is(i))).ra_obj);
      res(3,i) = itoa(Source_cat(w(is(i))).dec_obj);
      res(4,i) = itoa(dista(w(is(i))));
      if( am_subroutine() ) {
         write,format=fmt, \
           strtrim(Source_cat(w(is(i))).name), Source_cat(w(is(i))).ra_obj, \
           Source_cat(w(is(i))).dec_obj, dista(w(is(i)));
      }
   }

   return res;

}

/* Function nearest_source */

func nearest_source( ra_in, dec_in, radius, &dist, force=, clog= )
/* DOCUMENT res = nearest_source( ra_in, dec_in, radius, >dist, force=, clog= )

   Find the nearest source to the given position inside radius
   'radius' (degrees).

   When called as a function it
   returns a struct (s_Src) with name, ra_obj, dec_obj, err_rad,
   source_id, and class. The distance to the given position is
   returned in the variable 'dist' (in degrees).

   If there is no source within the given radius a [] is returned

   If called as a subroutine the output appears on the terminal.

   Keyword  force:   Force reading the catalog contents
            clog :   The DOL of the catalogue

   2007-08-15/NJW translated to Yorick
   2008-11-25/NJW returns also source_id and class

*/

{

   extern Source_cat, Source_cat_dol, Source_cat_num;

   if( dimsof(ra_in)(1)  !=  0 || dimsof(dec_in)(1)  !=  0 ) {
      write,"Input coordinate must be scalar";
      return [];
   }

   read_catalog, force=force, clog=clog;

   ra_in = double(ra_in);
   dec_in = double(dec_in);

   dista = arcdist(Source_cat.ra_obj,Source_cat.dec_obj,ra_in,dec_in);
   is = sort(dista)(1);
   dist = dista(is);

   if( dist > radius ) {
      dist = 180.;
      return [];
   }

   name = Source_cat(is).name;
   ra = Source_cat(is).ra_obj;
   dec = Source_cat(is).dec_obj;
   src_id = Source_cat(is).source_id;
   class = Source_cat(is).class;

   if( am_subroutine() ) {
      write,format="%s %s RAdec: %9.4f %9.4f deg, dist = %7.2f arcmin, class: %s\n", \
                name, src_id, ra, dec, dist*60.0, itoa(class);
      return;
   } else {
      return Source_cat(is);
   }

}

/* Function _read_catalog */

struct s_Src {
   double ra_obj;
   double dec_obj;
   double err_rad;
   string name;
   string source_id;
   int class;
}

func _read_catalog( dol_of_cat, chat= )
/* DOCUMENT _read_catalog, dol_of_cat, chat=

  Read an X-ray source catalog and store it as external variables:
    Source_cat{ ra_obj, dec_obj, err_rad, name, source_id } (array)
    Source_cat_dol (scalar string)
    Source_cat_num (number of entries)

  NJW/010126  Read a catalog in format like DSRI_CAT.fits
  NJW/2005-10-27  Updated to version 2 for gnrl_refr_cat_latest.fits
  NJW/2006-01-10  Updated to also have the entry: catalogue
  2007-08-15/NJW Translated to yorick

      Some of the "not so important" columns may be missing
      in which case some dummy information is produced

*/

{

   extern Source_cat, Source_cat_dol, Source_cat_num;

   local file_of_cat, extno;

   get_exten_no, dol_of_cat, file_of_cat, extno;
   if( ! file_test( file_of_cat ) ) {
      write,format="_READ_CATALOG: Requested catalog: %s does not exist ...\n", \
               file_of_cat;
      Source_cat_num = -1;
      return;
   }
   Source_cat_dol = fullpath(dol_of_cat);

   // Read the contents of the database

   if( chat ) write,format="_READ_CATALOG: Reading %s ...\n", dol_of_cat;

   fh = headfits(Source_cat_dol,nocheck=1);

   //  RA(_OBJ) and DEC(_OBJ) are required columns

   colnum = fits_colnum( fh, "RA_OBJ" );
   if( is_void(colnum) ) { // Try RA
      colnum = fits_colnum( fh, "RA");
      if( is_void(colnum) ) {
         write,"_READ_CATALOG: Neither RA nor RA_OBJ column found, give up";
         return;
      }
   }
   ra = rdfitscol( dol_of_cat, colnum);

   colnum = fits_colnum( fh, "DEC_OBJ");
   if( is_void(colnum) ) { // Try DEC
      colnum = fits_colnum( fh, "DEC");
      if( is_void(colnum) ) {
         write,"_READ_CATALOG: Neither DEC nor DEC_OBJ column found, give up";
         return;
      }
   }
   dec = rdfitscol( dol_of_cat, colnum);

   Source_cat_num = numberof(ra);

   // The remaining columns may be omitted

   colnum = fits_colnum( fh, "NAME");
   if( is_void(colnum) ) { //  Try "SOURCENAME" in stead
      colnum = fits_colnum( fh, "SOURCENAME");
      if( is_void(colnum) ) { // Try "SOURCE_ID" in stead
         colnum = fits_colnum( fh, "SOURCE_ID" );
      }
   }
   if( is_void(colnum) ) {
      name = array("?NAME",Source_cat_num);
      if( chat ) write,"_READ_CATALOG:  substituted all names with ?NAME";
   } else name = rdfitscol( dol_of_cat, colnum );

   source_id = rdfitscol( dol_of_cat, "SOURCE_ID");
   if( is_void(source_id) ) {
      source_id = array("?SOURCE_ID",Source_cat_num);
      if( chat ) write,"_READ_CATALOG:  substituted all source_ids with ?SOURCE_ID";
   }

   err_rad = rdfitscol( dol_of_cat, "ERR_RAD");
   if( is_void(err_rad) ) {
      err_rad = array( 0.05,Source_cat_num);
      if( chat ) write,"_READ_CATALOG:  substituted all err_rads with 0.05";
   }

   class = rdfitscol( dol_of_cat, "CLASS");
   if( is_void(class) ) {
      class = array( int, Source_cat_num);
      if( chat ) write,"_READ_CATALOG:  substituted all class s with 0";
   }

   Source_cat = array( s_Src, Source_cat_num );

   for( i = 1; i <= Source_cat_num; i++ ) {
      Source_cat(i).ra_obj     = ra(i);
      Source_cat(i).dec_obj    = dec(i);
      Source_cat(i).err_rad    = err_rad(i);
      Source_cat(i).name       = name(i);
      Source_cat(i).source_id  = source_id(i);
      Source_cat(i).class      = class(i);
   }

}

/* Function read_catalog */

func read_catalog( catdol, force=, clog= )
/* DOCUMENT read_catalog, catdol, force=, clog=

    Loads a catalog of X-ray sources to memory in externals:
       Source_cat, Source_cat_dol, Source_cat_num

    Either the argument 'catdol' may be given or the keyword 'clog'.
    If both are given 'clog' will dominate.

    Logics:

     if (there is no source cat in memory OR 'force' is set) then
        if ('clog' is not given ) read the standard ISDC refr catalog
        else read the one given by 'clog' keyword
     else
        if ('clog' is not given) no action [working with std catalog]
        else
           if ('clog' differs from Source_cat_dol ) read 'clog'
           else no action
        end_if 
     endif

*/
{
   extern Source_cat, Source_cat_dol, Source_cat_num; 

   //+ if( is_void(Source_cat) && is_void(catdol) && is_void(clog) ) \
   //+           error,"READ_CATALOG error: missing catalog";
   if( is_void(clog) && !is_void(catdol) ) clog = catdol; // accept first argument

   if( is_void(Source_cat) || !is_void(force) ) {
      if( is_void(clog) ) { // read standard reference catalog
         Source_cat_dol = "/r6/jemx/catalogs/gnrl_refr_cat_latest.fits+1";
         _read_catalog, Source_cat_dol, chat=1;
      } else {
         _read_catalog, clog, chat=1;
      }
   } else {
      if( !is_void(clog) ) {
         fullclog = fullpath(clog);
         if( fullclog != Source_cat_dol ) {
            _read_catalog, clog, chat=1;
            // Source_cat_dol is updated by 'read_catalog'
         }
      }
   }
}

/* Function qidsrcs */

func qidsrcs( dol, check=, outfile=, rad=, clobber=, force=, clog=, unique=, chat= )
/* DOCUMENT qidsrcs, dol, check=, outfile=, rad=, clobber=, force=, clog=, unique=, chat=

   Identify sources in a FITS binary table (the input source list given
   by argument 'dol') with at least the columns 'NAME', 'RA_OBJ', and 'DEC_OBJ'.

   The header (HDU) of the updated file will have additional keywords to mark
   that 'qidsrcs' has been applied and to give the catalog name.

   Keywords:
   check     : is to identify sources where the name deviates
               from the one proposed by 'qidsrcs'. No update is done.
   outfile   : if given then the result (with NAME column
               replaced) will be written into that file; else the
               file defined by 'dol' will be overwritten.
               Note that the resulting file will have the binary
               table in the first extension and the rest of the
               file is lost.
   rad       : is a radius limit (in degrees, defaults to 0.1) outside which no
               identification will be done (NAME will be replaced by 'UNKNOWN').
   chat      : the chattiness level
   unique    : implies that the source list consists of unique sources
               so that each catalog source can only be assigned to a single
               source from the list (resembles standard running of
               q_identify_srcs).
   force     : Force re-reading of reference source catalog
   clog      : DOL of reference source catalog
   clobber   : Allow overwriting of output file

   2007-09-12/NJW
   2008-11-18/NJW updated with 'unique' keyword
   2008-11-25/NJW updated with CLASS information
*/
{

   extern Source_cat, Source_cat_dol, Source_cat_num;

   local filename, extno, fh, nrows, nam, src_id, ra, dec;
   local racat, deccat, class;

   if( is_void(chat) ) chat = 0;

   if( is_void(rad) ) rad = 0.1; // degrees
   get_exten_no, dol, filename, extno;
   if( extno == 0 ) dol = dol+"+1"; // extension #1 is the default
   if( !file_test(filename) ) {
      write,format="%s does not exist\n", filename;
      return [];
   }
   // read the contents before it might be destroyed
   ptr = rdfitsbin( dol, fh, nrows );
   if( is_void(ptr) ) {
      write,format="%s has no rows, skip ...\n", dol;
      return [];
   }

   if( !check ) {
      if( is_void(outfile) ) outfile = filename;
      if( file_test(outfile) ) {
         if( clobber ) {
            remove, outfile;
         } else {
            write,format="%s exists already, quit\n", outfile;
            return;
         }
      }
   }


   // get reference catalog if not already in memory

   read_catalog, force=force, clog=clog;

   // localize specific columns in the source list

   nnam = fits_colnum( fh, "name" );
   if( is_void(nnam) ) error,"Column NAME is missing";
   nra  = fits_colnum( fh, "ra_obj" );
   if( is_void(nra) ) error,"Column RA_OBJ is missing";
   ndec = fits_colnum( fh, "dec_obj" );
   if( is_void(ndec) ) error,"Column DEC_OBJ is missing";
   nsrc_id = fits_colnum( fh, "source_id" );
   if( is_void(nsrc_id) ) error,"Column SOURCE_ID is missing";
   nracat  = fits_colnum( fh, "ra_cat" );
   catflag = is_void(nracat) ? 0 : 1;
   if(catflag) ndeccat = fits_colnum( fh, "dec_cat" );
   nclass = fits_colnum( fh, "class" );
   classflag = is_void(nclass) ? 0 : 1;


   eq_nocopy, nam, *ptr(nnam);
   eq_nocopy, ra , *ptr(nra);
   eq_nocopy, dec, *ptr(ndec);
   if( catflag ) {
      eq_nocopy, racat, *ptr(nracat);
      eq_nocopy, deccat, *ptr(ndeccat);
   }
   if( classflag ) {
      eq_nocopy, class, *ptr(nclass);
   }

   // Get SOURCE_ID column with correct string length
   // for proper update of source list
   eq_nocopy, src_id, *ptr(nsrc_id);
   tform = fxpar( fh, swrite(format="tform%i", nsrc_id));
   if( strlen(tform) > 1 ) {
      srclen = atoi(strpart(tform,1:-1));
   } else error,"Bad SOURCE_ID TFORM format";

   // Get correct string length for NAME column
   // for proper update of source list
   tform = fxpar( fh, swrite(format="tform%i", nnam));
   if( strlen(tform) > 1 ) {
      namlen = atoi(strpart(tform,1:-1));
   } else error,"Bad NAME TFORM format";

 /*************
  *
  *   The default operation mode is to walk through the input
  *   source list in order to find the catalog source that
  *   is closest and then decide if it is close enough. If so,
  *   the identification is done.
  *   This approach is useful when the input source list can
  *   have multiple representations of the same physical source.
  *
  *   On the other hand, when it is known (or assumed) that the
  *   input list consists of unique sources then each catalog
  *   source can only be assigned once. In this case (indicated
  *   by the setting of the keyword 'unique') it is better to
  *   walk through the source catalog and for each source
  *   find the best matching source from the source list.
  *
  **************/

   if( unique ) {  // Walk through the reference source catalog
                 // to see if a source from the given list matches
                 // the known source position

      // reset all source names and source_ids

      snew = strpadd("NEW SOURCE", namlen, " ");
      for( i = 1; i <= nrows; i++ ) (*ptr(nnam))(i) = snew;
      srid = strpadd("UNKNOWN", srclen, " ");
      for( i = 1; i <= nrows; i++ ) (*ptr(nsrc_id))(i) = srid;

      // 'rflag' is used to mark the sources where an identification has
      // been found. Set to 180. for those and add to 'r' before sorting
      // making sure that it will not be close again

      rflag = array(0.0,nrows);

      for( i = 1; i <= Source_cat_num; i++ ) {
         r = arcdist( Source_cat(i).ra_obj, Source_cat(i).dec_obj, ra, dec );
         is = sort(r + rflag);
         if( r(is(1)) < rad ) { // an identification has been found
            // alright, this is a candidate, but there might be a better match
            rr = arcdist(Source_cat.ra_obj, Source_cat.dec_obj,ra(is(1)),dec(is(1)));
            if( rr(min) < r(is(1)) ) continue; // continue steeping through
               // refr cat sources; sooner or later the best one will be found
            rflag(is(1)) = 180.;
            name = strpadd(Source_cat(i).name, namlen, " ");
            s_id = strpadd(Source_cat(i).source_id, srclen, " ");
            (*ptr(nnam))(is(1)) = name;
            (*ptr(nsrc_id))(is(1)) = s_id;
            if( catflag ) {
               (*ptr(nracat))(is(1)) = Source_cat(i).ra_obj;
               (*ptr(ndeccat))(is(1)) = Source_cat(i).dec_obj;
            }
            if( classflag ) {
               (*ptr(nclass))(is(1)) = Source_cat(i).class;
            }
         }
      }

   } else { //  Walk through the input source list

      // make sure to keep original string length
      for( i = 1; i <= nrows; i++ ) {
         nearest = nearest_source( ra(i), dec(i), rad );
         if( is_void(nearest) ) { // No catalog object within given radius
            name = strpadd("NEW SOURCE", namlen, " ");
            s_id = strpadd("UNKNOWN", srclen, " ");
         } else { // A source has been found
            name = strpadd(strpart(nearest.name,1:namlen),namlen," ");
            s_id = strpadd(strpart(nearest.source_id,1:srclen),srclen," ");
         }
         if( chat > 0 ) {
            write,format="Row#%i ID: %s, NAME: %s\n", i, s_id, name;
         }
         if( check ) {
            if( strtrim(name) != strtrim(nam(i)) ) {
               write,format="Row#%i, %s to change to %s\n", \
                       i, strtrim(nam(i)), strtrim(name);
            }
         } else {
            //+ while(strlen(name) < namlen ) name += " ";
            //+ while(strlen(s_id) < srclen ) s_id += " ";
            (*ptr(nnam))(i) = name;
            (*ptr(nsrc_id))(i) = s_id;
            if( catflag ) {
               if( is_void(nearest) ) {
                  (*ptr(nracat))(i) = float(-99.0);
                  (*ptr(ndeccat))(i) = float(-99.0);
               } else {
                  (*ptr(nracat))(i) = float(nearest.ra_obj);
                  (*ptr(ndeccat))(i) = float(nearest.dec_obj);
               }
            }
            if( classflag ) {
               if( is_void(nearest) ) {
                  (*ptr(nclass))(i) = 0n;
               } else {
                  (*ptr(nclass))(i) = int(nearest.class);
               }
            }
         }
      }

   }

   kwds_init;
   if( typeof(outfile) == "string" ) kwds_set,"ORIGIN", dol, "Original source list";
   kwds_set,"QDATE",ndate(3),"Updated with qidsrcs";
   kwds_set,"Q_RAD", rad, "[deg] Acceptance radius for qidsrcs";
   kwds_set,"REFR_CAT", Source_cat_dol,"Reference catalog of X-ray sources";
   mode = unique ? "UNIQUE_MOD" : "SIMPLE_MOD";
   kwds_set,"Q_MODE", mode, "Mode for qidsrcs id process";

   fh = kwds_put( fh );
   if( !check ) wrfitsbin, outfile, fh, ptr;

}

/* Function find_src_by_name */

func find_src_by_name( name, force=, clog= )
/* DOCUMENT res = find_src_by_name( name, force=, clog= )

  2007-10-26/NJW

   Returns struct array with the elements:
       ra_obj, dec_obj, err_rad, name, source_id
   for each source with a name that matches the input name.

  Keyword  force:   Force reading the catalog contents
           clog :   The DOL of the catalogue
*/

{

   extern Source_cat, Source_cat_dol, Source_cat_num;

   if( dimsof(name)(1)  !=  0 ) {
      write,"Input name must be scalar";
      return [];
   }
   if( typeof(name) != "string" ) {
      write,"Input name must be string";
      return [];
   }

   read_catalog, force=force, clog=clog;

   //+ w = where( strglob( name, strtrim(Source_cat.name), case=0));
   w = where( strglob( strcompress(name,all=1),  \
               strtrim(strcompress(Source_cat.name,all=1)), case=0));

   nw = numberof(w);

   if( nw == 0 ) {
      write,"No matching source found";
      return [];
   }

   if( am_subroutine() ) {
      write,"  # Name                     RA        DEC";
      write,"                             deg       deg";
      for( i = 1; i <= nw; i++ ) {
         write,format="%4i %s   %8.4f %8.4f\n", \
            w(i),Source_cat(w(i)).name, Source_cat(w(i)).ra_obj, \
            Source_cat(w(i)).dec_obj;
      }
   } else {
      if( nw == 1 ) return Source_cat(w(1));
      else return Source_cat(w);
   }

}

/* Function find_swid_galac */

func find_swid_galac( lon0, lat0, lonw, latw, offax=, rev=, tstart=,
                      tstop=, list=, nof=, silent=, lst= )
/* DOCUMENT list = find_swid_galac( lon0, lat0, lonw, latw2[, offax=]
                       [,rev=][, tstart=][, tstop=][, list=]
                       [,nof=][, silent=][, lst=] )

   Find the INTEGRAL SWIDs where the angular distance of the pointings
   is less than lonw from lon0 in longitudinal direction and similarly
   for the latitude: A belt is selected e.g.
       lon0 = 0, lat0 = 0, lonw = 30., latw = 10
   will include pointings with longitude 0 - 30 deg and 330 - 360 deg
   in the latitude interval -10 -> 10 deg.

    2007-11-16/NJW  copied from find_swid_radec

   Keywords:
             offax:  When set the result will be sorted
                     by increasing off-axis angle
             rev:    Either scalar integer or 2 element integer
                     array with min and max revolution number
             tstart: Time in IJD for start of interval
             tstop:  Time in IJD for end of interval
             list :  Makes returned list a list of SWIDs (default)
             lst  :  Makes returned list a list of SWIDs in jemx.lst format
                         (overrides setting of 'list')
             nof  :  Flag to avoid file writing
*/
{


   local swid, ra, dec, posangle, ut, ijd, telapse, mode1, mode2;

   if( is_void(latw) ) {
      write,"Syntax: list = find_swid_galac(lon,lat,lonw,latw, keywords... )";
      return [];
   }
   //
   //  Initialize
   //
   if( is_void(silent) ) silent = 0;
   first = 1;
   tbegin = is_void( tstart ) ? 0.0 : tstart;
   // if( tstart ) { tbegin = tstart; } else { tbegin = 0.0; }
   tend = is_void( tstop ) ? 1.0e9 : tstop;
   // if( tstop ) { tend = tstop; } else { tend = 1.0e9; }
   lon0 = double(lon0);
   lat0 = double(lat0);
   lonw = double(lonw);
   latw = double(latw);
   radec = equatorial( lon0, lat0 );
   ra0 = radec(1);
   dec0 = radec(2);

   //
   // Get list of pointing files
   //
   base = get_env("J_POINTINGS");
   if( numberof(rev) ) {
      if( typeof(rev) == "string" ) {
         revarr = str2arr( rev );
      } else {
         if( numberof( rev ) == 2 ) {
            revarr = indgen(long(rev(2)-rev(1))+1) + long(rev(1)) - 1;
         } else {
            revarr = long(rev)
         }
      }
      nrev = numberof(revarr);
      for( i = 1; i <= nrev; i++ ) {
         revstr = swrite(revarr(i),format="%4.4i");
         tmp = base+"/pointings_"+revstr+"p.dat";
         if( !silent ) write,tmp;
         ybase = base+"/ysav"+swrite(revarr(i)/100,format="%02i/");
         ytmp = ybase+"pointings_"+revstr+"p.ysav";
         if( !silent ) write,ytmp;
         if( i == 1 ) {
            pf_list = tmp;
            ypf_list = ytmp;
         } else {
            grow,pf_list,tmp;
            grow,ypf_list,ytmp;
         }
      }
   } else {
      pf_list = file_search("pointings_*p.dat", base);
      ypf_list = pf_list;
      npf_list = numberof(pf_list);
      for( i = 1; i <= npf_list; i++ ) {
         pos = strpos( pf_list(i),"_" );
         revstra = strpart(pf_list(i), pos+1:pos+4 );
         drevstra = strpart(pf_list(i),pos+1:pos+2);
         ybase = base+"/ysav"+drevstra;
         ytmp = ybase+"/pointings_"+revstra+"p.ysav";
         ypf_list(i) = ytmp;
      }
   }
   npf_list = numberof(pf_list);
   if( npf_list == 0 ) {
      write,"find_swid_galac error: no pointing files of required kind found";
      return -1;
   }

   if( !nof ) {

      // Open output file

      outfilename = get_next_filename("find_swid_galac_???.dat");
      fout = open(outfilename,"w");
      n = write(fout,format="%s\n","//");
      n = write(fout,format="//        %s\n", ndate(2));
      n = write(fout,format="// lon0  = %7.3f; deg\n", lon0);
      n = write(fout,format="// lat0 = %7.3f; deg\n", lat0);
      n = write(fout,format="// ra0  = %7.3f; deg\n", ra0);
      n = write(fout,format="// dec0 = %7.3f; deg\n", dec0);
      n = write(fout,format="// lonw = %7.3f; deg\n", lonw);
      n = write(fout,format="// latw = %7.3f; deg\n", latw);
      if( tstart ) {
         n = write(fout,format="// tstart = %14.8f; IJD\n", tstart);
      }
      if( tstop ) {
         n = write(fout,format="// tstop = %14.8f; IJD\n", tstop);
      }
      if( numberof(rev) ) {
         if( nrev == 1 ) {
            n = write(fout,format="// rev_begin = %4i\n", revarr(1));
            n = write(fout,format="// rev_end   = %4i\n", revarr(1));
         } else {
            n = write(fout,format="// rev_begin = %4i\n", revarr(1));
            n = write(fout,format="// rev_end   = %4i\n", revarr(0));
         }
      }

   }

   ntotal = 0;
   for( ipf_list = 1; ipf_list <= npf_list; ipf_list++ ) {

      if( file_test(ypf_list(ipf_list)) ) {
         if( !silent ) write,"Reading binary file "+ypf_list(ipf_list);
         bfile = openb( ypf_list(ipf_list) );
         restore,bfile, swid, ra, dec, posangle, ut, ijd, telapse, \
                     mode1, mode2;
         close, bfile;
      } else {
         if( !silent ) write,"Reading usual text file "+pf_list(ipf_list);
         if( ! file_test(pf_list(ipf_list)) ) {
            if( !silent ) write,pf_list(ipf_list)+" was not found";
            continue;
         }

      /*
       * swid = rscol( pf_list(ipf_list),1, str=1, silent=1);
       * ra = rscol( pf_list(ipf_list), 2, silent=1);
       * dec = rscol( pf_list(ipf_list), 3, silent=1);
       * posangle = rscol( pf_list(ipf_list), 4, silent=1);
       * ut = rscol( pf_list(ipf_list), 5, str=1, silent=1);
       * ijd = rscol( pf_list(ipf_list), 6, silent=1);
       * telapse = rscol( pf_list(ipf_list),7, silent=1);
       * mode1 = rscol( pf_list(ipf_list), 8, str=1, silent=1);
       * mode2 = rscol( pf_list(ipf_list), 9, str=1, silent=1);
       */

         rstab,pf_list(ipf_list), 9, swid, ra, dec, posangle, ut, \
              ijd, telapse, mode1, mode2, typ="sfffsffss",silent=1;

         bfile = createb( ypf_list(ipf_list) );
         save, bfile,  swid, ra, dec, posangle, ut, ijd, telapse, \
                 mode1, mode2;
         close, bfile;
      }

      npointings = numberof( ra );

      galac = galactic( ra, dec );
      zero = array(0.0, npointings );
      dist_lon = arcdist( lon0, 0., galac(,1), zero );
      dist_lat = arcdist( 0., lat0, zero, galac(,2) );

      dist = arcdist( ra0, dec0, ra, dec );
      w = where( dist_lon < lonw & dist_lat < latw );
      nw = numberof(w);

      if( nw > 0 ) {

         if( first ) {
            first = 0;
            swid_all = swid(w);
            ra_all = ra(w);
            dec_all = dec(w);
            posangle_all = posangle(w);
            ut_all = ut(w);
            ijd_all = ijd(w);
            telapse_all = telapse(w);
            mode1_all = mode1(w);
            mode2_all = mode2(w);
            dist_all = dist(w);
         } else {
            grow,swid_all,swid(w);
            grow,ra_all,ra(w);
            grow,dec_all,dec(w);
            grow,posangle_all,posangle(w);
            grow,ut_all,ut(w);
            grow,ijd_all,ijd(w);
            grow,telapse_all,telapse(w);
            grow,mode1_all,mode1(w);
            grow,mode2_all,mode2(w);
            grow,dist_all,dist(w);
         }

         ntotal += nw;

      }

   }
   if( ntotal == 0 ) {
      write,"Sorry, no pointings found!";
      return [];
   }

   if( offax ) {
      is = sort(dist_all);
      swid_all = swid_all(is);
      ra_all = ra_all(is);
      dec_all = dec_all(is);
      posangle_all = posangle_all(is);
      ut_all = ut_all(is);
      ijd_all = ijd_all(is);
      telapse_all = telapse_all(is);
      mode1_all = mode1_all(is);
      mode2_all = mode2_all(is);
      dist_all = dist_all(is);
   }

   noutput = 0;
   list = "";
   lfirst = 1;
   for( i = 1; i <= ntotal; i++ ) {
      if( ijd_all(i) > tbegin && ijd_all(i) < tend ) {

         if( lfirst ) {
            list_list = [swid_all(i)];
            lfirst = 0;
         } else grow,list_list,swid_all(i);
         if( !nof) {
          n = write(fout,format="%s%10.4f%9.4f%9.3f  %s%10.3f%6.0f  %s  %s %8.2f\n",
            swid_all(i),ra_all(i),dec_all(i),posangle_all(i),
            ut_all(i),ijd_all(i),telapse_all(i),
            mode1_all(i),mode2_all(i),dist_all(i));
         }
         noutput++;
      }
   }

   lst_list = array("",ntotal);
   for( i = 1; i <= ntotal; i++ ) {
      lst_list(i) = "./scw/"+strpart(swid_all(i),1:4)+"/"+swid_all(i)+".001/swg.fits[1]";
   }

   if( !nof ) close,fout;

   if( !silent ) {
      write,format="Found %i SWIDs in selected revolutions\n", ntotal;
      if( noutput == 1 ) {
         write,format="%i has been selected by time\n", noutput;
      } else {
         write,format="%i have been selected by time\n", noutput;
      }
      if( !nof ) write,"Output is directed to "+outfilename;

   }

   if( !is_void(lst) ) { return lst_list; } else {return list_list;}

}

/* Function j_mk_vignet */

func j_mk_vignet( imDims, radiusLimit, im_cent_x, im_cent_y, scale= )
/* DOCUMENT vignet = j_mk_vignet( imDims, radiusLimit, im_cent_x, im_cent_y, scale= )

   Returns a vignetting array with dimensions 'imDims' e.g. [2,790,790]
   (result of dimsof(image)).
   'radiusLimit' is the radius of the (circular) detector area used, in mm.
   The image must have pixels of 1.00 mm. Otherwise the 'scale' keyword
   must be given as pixel size in mm.

   2007-11-23/NJW, copied from jic_mk_vignet.i
*/
{


   if( is_void(im_cent_y) ) {
      write,"Syntax: vignet = j_mk_vignet( imDims, radiusLimit, im_cent_x, im_cent_y )";
      return [];
   }

   if( numberof(imDims) != 3 ) {
      write,"j_mk_vignet: First argument must be 3-element array";
      return [];
   }

   if( is_void(scale) ) scale = 1.0;

   rad2deg = 180.0 / pi;
   im_cent_x = double(im_cent_x);
   im_cent_y = double(im_cent_y);
   vignet = array(double,imDims);
   // Make pixel distances in mm
   d_mm = distances(imDims(2),imDims(3),im_cent_x,im_cent_y)*scale;
   for( i = 1; i <= imDims(2); i++ ) {
   for( j = 1; j <= imDims(3); j++ ) {
      offaxis = atan( d_mm(i,j) / 3401. ) * rad2deg; // Detector Mask distance is 3401 mm
      if( i == im_cent_x && j == im_cent_y ) {
         vignet(i,j) = 1.0;
      } else {
         omega = atan(abs(j - im_cent_y), abs(i - im_cent_x)) * rad2deg;
         vignet(i,j) = j_thruput( offaxis, radiusLimit, omega );
      }
   }
   }

   return vignet;
}

/* Function get_revol_start_time */

func get_revol_start_time( revol, fmt= )
/* DOCUMENT res = get_revol_start_time( revol, fmt= )

   Keyword fmt:   "ijd" (default) or "ymd"

   2009-04-17/NJW
*/
{
   dol = "/r6/jemx/integral_history/revolution_latest.fits+1";

   revol_no = double(rdfitscol(dol, "REVOLUTION"));
   time_perigee = rdfitscol(dol, "TIME_PERIGEE");
   nrev = numberof(revol_no);

   w = where( revol_no == revol );
   nw = numberof(w);

   if( nw != 1 ) {
      write,"Exceeded revol information";
      return [];
   }
   if( is_void(fmt) ) fmt = "ijd";
   res =  fmt == "ymd" ? ijd2dattim(time_perigee(w(1))) : time_perigee(w(1));
   if( am_subroutine() ) {
      if( fmt == "ymd" ) {
         write,format="Time of perigee: %s\n", res;
      } else {
         write,format="Time of perigee (IJD) : %11.6f\n", res;
      }
   } else return res;
}
   

/* Function get_revol_no */

func get_revol_no( time, frac= )
/* DOCUMENT revol = get_revol_no( time, frac= )

   Use /r6/jemx/integral_history/revolution_latest.fits to return
   revolution number for a given time

   The time parameter can be given as IJD or as string 'YYYY-MM-DDTHH:MM:SS' (UTC)

   2004-06-04/NJW
   2005-08-16/NJW updated with fractional result
   2007-12-11/NJW translated to Yorick

*/
{
   if( is_void(time) ) {
      write,"Syntax: revol = get_revol_no( time, frac= )";
      write,"   'time' can be given as IJD or as string 'YYYY-MM-DDTHH:MM:SS'";
      write,"   If keyword 'frac' is set then it returns revolution with fraction";
      return [];
   }

   // Determine the type of input

   ijd = typeof(time) == "string" ? dattim2ijd(time) : time;

   dol = "/r6/jemx/integral_history/revolution_latest.fits+1";

   revol_no = double(rdfitscol(dol, "REVOLUTION"));
   time_perigee = rdfitscol(dol, "TIME_PERIGEE");
   nrev = numberof(revol_no);

   // The TIME_PERIGEE refers to the beginning of the revolution

   if( ijd < time_perigee(1) - 1.0 )  return -1;  // Definitely before INTEGRAL mission
   if( ijd > time_perigee(0) )  return -999;  // After highest revolution given

   if( ijd < time_perigee(1) ) { // Reset to time_perigee(1) plus epsilon
      ijd = time_perigee(1) + 0.001;
   }

   w = where( time_perigee < ijd );
   nw = numberof(w);

   if( frac ) {
      fraction = (ijd - time_perigee(w(0))) \
         / (time_perigee(w(0)+1) - time_perigee(w(0)));
      return  revol_no(w(0)) + fraction;
   } else {
      return  revol_no(w(0));
   }

}

/* Function j_cor2raw */

func j_cor2raw( jemxNum, corx, cory, &rawx, &rawy )
/* DOCUMENT j_cor2raw, jemxNum, corx, cory, >rawx, >rawy

    Procedure to get raw positions from corrected ones

    2003-04-17/NJW original version
    2004-08-19/NJW This "procedure" version
    2007-12-21/NJW Translated to Yorick

*/

{
   extern Njmx_com, Acorx, Acory;

   if( is_void( cory ) ) {
      write,"Syntax: j_cor2raw, jemxNum, corx, cory, >rawx, >rawy";
      return [];
   }

   reread = 0;
   if( is_void(Njmx_com) ) {
      reread = 1;
   } else {
      if( jemxNum  !=  Njmx_com ) reread = 1;
   }

   if( reread ) {
      write,"Reading correction matrices ...";
      if( jemxNum  ==  1 ) {
         Acorx = readfits("/r6/jemx/ic/imod_grp/jmx1_imod_grp_0117.fits+22");
         Acory = readfits("/r6/jemx/ic/imod_grp/jmx1_imod_grp_0117.fits+23");
      } else {
         Acorx = readfits("/r6/jemx/ic/imod_grp/jmx2_imod_grp_0117.fits+22");
         Acory = readfits("/r6/jemx/ic/imod_grp/jmx2_imod_grp_0117.fits+23");
      }
      Njmx_com = jemxNum;
   }

   //   Define outline of squares

   dx1 = [-1,0,1,1,1,0,-1,-1];
   dy1 = [-1,-1,-1,0,1,1,1,0];
   dx2 = [-2,-1,0,1,2,2,2,2,2,1,0,-1,-2,-2,-2,-2];
   dy2 = [-2,-2,-2,-2,-2,-1,0,1,2,2,2,2,2,1,0,-1];
   dx3 = [-3,-2,-1,0,1,2,3,3,3,3,3,3,3,2,1,0,-1,-2,-3,-3,-3,-3,-3,-3];
   dy3 = [-3,-3,-3,-3,-3,-3,-3,-2,-1,0,1,2,3,3,3,3,3,3,3,2,1,0,-1,-2];

   num = numberof(corx);
   rawx = array(int,num);
   rawy = array(int,num);

   for( j = 1; j <= num; j++ ) {

   //  approximate result

      rx0 = toint(corx(j) + 127);
      ry0 = toint(cory(j) + 124);
      rx = rx0; // This is index with start zero
      ry = ry0;
   
      found = 0;
      if( abs(corx(j) - Acorx(rx+1,ry+1))  <  1.e-4 \
             && abs(cory(j) - Acory(rx+1,ry+1))  <  1.e-4 ) {
         found = 1;
      } else { // search inner circle
         for( i = 1; i <= 8; i++ ) {
            rx = rx0 + dx1(i);
            ry = ry0 + dy1(i);
            if( 0  <=  rx && rx  <=  255 && 0  <=  ry && ry  <=  255 ) {
               if( abs(corx(j) - Acorx(rx+1,ry+1))  <  1.e-4 \
                        && abs(cory(j) - Acory(rx+1,ry+1))  <  1.e-4 ) {
                  found = 1;
                  break;
               }
            }
         }
      }
   
      if( ! found ) { // search next ring
         for( i = 1; i <= 16; i++ ) {
            rx = rx0 + dx2(i);
            ry = ry0 + dy2(i);
            if( 0  <=  rx && rx  <=  255 && 0  <=  ry && ry  <=  255 ) {
               if( abs(corx(j) - Acorx(rx+1,ry+1))  <  1.e-4 \
                           && abs(cory(j) - Acory(rx+1,ry+1))  <  1.e-4 ) {
                  found = 1;
                  break;
               }
            }
         }
      }
   
   
      if( ! found ) { // search next again
         for( i = 1; i <= 24; i++ ) {
            rx = rx0 + dx3(i);
            ry = ry0 + dy3(i);
            if( 0  <=  rx && rx  <=  255 && 0  <=  ry && ry  <=  255 ) {
               if( abs(corx(j) - Acorx(rx+1,ry+1))  <  1.e-4 \
                           && abs(cory(j) - Acory(rx+1,ry+1))  <  1.e-4 ) {
                  found = 1;
                  break;
               }
            }
         }
      }
   
      if( found ) {
         rawx(j) = rx;
         rawy(j) = ry;
      } else {
         rawx(j) = 255;
         rawy(j) = 255;
      }
   
   
   }

   if( num == 1 ) {
      rawx = rawx(1);
      rawy = rawy(1);
   }

}

/* Function mk_swid_lists */

func mk_swid_lists( ra, dec, radius, name )
/* DOCUMENT mk_swid_lists, ra, dec, radius, name

   Make SWID lists for both JMX1 and JMX2 where position
   (ra,dec) is inside radius 'radius' and the SWID has been
   found the jmx[12]_shd.list file in the JEMX data archive.
   'name' is a filename compatible identification string that
   becomes part of the output name: jmx[12]_<name>.list.

   2008-01-09/NJW
*/
{
   lis = find_swid_radec( ra, dec, radius, nof=1, list=1,silent=1);
   lis = lis(sort(lis));

// get the involved revolutions

   revols = strpart(lis,1:4);
   urevols = revols(uniq(revols));
   nu = numberof(urevols);
   jmx1_list = [];
   jmx2_list = [];

// Go through each revolution and pick the 'approved' SWIDs

   for( i = 1; i <= nu; i++ ) {
      oklist = "/r8/jemx/arc/rev_2/scw/"+urevols(i)+"/jmx1_shd.list";
      if( file_test(oklist) ) {
         shd_list = read_slist(oklist);
         grow, jmx1_list, filter_common( shd_list, lis );
      }
      oklist = "/r8/jemx/arc/rev_2/scw/"+urevols(i)+"/jmx2_shd.list";
      if( file_test(oklist) ) {
         shd_list = read_slist(oklist);
         grow, jmx2_list, filter_common( shd_list, lis );
      }
   }

   fnam = "jmx1_"+name+".list";
   write_slist,fnam,jmx1_list;
   write,format="Has written %s with %i swids\n", fnam, numberof(jmx1_list);
   fnam = "jmx2_"+name+".list";
   write_slist,fnam,jmx2_list;
   write,format="Has written %s with %i swids\n", fnam, numberof(jmx2_list);

}

/* Function build_swid_time_table */

func build_swid_time_table( topdir, outfile, clobber= )
/* DOCUMENT build_swid_time_table, topdir, outfile, clobber=

  Build a table of start and stop IJD times of pointings.

  'topdir' points to the directory under which the JEM-X data
           can be found for the given revolution.
  'outfile' is the path and name for the output table.

   If 'outfile' is a four character string then the filename will be set to
      /r6/jemx/integral_history/timetables/swid_timetable_RRRR.fits
      where RRRR is <outfile>

   If 'topdir' is a four character string ("RRRR") and 'outfile' is missing
   then standard values are assumed: /jemx/arc/rev_3/scw/RRRR and
   /r6/jemx/integral_history/timetables/swid_timetable_RRRR.fits

   In case the timetable file already exists the user will be asked if it
   should be overwritten. This is cancelled with keyword 'clobber'.

     2007-08-17/NJW copied from build_swid_time_table.pro
*/

{
   if( is_void(outfile) ) {
      if( typeof(topdir) != "string" ) topdir = itoa(topdir,4);
      if( strlen(topdir) == 4 ) {
         outfile = topdir;
         topdir = "/jemx/arc/rev_3/scw/"+topdir;
      } else {
         write,"Missing the second argument.";
         return;
      }
   }
   if( strlen(outfile) == 4 ) {
      outfilx = "/r6/jemx/integral_history/timetables/swid_timetable_"+outfile+".fits";
   } else outfilx = outfile;
  /*
   *  Check existence of previous version of table;
   */
   if( file_test(outfilx) ) {
      write,"Will update: "+outfilx;
      if( clobber ) {
         remove, outfilx;
      } else {
         //  Old version exists, ask what to do
         ans = rdline(prompt="File exists, stop (s) or remove (r) ? ... ");
         if( ans == "r" ) {
            remove, outfilx
         } else {
            write,"Skip further action ...";
            return;
         }
      }
   }
  /*
   * Get list of all SWGs below "topdir";
   */
   swg_name = "swg.fits";
   list = file_rsearch( swg_name, topdir );
   nlist = numberof( list );
   write,format="Found %i files by name of: %s\n", nlist, swg_name;

   if( nlist  ==  0 ) {
      write,format="Sorry, no SWGs in and below %s\n",topdir;
      return;
   }

   list = list(sort(list));

   tstart = array(double, nlist);
   tstop  = tstart;
   swid   = array( string, nlist);
   ra_scx = tstart;
   dec_scx= tstart;
   ra_scz = tstart;
   dec_scz= tstart;
   posangle = tstart;

   for( i = 1; i <= nlist; i++ ) {

      write,format="%s,  %i of %i\n", list(i), i, nlist;
      hdr = headfits(list(i)+"+1",nocheck=1);
      tstart(i) = fxpar(hdr,"TSTART");
      tstop(i) = fxpar(hdr,"TSTOP");
      swid(i) = fxpar(hdr,"SWID");
      ra_scx(i) = fxpar(hdr,"RA_SCX");
      dec_scx(i)= fxpar(hdr,"DEC_SCX");
      ra_scz(i) = fxpar(hdr,"RA_SCZ");
      dec_scz(i)= fxpar(hdr,"DEC_SCZ");
      posangle(i) = fxpar(hdr,"POSANGLE");

   }

   wrmfitscols, outfilx,"SWID",swid,"TSTART",tstart, \
                "TSTOP",tstop,"RA_SCX",ra_scx,"DEC_SCX",dec_scx, \
                "RA_SCZ",ra_scz,"DEC_SCZ",dec_scz, \
                "POSANGLE",posangle;

}

/* Function j_src_on_shadowgram */

func j_src_on_shadowgram( ra_scx, dec_scx, posangle, ra_src, dec_src )
/* DOCUMENT arr = j_src_on_shadowgram( ra_scx, dec_scx, posangle, ra_src, dec_src )

   Returns a 256x256 map with 1 (one) where the source can hit
   the detector. All other pixels are zero.

   NB: Currently only for JMX1

   2008-05-27/NJW

*/
{
   r = j_get_scz( ra_scx, dec_scx, posangle, deg=1 );
   ra_scz = r(1);
   dec_scz = r(2);

   srcvec = vector( ra_src, dec_src, deg=1 );
   xvec = vector( ra_scx, dec_scx, deg=1 );
   zvec = vector( ra_scz, dec_scz, deg=1 );
   yvec = crossprod( zvec, xvec );

   mask_center = [sum(yvec*srcvec),sum(zvec*srcvec)]*(-3401.);
   offset = [128.,124.];

   d = distances(256,256,mask_center(1)+offset(1), \
                         mask_center(2)+offset(2) );
   res = array(long,256,256);
   w = where( d < 267.5 );
   if( numberof(w) > 0 ) {
      res(w) = 1;
   }
   return res;

}

/* Function j_get_scz */

func j_get_scz( ra_scx, dec_scx, posangle, deg= )
/* DOCUMENT res = j_get_scz( ra_scx, dec_scx, posangle, deg= )

   Returns the ra_scz and dec_scz in a two-element array.
   By default the unit is radian, but setting the keyword 'deg'
   will change to degrees (both input and output).

   2008-05-27/NJW
*/
{
   dr = deg ? pi/180.0 : 1.0;
   ax = ra_scx * dr;
   dx = dec_scx * dr;
   Theta = posangle * dr;

   cT = cos(Theta);
   dz = asin(cT * cos(dx));
   B = atan( sin(Theta), -sin(dx)*cT );

   az = zero2pi(ax - B);
   return [ az, dz ]/dr;

}

/* Function j_collect_spectra */

func j_collect_spectra( ref_sourceid, spec_path=, srcid2=, jemxNum=, \
                     flist=, outfile=, outarf=, noplot=, proj= )
/* DOCUMENT j_collect_spectra, ref_sourceid, spec_path=, srcid2=, jemxNum=, \
                     flist=, outfile=, outarf=, noplot=, proj=

   Get several spectra combined from data produced with j_src_spectra i.e.
   including mandatory keywords, ARF etc. assuming the naming convention
   jmxi_srcl_spe_proj_*.fits, where 'proj' is defined by keyword 'proj'.
   If 'proj' is not given, then jmxi_srcl_spe.fits is assumed (and then
   in various sub-directories).

    2003-04-11/NJW
    2008-01-17/NJW Translated from IDL to Yorick

 Arguments:
   ref_sourceid = "crab"
       will translate to ref_sourceid = "J053432.0+220052";
   ref_sourceid = "J195821.7+351206" ; Cyg X-1
   ref_sourceid = "J171958.0-314648"  ; XTE1720-318
   ref_sourceid2 = "XTE1720-318"

 Keywords:
   spec_path    directory under which the spectra can be found
   srcid2       alternative source name
   jemxNum      JEM-X unit
   flist        list of files to override 'spec_path'
   outfile       output spectral file
   outarf       output ARF file
          both outfile and outarf must be defined to have an effect
          else the output file will be jmxi_0000_spe.fits etc.
   noplot       to avoid plotting

*/
{

   if( is_void(jemxNum) ) jemxNum = 1;
   if( jemxNum  !=  1 && jemxNum  !=  2 ) {
      write,"Illegal JEMX number";
      return [];
   }
   jstr = "jmx"+itoa(jemxNum);

   if( ! numberof(flist) && is_void(spec_path) ) {
      write,"There is no indication of where to find the spectra ...";
      return [];
   }

   // See if both keywords "outfile" and "outarf" are set

   default_out_names = 1;
   if( numberof(outfile) ) {
      if( numberof(outarf) ) {
         default_out_names = 0; // don't use default output names
      } else {
         write,"Warning: only 'outfile' has been set - use default output names";
      }
   }

   pflag = is_void(noplot);

   // Get list of spectral files to include

   if( numberof(flist) ) {

      list = flist;

   } else {

      write,"Start building list  (takes some time) ...";
      if( is_void(proj) ) {
         searchname = jstr+"_srcl_spe.fits";
      } else {
         searchname = jstr+"_srcl_spe_"+proj+"_*.fits";
      }
      list = file_search( searchname, spec_path );

      if( numberof(list) == 0 ) error,"No spectral files found of name: "+searchname;

   }

   // Apply special case for Crab

   if( strtolower(ref_sourceid)  ==  "crab" ) ref_sourceid = "J053432.0+220052";

   nlist = numberof(list);
   list = list(sort(list));
   list_used = list;
   nlist_used = 0;


   // Prepare the output files jmxi_nnnn_spe.fits and jmxi_nnnn_arf.fits;
   // in the current directory but only if keywords outfile and outarf are set;

   if( default_out_names ) {

      local strnum;
      fname_spe = get_next_filename(jstr+"_????_spe.fits",strnum);
      fname_arf = strput( fname_spe, "arf", 11 );
      logfile = "collect_spectra_"+strnum+".log";

   } else {

      fname_spe = outfile;
      fname_arf = outarf;
      logfile = get_next_filename("collect_spectra_????.log");

   }

   //+ cp,"/home/njw/jemx/spectra/"+jstr+"_coll_spe.fits",fname_spe;
   //+ cp,"/home/njw/jemx/spectra/"+jstr+"_coll_arf.fits",fname_arf;

   tot_arf  = array(float,500);
   tot_expo = 0.0;

   write,"Output logging data in "+logfile;
   lug = open(logfile,"w");

   write,lug,"  Logging of collect_spectra   "+ndate(3);
   write,lug;
   write,lug,"Resulting SPE file: "+fname_spe;
   write,lug,"Resulting ARF file: "+fname_arf;

   first = 1; // used for checking number of spectral bins (nchans)
   firstsum = 1; // used for making the sums of spectra

   for( i = 1; i <= nlist; i++ ) {

      write,"Analyzing "+itoa(i)+" of "+itoa(nlist);
      write,lug,"-------------------------------";
      write,lug,list(i);
      // Note if path is absolute
      first_char = strpart(list(i),1:1); // to be used for ARF name
      // Get header
      if( i  >  1 ) respfile_prev = respfile_ori;
      hdr = headfits(list(i)+"+1");
      nsources = fxpar(hdr,"NAXIS2");
      if( nsources  <=  0 ) {
         write,"Skip - no sources";
         write,lug,"Skip this one, there are no sources";
         continue;
      }
      respfile_ori = fxpar(hdr,"RESPFILE");
      tok = strsplit(respfile_ori,"/");
      ntok = numberof(tok);
      jj = -1;
      for( j = 1; j <= ntok; j++ ) {
         if( strlen(tok(j))  >=  18 ) {
            p1 = strpos(tok(j),"jmx",1);
            p2 = strpos(tok(j),"rmf",1);
            p3 = strpos(tok(j),"fits",1);
            if( p1  >  0 && p2  >  0 && p3  >  0 ) {
               jj = j;
               break;
            }
         }
      }
      if( jj  >  0 ) {
         respfile = tok(jj);
         write,lug,"RESPFILE = "+respfile;
      } else {
         write,lug,"RESPFILE is unidentified";
         write,"Problem finding the RESPFILE";
      }
      if( i  >  1 ) {
         if( respfile_ori  !=  respfile_prev ) {
            write,"Warning - change of response file";
            write,lug,"Warning - change of response file";
         }
      }
      // read the source identifications
      sourceid = rdfitscol(list(i)+"+1","ROWID");
      exposure = rdfitscol(list(i)+"+1","EXPOSURE");
      ancrfile = rdfitscol(list(i)+"+1","ANCRFILE");
      ancrfile = strtrim(ancrfile);
      sourceid = strtrim(sourceid);
      write,lug,"Source IDs: "+sourceid;
      // locate actual source;
      if( numberof(srcid2) ) {
         w = where( sourceid  ==  ref_sourceid | sourceid  ==  srcid2);
      } else {
         w = where( sourceid  ==  ref_sourceid);
      }
      n_w = numberof(w);

      if( n_w  ==  1 ) {

         // include this one in the list of used spectral files;
         list_used(nlist_used) = list(i);
         nlist_used = nlist_used + 1;

         write,lug,"Actual source is number "+itoa(w(1))+" (starting with 1)";

         pick_swid_str, list(i), swid;
         swid = numberof(swid) ? swid(1) : "Unknown SWID";

         //+ tok = strsplit(list(i),"/",/extract);
         //+ ntok = numberof(tok);
         write,lug,swid+"  "+itoa(nsources)+" sources";
         write,lug,format="Exposure time is %10.2f s\n",exposure(w(1));

         // Get the spectrum etc.

         ra_obj =   rdfitscol(list(i)+"+1","RA_OBJ");
         dec_obj =  rdfitscol(list(i)+"+1","DEC_OBJ");
         rate =     rdfitscol(list(i)+"+1","RATE");
         stat_err = rdfitscol(list(i)+"+1","STAT_ERR");
         nch = dimsof(rate)(2);
         if( first ) {
            nchans = nch;
            first = 0;
         } else {
            if( nch != nchans ) error,"##1## varying number of channels";
         }
         if( pflag ) {
   	 dataplot,indgen(nchans),rate(,w(1)),stat_err(,w(1));

            if( jj  >=  1 ) xyouts,0.25,0.82,swid,charsize=1.3,ndc=1;
            xyouts,0.25,0.80,swrite(format="Exposure %10.2f s",exposure(w(1))), \
                      charsize=1.3,ndc=1;

         }

         //  --    Get the corresponding ARF file;

         // First check if ARF file name is absolute or relative

         ancr = strip_curly_br(strtrim(ancrfile(w(1))));
         if( strpart( ancr, 1:1 ) == "/" ) { // absolute path name, no change
            arffile = ancr;
         } else {  // we have a relative name, append to path found in 'list(i)'

            //+ tok = strsplit( list(i), "/" );
            dirlist = dirname( list(i) );
            //+ ntok = numberof(tok);
            //+ tok(ntok) = strip_curly_br(ancrfile(w(1)));
            //+ arffile = strjoin(tok, "/");
            //+ if( first_char  ==  "/" ) arffile = "/"+arffile;

            arffile = dirlist + "/" + ancr;
         }

         if( !file_test(arffile) ) {
            write,format="ARF is missing: %s\n", arffile;
            close,lug;
            return [];
         }
         arf = rdfitscol(arffile+"+1","SPECRESP");
         energ_lo = rdfitscol(arffile+"+1","ENERG_LO");
         energ_hi = rdfitscol(arffile+"+1","ENERG_HI");
         tot_arf  += reform(arf(,w(1)),500)*exposure(w(1));
         if( firstsum ) {
            tot_spec = float(reform(rate(,w(1)),nchans)*exposure(w(1)));
            tot_err2 = float((reform(stat_err(,w(1)),nchans)*exposure(w(1)))^2);
            firstsum = 0;
         } else {
            tot_spec += float(reform(rate(,w(1)),nchans)*exposure(w(1)));
            tot_err2 += float((reform(stat_err(,w(1)),nchans)*exposure(w(1)))^2);
         }
         tot_expo += exposure(w(1));
      } else write,lug,"Source was not found";

   }

   write,lug,"// total_exposure = ", tot_expo," ; s";
   write,lug,"//  --- Normal exit ---";

   close,lug;

   tot_arf  = tot_arf  / tot_expo;
   tot_spec = tot_spec / tot_expo;
   tot_err  = sqrt(tot_err2) / tot_expo;

   if( pflag ) dataplot,indgen(nchans),tot_spec,tot_err;

   //  Update standard file with collected spectrum;

   write,"New spectrum file: "+fname_spe;

 /*  ----------  remove
  *
  *fh = headfits( fname_spe+"+1" );
  *colnum = get_colnum( fh, "rowid" );
  *fits_bintable_poke, fname_spe+"+1", -1, colnum, sourceid(w(1));
  *colnum = get_colnum( fh, "ra_obj" );
  *fits_bintable_poke, fname_spe+"+1", -1, colnum, ra_obj(w(1));
  *colnum = get_colnum( fh, "dec_obj" );
  *fits_bintable_poke, fname_spe+"+1", -1, colnum, dec_obj(w(1));
  *colnum = get_colnum( fh, "rate" );
  *fits_bintable_poke, fname_spe+"+1",  1, colnum, float(tot_spec);
  *colnum = get_colnum( fh, "stat_err" );
  *fits_bintable_poke, fname_spe+"+1",  1, colnum, float(tot_err);
  *colnum = get_colnum( fh, "exposure" );
  *fits_bintable_poke, fname_spe+"+1",  1, colnum, double(tot_expo);
  *colnum = get_colnum( fh, "ancrfile" );
  *fits_bintable_poke, fname_spe+"+1", -1, colnum, [fname_arf+"{1}"];
  ********/

/******************
   //  Update the RESPFILE keyword && add the list;
   //  of input files;

   lut = open("tmpfil","w");
   write,lut,format="RESPFILE = '%s'\n","/r6/jemx/ic/rmf_grp/"+respfile;
   write,lut,format="SOURCEID = '%s'\n",ref_sourceid;
   for( i = 1; i <= nlist_used; i++ ) {
      s = list_used(i);
      len = strlen(s);
      while( len  >  70 ) {
         scut = strpart(s,1:70)+" $";
         write,lut,format="COMMENT %s\n", scut;
         s = strpart(s,71:9999);
         len = strlen(s);
      }
      write,lut,format="COMMENT %s\n",s;
   }

   close,lut;

   system,"fmodhead "+fname_spe+"+1 tmpfil=tmpfil";

   //  Update the checksum;

   system,"fchecksum "+fname_spe+" update=yes";

   //  Update file with collected average ARF;


   write,"New ARF file: "+fname_arf;
   colnum = get_colnum(fname_arf+"+1", "SPECRESP" );
   fits_bintable_poke, fname_arf+"+1", 1, colnum, float(tot_arf);
***************************/

   kwds_init;

   for( i = 1; i <= nlist_used; i++ ) {
      s = list_used(i);
      len = strlen(s);
      while( len  >  70 ) {
         scut = strpart(s,1:70)+" $";
         kwds_set,"COMMENT", scut;
         s = strpart(s,71:9999);
         len = strlen(s);
      }
      kwds_set,"COMMENT", s;
   }
   kwds_set,"DATE",ndate(3),"Date/time of file creation";

   spec2phaii, fname_spe, tot_spec, tot_err, type="net", exposure=tot_expo, \
       ancrfile=fname_arf, respfile=respfile_ori, rowid=ref_sourceid, \
       ra_obj=ra_obj(w(1)), dec_obj=dec_obj(w(1)), \
       telescop="INTEGRAL", instrume=strupcase(jstr), no_kwds_init=1;

   system,"fchecksum "+fname_spe+" update=yes";

   arf2phaii, fname_arf, tot_arf, energ_lo(,1), energ_hi(,1), telescop="INTEGRAL", \
              instrume=strupcase(jstr);

   //  Update the checksum;

   system,"fchecksum "+fname_arf+" update=yes";

   write,"New ARF file: "+fname_arf;

}

/* Function upd_ancrfile */

func upd_ancrfile( spec_file_list, ancrfile= )
/* DOCUMENT upd_ancrfile, spec_file_list, ancrfile=

   No keyword 'ancrfile' given:
   Assuming that spectral file names are given as *_srcl_spe_*.fits
   then the ANCRFILE information is updated to *_srcl_arf_*.fits in
   the same directory as the spectral file.

   Else when keyword 'ancrfile' has been given:
   Update to the given file name.

   2008-08-08/NJW
   2011-07-02/NJW, updated with keyword ancrfile
*/
{
   local dirname, basename;

   nlist = numberof(spec_file_list);

   if( typeof(ancrfile) == "string" ) {

      for( i = 1; i <= nlist; i++ ) {
         specfile = spec_file_list(i);
         arf = rdfitscol( specfile+"+1","ancrfile");
         narf = numberof(arf);
         arfs = array( ancrfile, narf );
         for( j = 1; j <= narf; j++ ) arfs(j) += "{"+itoa(j)+"}";
         fits_bintable_poke, specfile+"+1", 0, "ancrfile", arfs;
      }

   } else { // no ancrfile name given, compose one

      for( i = 1; i <= nlist; i++ ) {
         specfile = fullpath( spec_file_list(i) );
         // define ANCRFILE is same directory as spectral file
         splitfname, specfile, dirname, basename;
         pos = strpos( basename, "_srcl_spe_", 1 );
         if( pos == 0 ) {
            write,format="Sorry, %s does not conform - skip\n", specfile;
            continue;
         }

         arffile = dirname+"/"+strpart( basename, 1:pos+5 )+"arf"+strpart(basename, pos+9:0);
         if( !file_test( arffile ) ) {
            write,format="Sorry, %s has no matching ARF file\n", specfile;
            continue;
         }
         ancrfile = arffile+"{1}";
         arf = rdfitscol( specfile+"+1","ancrfile");
         length = strlen(arf(1));
         len = strlen(ancrfile);
         for(j=1;j<=length-len;j++) ancrfile += " ";
         for( j = 1; j <= numberof(arf); j++ ) arf(j) = ancrfile;

         fits_bintable_poke, specfile+"+1", 0, "ancrfile", arf;

         write,format="Has now updated %s\n", specfile;
      }

   }

}

/* Function j_get_src_spectrum */

struct s_Rdm {
   pointer rdm;
   pointer e_min;
   pointer e_max;
   pointer energ_lo;
   pointer energ_hi;
   pointer arf;
}

func j_get_src_spectrum( dol_of_spec, num_spec, &rate, &stat_err, &rdm, &exposure, sourceid=, silent= )
/* DOCUMENT j_get_src_spectrum, dol_of_spec, num_spec, >rate, >stat_err,
                          >rdm, >exposure, sourceid=, silent=

   Simple function to retrieve a given spectrum in PHA II format.
   The row number can be given as 'num_spec' but a SOURCE_ID name
   given in keyword 'sourceid' will make a search for the specified source.

   Returns 'rate', 'stat_err', the struct 'rdm', and 'exposure' in the arguments.
   The function value returned is 0, 1, or 2 giving the spectrum type 'net', 'bkg', or 'total'
   as specified with the OGIP standard.

   'rdm' has elements (pointers): rdm, e_min, e_max, energ_lo, and energ_hi.

   This function has an alias:  read_phaii_spectrum

   2008-01-01(?)/NJW
   2010-10-28/NJW updated with e_min, e_max return.
   2012-30-29/NJW updated with exposure and type return.
*/
{
   local file_of_spec, ext_num;
   rdm = s_Rdm();

   get_exten_no, dol_of_spec, file_of_spec, ext_num;
   if( ext_num == 0 ) dol_of_spec += "+1"; // assumes first extension

   if( !file_test( file_of_spec ) ) error,"Cannot find: "+file_of_spec;

   if( is_void(num_spec) ) num_spec = 1; // defaults to first spectrum
   if( num_spec <= 0 ) error,"Illegal num_spec value";

   rate = stat_err = [];

   if( !silent ) write,format="Data: #%i in %s\n", num_spec, dol_of_spec;

   // Get the header and various keywords

   hdr = headfits( dol_of_spec );
   naxis2 = fxpar( hdr, "naxis2" );
   respfile = fxpar( hdr, "respfile" );
   type = 0; // the default value implying a net spectrum (i.e. background subtracted)
   ogip = fxpar( hdr, "hduclass" );
   if( typeof(ogip) == "string" ) {
      if( strtrim(strlowcase(ogip)) == "ogip" ) {
         clas1 = fxpar( hdr, "hduclas1" );
         if( is_void(clas1) ) {
            write,"Warning! HDUCLAS1 keyword is missing";
         } else {
            if( strtrim(clas1) != "SPECTRUM" ) write,"Warning! HDUCLAS1 is not SPECTRUM";
         }
         clas2 = fxpar( hdr, "hduclas2" );
         if( is_void(clas2) ) {
            write,"Warning! HDUCLAS2 keyword is missing";
         } else {
            if( strtrim(clas2) == "NET" ) {
               type = 0;
            } else if( strtrim(clas2) == "BKG" ) {
               type = 1;
            } else if( strtrim(clas2) == "TOTAL" ) {
               type = 2;
            } else write,"Warning! HDUCLAS2 is alien: "+clas2;
         }
         clas3 = fxpar( hdr, "hduclas3" );
         if( is_void(clas3) ) {
            write,"Warning! HDUCLAS3 keyword is missing";
         } else {
            if( strtrim(clas3) != "RATE" ) write,"Warning! HDUCLAS3 is not RATE ("+clas3+")";
         }
      }
   }

   if( !is_void(sourceid) ) {
      rowid = strtrim(rdfitscol( dol_of_spec, "rowid" ));
      w = where( sourceid == rowid );
      if( numberof(w) == 0 ) error,"Requested source not found";
      num_spec = w(1);
      if( !silent ) write,"Extracting spec no. "+itoa(num_spec)+": "+sourceid;
   }
   if( !silent ) {
      if( naxis2 == 1 ) { write,itoa(naxis2)+" spectrum found";
      } else write,itoa(naxis2)+" spectra found";
      rowid = rdfitscol( dol_of_spec, "rowid" );
      for( i = 1; i <= naxis2; i++ ) write,format=" %2i: %s\n", i, strtrim(rowid(i));
      if( !is_void(respfile) ) {
         write,format="RESPFILE = %s\n", respfile;
      } else write,"No RESPFILE keyword found";
   }
   e_min = e_max = [];
   if( !is_void(respfile) ) {
      if( file_test(respfile) ) {
         if( !silent ) write,format="Response: %s\n", respfile;
         e_min = rdfitscol(respfile+"[EBOUNDS]","e_min");
         e_max = rdfitscol(respfile+"[EBOUNDS]","e_max");
         rdm.e_min = &e_min;
         rdm.e_max = &e_max;
         energ_lo = rdfitscol(respfile+"[MATRIX]","energ_lo");
         energ_hi = rdfitscol(respfile+"[MATRIX]","energ_hi");
         matrix = rdfitscol(respfile+"[MATRIX]","matrix");
         rdm.energ_lo = &energ_lo;
         rdm.energ_hi = &energ_hi;
         rdm.rdm = &matrix;
      } else write,"j_get_src_spectrum: "+respfile+" was not found";
   } else write,"j_get_src_spectrum: keyword RESPFILE was not found";

   if( naxis2 ) {
   
      // Test the number of the requested spectrum
      if( num_spec > naxis2 ) {
         write,format="Only %i spectra in file\n", naxis2;
         return;
      }

      // Get the spectrum and errors and exposure

      rate = rdfitscol(dol_of_spec,"rate")(,num_spec);
      stat_err = rdfitscol(dol_of_spec,"stat_err")(,num_spec);
      exposure = rdfitscol(dol_of_spec,"exposure")(num_spec);

      // Get the ANCRFILE i.e. the ARF

      ancrfile = strip_curly_br(strtrim(rdfitscol( dol_of_spec, "ancrfile" )(num_spec)));
      if( !file_test(ancrfile) ) {
         // try same directory as spec file
         dddir = dirname(file_of_spec);
         ancrfile = dddir+"/"+basename(ancrfile);
         if( !file_test(ancrfile) ) write,"Search for "+ancrfile+" failed";
      }
      if( file_test(ancrfile) ) {
         arf = rdfitscol(ancrfile+"+1","specresp")(,num_spec);
         if( is_void(arf) ) {
            write,format="No ARF found in %s\n", ancrfile;
         } else {
            if( !silent ) write,format="ARF from: %s\n", ancrfile;
            rdm.arf = &arf;
         }
      }

   } else {

      write,format="No spectra in %s\n", file_of_spec;

   }

}
read_phaii_spectrum = j_get_src_spectrum;

/* Function j_get_point_info_for_swid */

struct s_All {
   double ra_scx;
   double dec_scx;
   double posangle;
   double exposure;
   double gain;
}

/*
 *  This is in a rudimentary form and should be expanded
 */

func j_get_point_info_for_swid( jemxNum, swid )
/* DOCUMENT res = j_get_point_info_for_swid( jemxNum, swid )

   Reads the FITS pointing file in the directory given by the
   environment variable 'J_POINTINGS' and returns the struct s_All
   with the information for the chosen instrument in the
   'pointings_RRRR.fits' file.

   Struct elements: ra_scx, dec_scx, posangle, exposure, gain.

   2008-05-19/NJW (get_all_for_swid)
   2008-08-19/NJW Updated to get_point_info_for_swid
*/
{
   revol = strpart(swid,1:4);
   fil = get_env("J_POINTINGS") + "/pointings_" + revol + ".fits";

   if( !file_test(fil) ) {
      write,format="File no found: %s\n", fil;
      return [];
   }

   dol = fil+"+1";

   local fh, nrows;
   col_ptrs = rdfitsbin( dol, fh, nrows );
   colnum = fits_colnum( fh, "swid" );
   w = where(swid == *col_ptrs(colnum));

   if( numberof(w) < 1 ) {
      write,format="SWID %s not found in pointing file\n", swid;
      return [];
   }

   res = s_All();

   suffix = jemxNum == 1 ? "_j1" : "_j2";

   res.exposure = (*col_ptrs(fits_colnum(fh,"exposure"+suffix)))(w(1));
   res.gain     = (*col_ptrs(fits_colnum(fh,"gain"+suffix)))(w(1));
   res.ra_scx   = (*col_ptrs(fits_colnum(fh,"ra_scx")))(w(1));
   res.dec_scx  = (*col_ptrs(fits_colnum(fh,"dec_scx")))(w(1));
   res.posangle  = (*col_ptrs(fits_colnum(fh,"posangle")))(w(1));

   return res;

}

/* Function j_std_rebin */

func j_std_rebin( dol_spec, &ob1, &ob2, &orate, &orate_err, degree= )
/* DOCUMENT REBIN = j_std_rebin( dol_spec, >ob1, >ob2, >orate, >orate_err, degree= )
        or  REBIN = j_std_rebin()

   The former version will read the spectrum and return the
         rebinned spectrum
   The latter version will simply return the rebinning array

   Keyword  degree: 1 is the default
                    2 is coarser rebinning (for fainter sources)
                    3 is very coarse

   2008-05-29/NJW
   2008-08-19/NJW, updated with option
*/

{

   extern Eb1, Eb2;

   if( is_void(degree) ) degree = 1;

   // Define the standard rebinning array

   if( degree == 1 ) {
      REBIN = -39;
      grow, REBIN, array(1,10);
      grow, REBIN, array(2,10);
      grow, REBIN, array(3,30);
      grow, REBIN, array(2,33);
      grow, REBIN, -31;
   } else if( degree == 2 ) {
      REBIN = -45;
      grow, REBIN, array(2,15);
      grow, REBIN, array(3,10);
      grow, REBIN, array(4,10);
      grow, REBIN, array(5,5);
      grow, REBIN, array(6,5);
      grow, REBIN, -56;
   } else {
      REBIN = -45;
      grow, REBIN, array(3,15);
      grow, REBIN, array(5,10);
      grow, REBIN, array(7,5);
      r = 256 - sum(abs(REBIN));
      grow, REBIN, -r;
   }

   if( is_void(dol_spec) ) return REBIN;

   local rate, rate_err;
   j_get_src_spectrum, dol_spec, 1, rate, rate_err;

   if( is_void(Eb1) ) {
      j_get_pi_ebds, Eb1, Eb2;
   }

   specrebinning, Eb1, Eb2, rate, rate_err, REBIN, ob1, ob2, orate, orate_err;

   return REBIN;

}

/* Function mk_unique_cat */

func mk_unique_cat( dol_in_cat, file_unique_cat, clog=, chat=, accrad=, idrad= )
/* DOCUMENT mk_unique_cat, dol_in_cat, file_unique_cat, clog=, chat=, accrad=, idrad=

  Make a "unique catalog" i.e. where a source only appears once
  from the catalog in dol_in_cat.

  Preliminary identifications are inserted but it is advised to follow up by running
  'qidsrcs' with keyword uniq=1 (implying that a given gnrl_src_cat source can only
  by used once).

  Required columns in the input catalog: NAME, RA_OBJ, DEC_OBJ, DETSIG, ERR_RAD

  Keywords:
     clog     Set catalog DOL if different from the default one:
                                  /r6/jemx/catalogs/gnrl_refr_cat_latest.fits+1
     accrad   Acceptance radius in degrees (default value: 0.07 deg = 4.2 arcmin)
                 e.g. only accepted as same source if the distance is less than accrad
     idrad    Identification radius in degrees (default value: 0.07 deg)
     chat     Chattiness parameter

  2005-06-08/NJW  Cloned from /home/njw/0idl/proc/mk_unique_issw_cat.pro
  2005-10-28/NJW  Updated with column "NAME" in stead of "SRCNAME" and
                  extra column "ERR_RAD"
  2006-01-13/NJW  Only assign the source name after final positions has been found
                  and introduce a proper definition of the error radius (err_rad)
                  based on err_rad from input catalog

  2008-10-29/NJW translated to Yorick
  2008-11-18/NJW changed to handle the source identification better
  2008-11-25/NJW includes now the CLASS (source category) column

*/
{

   version = 5;   // NB: remember to update this value
   verdate = "2008-11-18";

   if( is_void(accrad) ) accrad = 0.07;
   if( is_void(idrad) ) idrad = 0.07;

   if( is_void(chat) ) chat = 1;

   logfile = get_next_filename("mujc_???.txt");
   flog = open(logfile,"w");



   // Read the contents of the input catalog

   write,format="Reading %s\n",dol_in_cat;
   write,flog,format="Input catlog: %s\n",fullpath(dol_in_cat);
   name = rdfitscol(dol_in_cat,"NAME");
   if( is_void(name) ) error,"Column NAME is missing in catalog";
   ra_obj = rdfitscol(dol_in_cat,"RA_OBJ");
   if( is_void(ra_obj) ) error,"Column RA_OBJ is missing in catalog";
   dec_obj = rdfitscol(dol_in_cat,"DEC_OBJ");
   if( is_void(dec_obj) ) error,"Column DEC_OBJ is missing in catalog";
   detsig = rdfitscol(dol_in_cat,"DETSIG");
   if( is_void(detsig) ) error,"Column DETSIG is missing in catalog";
   err_rad = rdfitscol(dol_in_cat,"ERR_RAD");
   if( is_void(err_rad) ) error,"Column ERR_RAD is missing in catalog";

   // Avoid negative DETSIG

   w = where( detsig  <  0.01 );
   nw = numberof(w);
   if( nw  >  0 ) {
      write,format="Warning: %i DETSIG values smaller than 0.01 exist\n", nw;
      write,"  The value of those is reset to 0.01";
      write,flog,format="Warning: %i DETSIG values smaller than 0.01 exist\n", nw;
      write,flog,"  The value of those is reset to 0.01";
      detsig(w) = 0.01;
   }

   num_entries_cat = numberof(ra_obj);
   if( chat  >  2 ) write,format="##0## num_entries_cat = %i\n", num_entries_cat;
   write,flog,format="Number of rows: %i\n", num_entries_cat;
   ismarked = array( int, num_entries_cat);


   // Define DOL and filename for the unique catalog as well as for the auxiliary
   //  Yorick save file

   pos = strpos( file_unique_cat,  ".fits", 0, rev=1 );
   if( pos > 0 ) {
      file_ysave = strpart( file_unique_cat, 1:pos ) + "ysave";
   } else file_ysave = "unique_cat_aux_"+ndate(1)+".ysave";

   dol_unique_cat = file_unique_cat+"+1";

   write,flog,format="DOL of output Unique cat: %s\n", fullpath(dol_unique_cat);
   write,flog,format="Filename of output Unique cat: %s\n", fullpath(file_unique_cat);
   write,flog,format="Yorick save file for list_int: %s\n", fullpath(file_ysave);


   //  Prepare arrays for saving unique data and allocating room for catalog
   //  source positions

   ra_obj_uniq = [];
   dec_obj_uniq = [];
   srcname_uniq = [];
   detsig_uniq = [];
   err_rad_uniq = [];
   pos_list_int = [];
   len_list_int = [];
   ra_cat_uniq = [];
   dec_cat_uniq = [];
   source_id_uniq = [];
   class_uniq = [];

   list_int = array( long, num_entries_cat);
   list_uno = array( long, num_entries_cat);

   //  Walk through the input catalog sources (i-sources)
   //  Pick the first one as the first resulting unique source (u-source)
   //  then assign all i-sources at same position to this one
   //  After that pick the next un-assigned i-source etc.


   cur = 1;
   uniq_no = 0;
   ans = "";
   dum = where( ismarked  ==  0 ); // Get number of unmarked i-sources
   num = numberof( dum );

   while( num  >  0 ) {

      uniq_no++;

      if( chat > 2 ) {
         write,format="Next unique source: %s\n", name(cur);
      }

      // Find the i-sources that can be identified with current u-source

      r = arcdist(ra_obj(cur), dec_obj(cur), ra_obj, dec_obj );
      w = where( r <=  accrad & ismarked == 0 );
      m = where( r > accrad | ismarked != 0 );
      nw = numberof(w);
      nm = numberof(m);
      bestpos = [ra_obj(cur), dec_obj(cur)];
      weight = array(1./nw,nw); // initial definition

      if( chat  >  4 ) {
         write," ----------  Begin with uniq_no = "+itoa(uniq_no)+" ---------";
         write,"     Initial  nw = "+itoa(nw);
         write,"     Working with unmarked finding cur:  "+itoa(cur);
         write,flog," ----------  Begin with uniq_no = "+itoa(uniq_no)+" ---------";
         write,flog,"     Initial  nw = "+itoa(nw);
         write,flog,"     Working with unmarked finding cur:  "+itoa(cur);
      }

      if( nw  ==  0 ) {
         write,format="Error ##1##, nw == 0, cur = %i, uniq_no = %i\n",cur,uniq_no;
         write,format="nw = %i, nm = %i\n", nw, nm;
         write,flog,format="Error ##1##, nw == 0, cur = %i, uniq_no = %i\n",cur,uniq_no;
         write,flog,format="nw = %i, nm = %i\n", nw, nm;
         close, flog;
         return;
      }

      if( nw  >  1 ) { // Try to iterate if it makes sense

         do {  // See if a better position as an average of all initially assigned
               // i-sources will change the selection
               // (the first source may be an outlier in a group)

            w_previous = w; // points to selected i-sources

            weight = detsig(w);
            if( max(weight)  <=  0.0 ) {
               weight = replicate(1., nw);
               write,format="DETSIG problem with input source cur = %i", cur;
               write,format="                and  uniq_no = %i\n", uniq_no;
               write,flog,format="DETSIG problem with input source cur = %i", cur;
               write,flog,format="                and  uniq_no = %i\n", uniq_no;
            }

            // normalize "weight"
            weight = weight / sum(weight);

            bestpos = best_skypos( ra_obj(w), dec_obj(w), weight );

            r = arcdist( bestpos(1), bestpos(2), ra_obj, dec_obj );
            w = where( r <= accrad & ismarked == 0 );
            m = where( r  > accrad | ismarked != 0 );
            nw = numberof(w);
            nm = numberof(m);

            if( chat  >  4 ) write,format="uniq_no = %i 2. nw = %i\n", uniq_no, nw;

            if( nw  ==  0 ) {
               write,"Mark ##2##";
               write,format="cur = %i,  uniq_no = %i\n", cur, uniq_no;
               write,format="nw = %i,  nm = %i\n", nw, nm;
               close, flog;
               return;
            }

            diff = numberof(w) == numberof(w_previous) ? 0 : 1;
            if( !diff ) {
               diff = anyof( w - w_previous );
            }
         } while( diff );

      }

      // Now we have a new unique source

      if( chat  >  4 ) {
         write,flog,format="New unique source, uniq_no: %i\n", uniq_no;
         write,flog,format="Number of contributions (nw) is %i\n", nw;
         write,flog,format="Number of contributions (numberof(w)) is %i\n", numberof(w);
         write,flog,format="bestpos: %9.4f %9.4f\n", bestpos(1), bestpos(2);
      }

      list_uno(w) = uniq_no;

      // Save values to storage arrays

      grow, ra_obj_uniq, bestpos(1);
      grow, dec_obj_uniq, bestpos(2);
      grow, detsig_uniq, max(detsig(w));
      grow, len_list_int, nw;
      len_list_int(uniq_no) = nw;
      if( uniq_no  ==  1 ) {
         pos_list_int = 1;
      } else {
         grow, pos_list_int, pos_list_int(uniq_no-1) + len_list_int(uniq_no-1);
      }
      list_int(pos_list_int(uniq_no):pos_list_int(uniq_no)+nw-1) = w;

      // Get sourcename from standard X-ray source catalog or
      //     from the chosen one

      res = nearest_source( bestpos(1), bestpos(2), idrad, clog=clog );
      if( is_void(res) ) {
         name_tmp = "NEW SOURCE";
         s_id_tmp = "UNKNOWN";
         class_tmp = 0n;
         ra_cat_tmp = -99.0;
         dec_cat_tmp = -99.0;
      } else {
         name_tmp = res.name;
         s_id_tmp = res.source_id;
         class_tmp = int(res.class);
         ra_cat_tmp = res.ra_obj;
         dec_cat_tmp = res.dec_obj;
      }
      grow, srcname_uniq, name_tmp;
      grow, source_id_uniq, s_id_tmp;
      grow, class_uniq, class_tmp;
      if( chat  >  4 ) write,flog,format=" name: %s\n",name_tmp;
      grow, ra_cat_uniq, ra_cat_tmp;
      grow, dec_cat_uniq, dec_cat_tmp;

      //  Define the position error

      var_err_rad = sum( (weight*err_rad(w))^2 );
      syst_err_rad = 2.778e-3; // in degrees, corresponding to 10 arcsec
      grow, err_rad_uniq, sqrt( var_err_rad + syst_err_rad^2 );
      if( chat  >  4 ) {
         nweight = numberof(w);
         write,flog,format=" numberof(weight): %i\n", numberof(w);
         for( k = 1; k <= min([5,nweight]); k++ ) {
            write,flog,"         weight(%i) = %8.5f\n", k, weight(k);
         }
         write,flog,format=" var_err_rad: %8.5f\n", var_err_rad;
         write,flog,format=" err_rad_uniq: %8.5f\n", sqrt( var_err_rad + syst_err_rad^2 );
      }

      //  Mark the i-sources now assigned

      ismarked(w) = 1;

      //  Find next unmarked i-source

      dum = where( ismarked == 0 ); // Get number of unmarked findings
      num = numberof( dum );
      if( num  >  0 ) {
         //+ while ismarked(cur)  ==  1 do cur = cur + 1
         cur = dum(1);
      }

      if( chat  >  4 ) {
         write,format="num = %i,  cur for next loop = %i\n", num, cur;
      }

   }

   if( uniq_no != numberof(ra_obj_uniq) ) error,"Mismatch between uniq_no and num of ra_obj_uniq";

   if( chat > 1 ) write,format="Writing file %s with %i sources\n", \
                     file_unique_cat, uniq_no;
   s20 = "01234567890123456789"
   kwds_init;
   kwds_set,"EXTNAME","JEMX_UNIQUE_CAT","JEM-X catalog of unique sources";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","mk_unique_cat.i","made this";
   kwds_set,"VERSION",version,"Version of generating program";
   kwds_set,"VERDATE",verdate,"Date of this version";
   kwds_set,"RESPONSI","Niels J. Westergaard, DTU Space","Programmer and responsible";
   kwds_set,"INPUTCAT", fullpath(dol_in_cat),"Input catalog";
   kwds_set,"LIST_INT", fullpath(file_ysave),"Yorick save file of LIST_INT";
   kwds_set,"ACCRAD", accrad,"[deg] Setting of acceptance radius keyword";
   kwds_set,"IDRAD", idrad,"[deg] Setting of identification radius keyword";
   kwds_set,"REFR_CAT", Source_cat_dol, "Reference catalog of X-ray sources";
   kwds_set,"TUNIT4","deg","Unit of RA_OBJ";
   kwds_set,"TUNIT5","deg","Unit of DEC_OBJ";
   kwds_set,"TUNIT6","deg","Unit of RA_CAT";
   kwds_set,"TUNIT7","deg","Unit of DEC_CAT";
   kwds_set,"TUNIT9","deg","Unit of ERR_RAD";

   l = strlen(srcname_uniq(1));
   for( i=1; i<= 20-l; i++ ) srcname_uniq(1) += " ";
   l = strlen(source_id_uniq(1));
   for( i=1; i<= 16-l; i++ ) source_id_uniq(1) += " ";
   wrmfitscols, file_unique_cat,"SOURCE_ID", source_id_uniq, "NAME", srcname_uniq, \
          "CLASS", class_uniq, \
          "RA_OBJ", ra_obj_uniq, "DEC_OBJ", dec_obj_uniq, \
          "RA_CAT", ra_cat_uniq, "DEC_CAT", dec_cat_uniq, \
          "DETSIG", detsig_uniq, "ERR_RAD", err_rad_uniq, \
          "NUMFIND", len_list_int, clobber=1;

  /******  The following step seems unnecessary ***
   *
   * fsav = createb( file_ysave );
   * save, fsav, uniq_no, pos_list_int, len_list_int, list_int;
   * close, fsav;
   *
   ***      ***         ***       ***/

  /*** skip this step temporarily ***
   *  for( i = 1; i <= uniq_no; i++ ) {
   *     p = pos_list_int(i);
   *     l = len_list_int(i);
   *     fits_bintable_poke, file_unique_cat+"+1", i, 7, list_int(p:p+l-1);
   *  }
   ***      ***         ***       ***/


   write,format="\n  Log file : %s\n\n", logfile;

   close, flog;

}

/* Function best_skypos */

func best_skypos( ra, dec, weight )
/* DOCUMENT newpos = best_skypos( ra, dec, weight )

  Returns average sky position array: [ra,dec]
  when arrays of RA and Dec are given in degrees.

  The third argument is a weight array
  If it is not given then same weight is applied to
  all positions.

   2003-10-27/NJW
   2008-10-29/NJW translated to Yorick from IDL
*/
{

   nval = numberof(ra);
   nd = numberof(dec);
   if( nval  !=  nd ) {
      write,"BEST_SKYPOS error, bad dimensions of input (dec)";
      return [];
   }
   if( is_void(weight) ) {
      weight = array( 1., nval);
   } else {
      if( nval  !=  numberof(weight) ) {
         write,"BEST_SKYPOS error, bad dimensions of input(weight)";
         return [];
      }
   }

   dr = pi / 180;

   rsum = array( double,3);
   for( i = 1; i <= nval; i++ ) {
      r = [cos(ra(i)*dr)*cos(dec(i)*dr),sin(ra(i)*dr)*cos(dec(i)*dr), sin(dec(i)*dr)];
      rsum += r*weight(i);
   }

   // normalize

   norm = sqrt(sum(rsum^2));
   rsum = rsum / norm;
   ra_res = zero2pi(atan(rsum(2),rsum(1)))/dr;
   dec_res = asin(rsum(3))/dr;

   return [ra_res,dec_res];

}

/* Function mk_reg */

func mk_reg( ra, dec, srcname, fn=, dir=, color=, point=, syst= )
/* DOCUMENT mk_reg, ra, dec, srcname, fn=, dir=, color=, point=, syst=

   Make region file for 'ds9' or 'saoimage'
   Keywords:
       fn         Output file name (defaults to cat_???.reg)
       dir        Operates temporarily in this directory for the
                    benefit of automatic file naming.
       color      Defines global color (same as for Yorick), default is green
       point      One of circle, box (default), diamond, cross, x,
                  arrow, boxcircle (in quotes)
       syst       "fk5" (default) | "physical"
      2008/NJW
      2009-11-17/NJW update
*/
{
   nvals = numberof(ra);
   if( numberof(dec) != nvals ) error,"MK_REG bad dimensions 1";
   if( !is_void(srcname) ) {
      if( numberof(srcname) != nvals ) error,"MK_REG bad dimensions 2";
   }
   if( is_void(color) ) color = "green";
   if( is_void(point) ) point = "box";
   if( is_void(syst) ) syst = "fk5";
   cwd = get_cwd();
   if( structof(dir) == string ) cd, dir;
   if( is_void(fn) ) fn = get_next_filename("cat_???.reg");
   txt = "# Region file by Yorick (jemx.i) version 1.0";
   grow, txt, "global move=0,color="+color;

   for( i = 1; i <= nvals; i++ ) {
      sn = is_void(srcname) ? "" : srcname(i);
      grow, txt, swrite(format=syst+";point(%f,%f) # point=%s text={%s}",\
               ra(i), dec(i), point, sn );
   }

   write_slist, fn, txt;

   cd, cwd;
}

/* Function cat_compare */

func cat_compare( dol_cat_1, dol_cat_2, outfile=, silent=, \
          names=, reci=, rad=, diff= )
/* DOCUMENT cat_compare, dol_cat_1, dol_cat_2, outfile=, silent=,
             names=, reci=, rad=, diff=

   Keywords:
      outfile  : will override default name 'cat_compare_0000.txt'
      silent   : to suppress output on terminal
      names    :  1  -> to force only a comparison on source names
                  2  -> to force also a comparison on source names
      reci     : to force output from the reciprocal test i.e.
                    when walking through CAT2 to find coincidences
                    in CAT1
      rad      : minimum error radius [degrees], defaults to 0.01
      diff     : causes only differences to be reported in outfile

   2009-08-26/NJW   from cat_compare.pro
*/
{

   vb = is_void(silent);
   if( is_void(outfile) ) outfile = get_next_filename("cat_compare_????.txt");
   lun = open(outfile, "w");

   if( is_void(rad) ) {min_err_rad = 0.01;} else {min_err_rad = rad;}
   if( is_void(names) ) names = 0;

   cat1 = dol_cat_1;
   cat2 = dol_cat_2;
   write,lun,"  Output file of \"cat_compare\",    "+ndate(3);

   write,lun,"CAT1: "+fullpath(cat1);
   write,"Reading "+cat1+" ...";

   fh1 = headfits( cat1 );
   nrows1 = fxpar( fh1, "NAXIS2" );

   // See if source names are present as 'NAME' or 'SOURCENAME'
   cname = "NAME";
   if( !is_void(fits_colnum( fh1, cname )) ) {
      name1 = rdfitscol(cat1,cname);
   } else {
      cname = "SOURCENAME";
      if( !is_void(fits_colnum( fh1, cname )) ) {
         name1 = rdfitscol(cat1,cname);
      } else { // I must give up - neither of NAME or SOURCENAME are found
               // Invent some names
         write,"No NAME or SOURCENAME column in cat1 - use standard names";
         name1 = swrite(format="CAT1_%06i",indgen(nrows1));
      }
   }
   // See if R.A. column is given as RA or as RA_OBJ
   cname = "RA_OBJ";
   if( !is_void(fits_colnum( fh1, cname )) ) {
      ra_obj1 = rdfitscol(cat1,cname);
   } else {
      cname = "RA";
      if( !is_void(fits_colnum( fh1, cname )) ) {
         ra_obj1 = rdfitscol(cat1,cname);
      } else error,"No R.A. information in cat1 ...";
   }
   // See if declination column is given as DEC or as DEC_OBJ
   cname = "DEC_OBJ";
   if( !is_void(fits_colnum( fh1, cname )) ) {
      dec_obj1 = rdfitscol(cat1,cname);
   } else {
      cname = "DEC";
      if( !is_void(fits_colnum( fh1, cname )) ) {
         dec_obj1 = rdfitscol(cat1,cname);
      } else error,"No declination information in cat1 ...";
   }
   // See if error radius column is present as ERR_RAD
   cname = "ERR_RAD";
   if( !is_void(fits_colnum( fh1, cname )) ) {
      err_rad1 = rdfitscol(cat1,cname);
   } else {
      // Use min_err_rad as a default
      err_rad1 = array(min_err_rad, nrows1);
   }

   write,lun,"           with "+itoa(nrows1)+" sources";
   is = sort(ra_obj1);
   name1 = strtrim(name1(is));
   ra_obj1 = ra_obj1(is);
   dec_obj1 = dec_obj1(is);
   err_rad1 = err_rad1(is);
   w = where( err_rad1 < min_err_rad );
   if(numberof(w)) err_rad1(w) = min_err_rad;

   write,lun, "CAT2: "+fullpath(cat2);
   write,"Reading "+cat2+" ...";

   fh2 = headfits( cat2 );
   nrows2 = fxpar( fh2, "NAXIS2" );

   // See if source names are present as 'NAME' or 'SOURCENAME'
   cname = "NAME";
   if( !is_void(fits_colnum( fh2, cname )) ) {
      name2 = rdfitscol(cat2,cname);
   } else {
      cname = "SOURCENAME";
      if( !is_void(fits_colnum( fh2, cname )) ) {
         name2 = rdfitscol(cat2,cname);
      } else { // I must give up - neither of NAME or SOURCENAME are found
               // Invent some names
         write,"No NAME or SOURCENAME column in cat2 - use standard names";
         name2 = swrite(format="CAT2_%06i",indgen(nrows2));
      }
   }
   // See if R.A. column is given as RA or as RA_OBJ
   cname = "RA_OBJ";
   if( !is_void(fits_colnum( fh2, cname )) ) {
      ra_obj2 = rdfitscol(cat2,cname);
   } else {
      cname = "RA";
      if( !is_void(fits_colnum( fh2, cname )) ) {
         ra_obj2 = rdfitscol(cat2,cname);
      } else error,"No R.A. information in cat2 ...";
   }
   // See if declination column is given as DEC or as DEC_OBJ
   cname = "DEC_OBJ";
   if( !is_void(fits_colnum( fh2, cname )) ) {
      dec_obj2 = rdfitscol(cat2,cname);
   } else {
      cname = "DEC";
      if( !is_void(fits_colnum( fh2, cname )) ) {
         dec_obj2 = rdfitscol(cat2,cname);
      } else error,"No declination information in cat2 ...";
   }
   // See if error radius column is present as ERR_RAD
   cname = "ERR_RAD";
   if( !is_void(fits_colnum( fh2, cname )) ) {
      err_rad2 = rdfitscol(cat2,cname);
   } else {
      // Use min_err_rad as a default
      err_rad2 = array(min_err_rad, nrows2);
   }

   write,lun,"           with "+itoa(nrows2)+" sources";
   is = sort(ra_obj2);
   name2 = strtrim(name2(is));
   ra_obj2 = ra_obj2(is);
   dec_obj2 = dec_obj2(is);
   err_rad2 = err_rad2(is);
   w = where( err_rad2 < min_err_rad );
   if(numberof(w)) err_rad2(w) = min_err_rad;

   // report keyword settings

   write,lun,"Keywords have been set as";
   write,lun,"   names = "+itoa(names);
   if( reci ) { write,lun,"   reci  = 1"; } else { write,lun,"   reci  = <not set>";}
   write,lun,"   rad   = "+swrite(format="%.4f",min_err_rad);
   if( diff ) { write,lun,"   diff  = 1"; } else { write,lun,"   diff  = <not set>";}

   if( names ) {

      write,"Checking names ...";
      if( !diff ) {
         write,lun,"";
         write,lun,"-----------------------------------------------------------";
         write,lun,"         MATCHING SOURCE NAMES";
         write,lun,"-----------------------------------------------------------";
      }

      tname1 = strtrim(name1);
      tname2 = strtrim(name2);
      n_coin = 0;
      coin_names = [];
      miss_names = [];
      coin_num = [];
      for( i = 1; i <= nrows1; i++ ) {

         w = where( tname2  ==  tname1(i) );
         nw = numberof(w);

         if( nw  >=  1 ) {
            if( vb ) write,"Both have: "+name1(i);
            //+ write,lun,"         "+name1(i);
            grow,coin_names, name1(i);
            grow,coin_num, nw;
            n_coin++;
         } else {
            grow, miss_names, name1(i);
         }

         if( nw  >  1 ) {
            if( vb ) write,name1(i)+" (CAT1) is found "+itoa(nw)+" times in CAT2";
            //+ write,lun,"         is found "+itoa(nw)+" times in CAT2";
         }

      }

      if( n_coin  ==  0 ) {
         write,"No coincident names found.";
         write,lun,"No coincident names found.";
      } else {

         if( numberof(coin_names)  !=  n_coin ) {
            write,"##3## Error!";
            close,lun;
            return;
         }
         is = sort(coin_names);
         coin_names = coin_names(is);
         coin_num   = coin_num(is);
         if( !diff ) {
            for( i = 1; i <= n_coin; i++ ) {
               write,lun,format="%20s   %i\n", coin_names(i), coin_num(i);
            }
            write,itoa(n_coin)+" coincidences of names.";
            write,lun,"";
            write,lun,itoa(n_coin)+" coincidences of names.";
         }
      }

      if( (nmiss = numberof(miss_names)) ) {
         write,lun,"";
         write,lun,"     ---------------------------------------";
         write,lun,"         Names in CAT1 not found in CAT2"
         write,lun,"     ---------------------------------------";
         for( i = 1; i <= nmiss; i++ ) {
            write,lun,"     "+miss_names(i);
         }
         write,lun,"     ---------------------------------------";
      } else {
         write,lun,"";
         write,lun,"---   All names in CAT1 also exist in CAT2 -----";
      }

      // repeat - if required - starting from CAT2

      n_coin = 0;
      coin_names = [];
      miss_names = [];
      coin_num = [];
      for( i = 1; i <= nrows2; i++ ) {

         w = where( tname1  ==  tname2(i) );
         nw = numberof(w);

         if( nw  >=  1 ) {
            if( vb && reci ) write,"Both have: "+name2(i);
            //+ write,lun,"         "+name2(i);
            grow,coin_names, name2(i);
            grow,coin_num, nw;
            n_coin++;
         } else {
            grow, miss_names, name2(i);
         }

         if( nw  >  1 ) {
            if( vb && reci ) write,name2(i)+" (CAT2) is found "+itoa(nw)+" times in CAT1";
            //+ write,lun,"         is found "+itoa(nw)+" times in CAT1";
         }

      }

      if( n_coin  ==  0 ) {
         write,"No coincident names found.";
         write,lun,"No coincident names found.";
      } else {

         if( numberof(coin_names)  !=  n_coin ) {
            write,"##4## Error!";
            close,lun;
            return;
         }
         is = sort(coin_names);
         coin_names = coin_names(is);
         coin_num   = coin_num(is);
         if( !diff ) {
            for( i = 1; i <= n_coin; i++ ) {
               write,lun,format="%20s   %i\n", coin_names(i), coin_num(i);
            }
            write,itoa(n_coin)+" coincidences of names.";
            write,lun,"";
            write,lun,itoa(n_coin)+" coincidences of names.";
         }
      }

      if( (nmiss = numberof(miss_names)) ) {
         write,lun,"";
         write,lun,"     ---------------------------------------";
         write,lun,"         Names in CAT2 not found in CAT1"
         write,lun,"     ---------------------------------------";
         for( i = 1; i <= nmiss; i++ ) {
            write,lun,"     "+miss_names(i);
         }
         write,lun,"     ---------------------------------------";
      } else {
         write,lun,"";
         write,lun,"---   All names in CAT2 also exist in CAT1 -----";
      }

   } // Terminate test for keyword "names";

   // only continue with matching positions if 'names' is 0 or 2

   if( names != 1 ) {

      if( !diff ) {
         write,lun,"";
         write,lun,"-----------------------------------------------------------";
         write,lun,"                MATCHING SOURCE POSITIONS";
         write,lun,"-----------------------------------------------------------";
         write,lun,"In CAT1                                  In CAT2";
      }

      write,"Checking source positions ...";

      n_coin = 0;
      aname = [];
      ara = [];
      adec = [];
      for( i = 1; i <= nrows1; i++ ) {

         // find cases where dist < err_rad1 + err_rad2;
         // or - equivalently : dist - err_rad2 < err_rad1;


         dist = arcdist(ra_obj1(i), dec_obj1(i), ra_obj2, dec_obj2 );
         dista = dist - err_rad2;
         w = where( dista  <  err_rad1(i) ) ;
         nw = numberof(w);

         if( nw  >  0 ) {
            n_coin++;
            if( vb ) {
               write,"";
               write,"Catalog 1 source: "+name1(i)+" "+ \
                  swrite(format="%9.3f%9.3f",ra_obj1(i),dec_obj1(i))+" matches the position of";
               for( j = 1; j <= nw; j++ ) {
                  write,"Catalog 2 source: "+name2(w(j))+" "+ \
                     swrite(format="%9.3f%9.3f",ra_obj2(w(j)),dec_obj2(w(j)));
               }
            }
            if( !diff ) {
               write,lun,format="%20s%9.3f%9.3f    %20s%9.3f%9.3f\n", \
                       name1(i), ra_obj1(i), dec_obj1(i), \
                       name2(w(1)), ra_obj2(w(1)), dec_obj2(w(1));
               if( nw  >  1 ) {
                  for( j = 2; j <= nw; j++ ) {
                     write,lun,format="                                          %20s%9.3f%9.3f\n", \
                        name2(w(j)), ra_obj2(w(j)), dec_obj2(w(j));
                  }
               }
            }
         } else {
            grow, aname, name1(i)
            grow, ara, ra_obj1(i)
            grow, adec, dec_obj1(i)
         }

      }

      if( n_coin  ==  0 ) {
         write,"No coincident positions found.";
      } else {
          write,itoa(n_coin)+" coincidences of positions.";
      }

      n_in1_not_in2 = numberof(aname);
      write,lun,"";
      write,lun,"-----------------------------------------------------------";
      write,lun,"                SOURCES IN CAT1 BUT NOT IN CAT2";
      write,lun,"-----------------------------------------------------------";
      write,lun,"                       RA       Dec       Glon    Glat";
      for( i = 1; i <= n_in1_not_in2; i++ ) {
         gcoor = galactic(ara(i),adec(i));
         if( gcoor(1) < 0. ) gcoor(1) += 360.;
         write,lun,format="%20s%9.3f%9.3f%12.3f%9.3f\n", \
                    aname(i),ara(i),adec(i),gcoor(1),gcoor(2);
      }

   /******************************************************************
    *
    *       Walk through catalog 2 to find matches in catalog 1
    *
    *********************************************************************/

      if( reci && !diff ) {
         write,lun,"-----------------------------------------------------------";
         write,lun,"                MATCHING SOURCE POSITIONS (2)";
         write,lun,"-----------------------------------------------------------";
         write,lun,"In CAT2                                  In CAT1";
      }

      aname = [];
      ara = [];
      adec = [];
      n_coin = 0;
      for( i = 1; i <= nrows2; i++ ) {

         // find cases where dist < err_rad1 + err_rad2;
         // or - equivalently : dist - err_rad1 < err_rad2;

         dist = arcdist(ra_obj2(i), dec_obj2(i), ra_obj1, dec_obj1 );
         dista = dist - err_rad1;
         w = where( dista  <  err_rad2(i));
         nw = numberof(w);

         if( nw  >  0 ) {
            n_coin++;

            if( reci ) {

               if( vb ) {
                  write,"";
                  write,"Catalog 2 source: "+name2(i)+" "+ \
                     swrite(format="%9.3f%9.3f",ra_obj2(i),dec_obj2(i))+" matches the position of";
                  for( j = 1; j <= nw; j++ ) {
                     write,"Catalog 1 source: "+name1(w(j))+" "+ \
                        swrite(format="%9.3f%9.3f",ra_obj1(w(j)),dec_obj1(w(j)));
                  }
               }
               if( !diff ) {
                  write,lun,format="%20s%9.3f%9.3f   %20s%9.3f%9.3f\n",name2(i), \
                          ra_obj2(i), dec_obj2(i), \
                          name1(w(1)), ra_obj1(w(1)), dec_obj1(w(1));
                  if( nw  >  1 ) {
                     for( j = 2; j <= nw; j++ ) {
                        write,lun, format="                                         %20s%9.3f%9.3f\n", \
                              name1(w(j)), ra_obj1(w(j)), dec_obj1(w(j));
                     }
                  }
               }

            }

         } else {
            grow, aname, name2(i);
            grow, ara, ra_obj2(i);
            grow, adec, dec_obj2(i);
         }


      }

      if( n_coin  ==  0 ) {
         write,"No coincident positions found.";
      } else {
          write,itoa(n_coin)+" coincidences of positions.";
      }

      n_in2_not_in1 = numberof(aname);
      write,lun,"";
      write,lun,"-----------------------------------------------------------";
      write,lun,"                SOURCES IN CAT2 BUT NOT IN CAT1";
      write,lun,"-----------------------------------------------------------";
      write,lun,"                       RA       Dec       Glon    Glat";
      for( i = 1; i <= n_in2_not_in1; i++ ) {
         gcoor = galactic(ara(i),adec(i));
         if( gcoor(1) < 0. ) gcoor(1) += 360.;
         write,lun,format="%20s%9.3f%9.3f%12.3f%9.3f\n", \
                    aname(i),ara(i),adec(i),gcoor(1),gcoor(2);
      }

   } // terminate test for names != 1

   close, lun;

   write,"The output has been written to: "+outfile;

}

/* Function jmx1_offaxis_azim */

func jmx1_offaxis_azim( ra_src, dec_src, ra_scx,  \
              dec_scx, posang, &offaxis, &azim )
/* DOCUMENT jmx1_offaxis_azim,  ra_src, dec_src, ra_scx, \
               dec_scx, posang, >offaxis, >azim


   Derive a source position in JEM-X 1 coordinates

     2009-02-09/NJW

   Let s_j1 be the vector pointing to the source in
   JMX1 coordinates (s_j1 = M Omega s_eq)
   then
            offaxis = acos(s_j1(1))
            azimuth = atan( s_j1(3), s_j1(2) )

    All angles in degrees
*/
{

   dr = pi/180.;
   alpha = -0.001045;
   beta  = -0.002205;
   gamma = -0.007520;

   s_eq = vector( ra_src, dec_src, deg=1 );
   omega = jconv_coord( ra_scx, dec_scx, posang, to_sc=1 );
   mis = misalign(alpha,beta,gamma);

   s_sc = omega(,+) * s_eq(+);
   s_j1 = mis(,+) * s_sc(+);

   offaxis = acos( s_j1(1) ) / dr;
   azim = zero2pi(atan( s_j1(3), s_j1(2) ) ) / dr;

}

/* Function misalign */

func misalign( alpha, beta, gamma )
/* DOCUMENT mis = misalign( alpha, beta, gamma )

   returns the JEM-X misalignment matrix

   Best values as of 2009-08-19:
        alpha = -0.001045
        beta  = -0.002205
        gamma = -0.007520
*/
{
   if( is_void(alpha) ) {
      alpha = -0.001045;
      beta  = -0.002205;
      gamma = -0.007520;
   }

   mis = array(double,3,3);
   if( alpha == 0.0 && beta == 0.0 && gamma == 0.0 ) {
      mis(1,1) = mis(2,2) = mis(3,3) = 1.0;
      return mis;
   }

   A = sqrt(1.-alpha^2-beta^2);
   C = sqrt(1.-beta^2-gamma^2);

   if( alpha == 0.0 && gamma == 0.0 ) {

      B = 1.0;
      x = 0.0;
      z = 0.0;
      y = -beta;

   } else {

      B_1 = (A*C - alpha*beta*gamma)/(gamma^2+C^2);
      B_2 = (-A*C - alpha*beta*gamma)/(gamma^2+C^2);

   // Equation for B

   /***    unnecessary
    *  AA = gamma^2 + C^2;
    *  BB = 2*alpha*beta*gamma;
    *  CC = alpha^2*C^2 + alpha^2*beta^2 - C^2;
    *
    *  nroots = quadr_eq( AA, BB, CC, B_x1, B_x2 );
    *  B = B_x1;
    ****/

      B = B_1; // the two systems are almost aligned

      x = -(alpha*beta + B*gamma)/C;
      z = -(gamma*beta + B*alpha)/A;
      if( abs(z) > abs(x) ) {
         y = -(B*x + C*gamma)/z;
      } else {
         y = -(B*z + A*alpha)/x;
      }

   }

   mis(1,1) = A;
   mis(1,2) = alpha;
   mis(1,3) = beta;
   mis(2,1) = z;
   mis(2,2) = B;
   mis(2,3) = gamma;
   mis(3,1) = y;
   mis(3,2) = x;
   mis(3,3) = C;

   return mis;

}

/* Function jconv_axes2posang */

func jconv_axes2posang( ra_scx, dec_scx, &posang, ra_scy, \
                  dec_scy, ra_scz, dec_scz )
/* DOCUMENT jconv_axes2posang, ra_scx, dec_scx, >posang, ra_scy,
                         dec_scy, ra_scz, dec_scz

 Procedure to get the posang angle from X, Y, and Z axis directions

 At input: all angles are given in degrees

   2009-02-09/NJW
*/
{

   dr = pi / 180; // degrees to radians

   ra_scx_rad = ra_scx * dr;
   dec_scx_rad = dec_scx * dr;
   ra_scy_rad = ra_scy * dr;
   dec_scy_rad = dec_scy * dr;
   ra_scz_rad = ra_scz * dr;
   dec_scz_rad = dec_scz * dr;

   posang_rad = atan( sin(dec_scy_rad), sin(dec_scz_rad) );
   posang = posang_rad / dr;

}

/* Function jconv_posang2axes */

func jconv_posang2axes( ra_scx, dec_scx, posang, &ra_scy, \
                  &dec_scy, &ra_scz, &dec_scz )
/* DOCUMENT jconv_posang2axes, ra_scx, dec_scx, posang, >ra_scy,
                         >dec_scy, >ra_scz, >dec_scz

 Procedure to convert posang to Y and Z axis directions

 At input: all angles are given in degrees

   2009-02-09/NJW
*/
{

   dr = pi / 180; // degrees to radians

   ra_scx_rad = ra_scx * dr;
   dec_scx_rad = dec_scx * dr;
   posang_rad = posang * dr;

   // Pointing direction: x-axis

   // RA && Dec of two other axes: y and z

   ra_scy_rad = zero2pi(ra_scx_rad - atan(-cos(posang_rad), -sin(dec_scx_rad)*sin(posang_rad)));

   dec_scy_rad = asin(cos(dec_scx_rad)*sin(posang_rad));

   ra_scz_rad = zero2pi(ra_scx_rad - atan(sin(posang_rad), -sin(dec_scx_rad)*cos(posang_rad)));
   dec_scz_rad = -asin(-cos(dec_scx_rad)*cos(posang_rad));

   ra_scy = ra_scy_rad / dr;
   dec_scy = dec_scy_rad / dr;
   ra_scz = ra_scz_rad / dr;
   dec_scz = dec_scz_rad / dr;

}

/* Function get_time_for_swid */

func get_time_for_swid( swid, &tstart, &tstop, chat= )
/* DOCUMENT status = get_time_for_swid( swid, >tstart, >tstop, chat= )

   returns the start and stop times (IJD, unit: day) obtained from
   /r6/jemx/integral_history/timetables/swid_timetable_RRRR.fits

   2009-03-12/NJW
*/
{
   local tswids, ttstart, ttstop;

   if( is_void(chat) ) chat = 0;

   basdir = "/r6/jemx/integral_history/timetables/";
   nswids = numberof(swid); // may be an array
   tstart = array(double, nswids);
   tstop = array(double, nswids);
   is = sort(swid);
   si = sort(is);
   swid = swid(is); // sort to minimize file reading

   revol = strpart(swid, 1:4);
   urevol = uniq( revol );
   nurevol = numberof(urevol);
   for( k = 1; k <= nurevol; k++ ) {
      rev = revol(urevol(k));
      if(chat > 1 ) write,format="Going to read timetable for revol %s\n", rev;
      filenam = basdir+"swid_timetable_"+rev+".fits";
      // check existence of arrays in memory storage
      if( 0 == mem_restore(filenam+"swid",tswids) ) {
         status = mem_restore(filenam+"tstart",ttstart);
         status = mem_restore(filenam+"tstop",ttstop);
      } else {
         tswids = rdfitscol(basdir+"swid_timetable_"+rev+".fits+1","swid");
         ttstart = rdfitscol(basdir+"swid_timetable_"+rev+".fits+1","tstart");
         ttstop = rdfitscol(basdir+"swid_timetable_"+rev+".fits+1","tstop");
         status = mem_save(filenam+"swid",tswids);
         status = mem_save(filenam+"tstart",ttstart);
         status = mem_save(filenam+"tstop",ttstop);
      }
      i2 = k == nurevol ? numberof(swid) : urevol(k+1)-1;
      for( i = urevol(k); i <= i2; i++ ) {
         w = where( swid(i) == tswids );
         nw = numberof(w);
         if( nw == 1 ) {
            tstart(i) = ttstart(w(1));
            tstop(i) = ttstop(w(1));
         } else if( nw == 0 ) {
            write,format="Warning! SWID %s not found in time table\n", swid(i);
         } else error,"##333## in get_time_for_swid (SWID found several times)";
      }
   }

   tstart = tstart(si); // reverse the previous sorting
   tstop = tstop(si); // so that times are matched with SWIDs

   return 0;

}

/* Function srcl2txt */

func srcl2txt( dol_srcl_res, outfile=, mospec=, size=, cat=, detsig= )
/* DOCUMENT srcl2txt, dol_srcl_res, outfile=, mospec=, size=, cat=, detsig=

   Reads a SRCL-RES file

   Keywords:
      outfile   Name of output (text) file
      mospec    If set, a mosaic_spec script is created
      size      is the 'size' parameter for mosaic_spec
      cat       If set, the catalog position is given
      detsig    If set, the detection significance is given

    2009-05-20/NJW
*/
{
   local filename, extno;

   get_exten_no, dol_srcl_res, filename, extno;
   if( extno == 0 ) dol_srcl_res += "+1";

   if( !file_test(filename) ) {
      write, filename+" was not found";
      return;
   }

   if( is_void(size) ) size = 10;

   fh = headfits( dol_srcl_res );
   naxis2 = fxpar(fh, "naxis2");
   instrume = fxpar(fh, "instrume" );
   jstr = strtrim(instrume)=="JMX1" ? "jmx1" : "jmx2";
   Jstr = strupcase(jstr);

   if( naxis2 == 0 ) {
      write,"No rows in "+dol_srcl_res;
      return;
   }
   ra = rdfitscol(dol_srcl_res,"ra_obj");
   if( is_void(ra) ) {
      write,"Problem reading RA_OBJ from "+dol_srcl_res;
      return;
   }
   nrows = numberof(ra);
   dec = rdfitscol(dol_srcl_res,"dec_obj");
   if( is_void(dec) ) {
      write,"Problem reading DEC_OBJ from "+dol_srcl_res;
      return;
   }
   name = rdfitscol(dol_srcl_res,"name");
   if( is_void(dec) ) {
      write,"Problem reading NAME from "+dol_srcl_res;
      return;
   }

   if( structof(outfile) == string ) {
      stream = open(outfile,"w");
      p = 1;
   } else p = 0;

   // fix the output formats and the headline

   name = strtrim(name);
   mlen = max(strlen(name));
   fmt = swrite(format="%%%is %%8.3f%%8.3f",mlen+1);
   headline = strpadd(" NAME",mlen+2," ");
   headline += "  RA_OBJ DEC_OBJ";
   if( cat ) {
      ra_cat = rdfitscol(dol_srcl_res,"ra_cat");
      dec_cat = rdfitscol(dol_srcl_res,"dec_cat");
      fmtc = " %8.3f%8.3f";
      headline += "   RA_CAT DEC_CAT";
   }
   if( detsig ) {
      dtsg = rdfitscol(dol_srcl_res,"detsig");
      fmtd = " %6.1f";
      headline += "  DETSIG";
   }

   write,format="%s\n\n", headline;
   if(p)write,stream,format="%s\n\n", headline;

   for( i = 1; i <= nrows; i++ ) {
      write,format=fmt, name(i), ra(i), dec(i);
      if(p)write,stream,format=fmt, name(i), ra(i), dec(i);
      if( cat ) {
         write,format=fmtc,ra_cat(i),dec_cat(i);
         if(p)write,stream,format=fmtc,ra_cat(i),dec_cat(i);
      }
      if( detsig ) {
         write,format=fmtd,dtsg(i);
         if(p)write,stream,format=fmtd,dtsg(i);
      }
      write,format="%s\n","";
      if(p)write,stream,format="%s\n","";
      if( mospec ) {
         fname = get_next_filename("mospec_???");
         f = open(fname,"w");
         write,f,format="mosaic_spec %s\n","\\";
         write,f,format="   DOL_idx=\"%s_sky_ima.fits[GROUPING]\" %s\n",jstr,"\\";
         write,f,format="   DOL_spec=\"%s_mosaic_spec.fits(%s-PHA1-SPE.tpl)\" %s\n",jstr,Jstr,"\\";
         write,f,format="   ra=%.3f \\\n", ra(i);
         write,f,format="   dec=%.3f \\\n", dec(i);
         write,f,format="   posmode=-1 %s\n","\\";
         write,f,format="   widthmode=-2 %s\n","\\";
         write,f,format="   size=%i %s\n",size,"\\";
         write,f,format="   allEnergies=yes %s\n","\\";
         write,f,format="   EXTNAME=%s-SKY.-IMA %s\n",Jstr,"\\";
         write,f,format="   Intensity=RECONSTRUCTED %s\n","\\";
         write,f,format="   chatty=3%s\n","";
         close, f;
      }
   }
   if(p)close, stream;
}

/* Function j_get_srcl_res_spectrum */

func j_get_srcl_res_spectrum( dol_srcl, srcid, &eb1, &eb2, &rate, &rate_err, &exposure )
/* DOCUMENT j_get_srcl_res_spectrum, dol_srcl, srcid, >eb1, >eb2, >rate, >rate_err, >exposure
      status = j_get_srcl_res_spectrum( dol_srcl, srcid, >eb1, >eb2, >rate, >rate_err, >exposure)

     Retrieve the E_MIN, E_MAX, FLUX, and FLUX_ERR values for a specified
     row or source name from a SRCL-RES file.
     'srcid' can be a string (source name) or a number (row number)

     Checks for first three energy intervals: 3.04 7.04 11.04 19.98 keV
     In that case they are disregarded (detection energy bands).

     Returns 0 for succesful running
             -1 if no rows
             -2 if file does not exist
             -3 source was not found

     2009-06-13/NJW
*/
{
   local filename, extno;

   get_exten_no, dol_srcl, filename, extno;
   if( extno == 0 ) {
      extno = 1;
      dol_srcl = filename+"+1";
   }

   if( !file_test(filename) ) {
      write,"Error ",filename," was not found";
      return -2;
   }
   fh = headfits(dol_srcl);
   nrows = fxpar( fh, "naxis2");
   if( nrows==0 ) {
      write,"Warning - no rows in ", filename;
      return -1;
   }
   exposure = fxpar( fh, "exposure" );

   e_min = rdfitscol( dol_srcl, "e_min" )(,1);
   e_max = rdfitscol( dol_srcl, "e_max" )(,1);
   rate = rdfitscol( dol_srcl, "flux" );
   rate_err = rdfitscol( dol_srcl, "flux_err" );
   name = strlowcase(strtrim(rdfitscol( dol_srcl, "name" )));

   if( typeof(srcid) == "string" ) { // check for match
      w = where(strlowcase(strtrim(srcid)) == name);
      if( numberof(w)==0 ) {
         write,"Source ",srcid," was not found";
         return -3;
      }
      srcid = w(1);
   }
   if( srcid > nrows ) {
      write,"Row number exceeded number of rows";
      return -3;
   }

   w = where( e_max(1:150) > 0. );
   eb1 = e_min(w);
   eb2 = e_max(w);
   rate = rate(w,srcid);
   rate_err = rate_err(w,srcid);
   nener = numberof(w);
   if( nener > 3 ) { // See if first bands are detection bands
      if( near(e_min(1),3.04,0.01) && near(e_min(2),7.04,0.01) \
       && near(e_min(3),11.04,0.01) && near(e_max(3),19.98,0.01) ) {
         eb1 = eb1(4:0);
         eb2 = eb2(4:0);
         rate = rate(4:0);
         rate_err = rate_err(4:0);
      }
   }

   return 0;

}

/* Function j_get_srcl_res_spectra */

func j_get_srcl_res_spectra( file_list, srcid, &eb1, &eb2, &rate, &rate_err )
/* DOCUMENT j_get_srcl_res_spectra, file_list, srcid, >eb1, >eb2, >rate, >rate_err

   Returns energy boundaries eb1 and eb2 under the assumption that they are
   identical for all srcl_res file in the list.

   Also returns 'rate' as a n x m array where n is the number of energy bins
   and m is the number of spectra. rate_err is defined similarly.

   2009-07-03/NJW
*/
{
   local loc_rate, loc_rate_err;

   n_file_list = numberof(file_list);

   rate = [];
   rate_err = [];
   for( i = 1; i <= n_file_list; i++ ) {
      write,i,file_list(i);
      status = j_get_srcl_res_spectrum( file_list(i)+"+1", srcid, eb1, eb2, loc_rate, loc_rate_err );
      if( status == 0 ) {
         nbins = numberof(loc_rate);
         grow,rate, reform(loc_rate,nbins,1);
         grow,rate_err, reform(loc_rate_err,nbins,1);
      }
   }
}

/* Function j_add_spectra */

func j_add_spectra( rate, rate_err, &avg_rate, &avg_rate_err )
/* DOCUMENT j_add_spectra, rate, rate_err, >avg_rate, >avg_rate_err

   Find the average spectrum (with errors) from several spectra.

   Add rate(nbins, n_spectra) weighted with 1/rate_err^2
   and divide with sum of weights.

   2009-07-03/NJW
*/
{
   dms = dimsof(rate);
   if( anyof(dms-dimsof(rate_err)) ) error,"Mismatching array dimensions";

   nbins = dms(2);
   nspectra = dms(3);

   w = where( rate_err == 0.0 );
   if( numberof(w) ) rate_err(w) = 1.;

   weight = 1./rate_err^2;
   rw = rate * weight;
   drw = rate_err * weight;

   avg_rate = rw(,sum)/weight(,sum);
   avg_rate_err = sqrt((drw^2)(,sum)) / weight(,sum);

}

/* Function timeconv */

func timeconv( t_in, in=, out= )
/* DOCUMENT t_out = timeconv( t_in, in=, out= )

   Time conversion between IJD, dattim, JD, revolution, MJD, MST
   INTEGRAL Julian Day, Julian Day, Modified Julian Day, MST
       (Microsoft time i.e. number of seconds since Jan 1, 1970)
   and (Gregorian) string representation: e.g. 2009-10-20T11:32:13
   'revolution' refers to INTEGRAL revolutions.

   Keywords:
        in     can be "dattim", "UTC", "IJD", "revol", "MJD", "MST", or "JD"
       out     can be "dattim", "UTC", "IJD", "revol", "MJD", "MST", or "JD"
                 (case insensitive)

   "dattim" and "UTC" are synonymous and must be in the format
        YYYY-MM-DDTHH:MM:SS.
            ^  ^  ^  ^  ^    required symbols.

   If 't_in' is a string the "dattim" ("UTC") is assumed (overriding
        keyword 'in').
   If 'out' is omitted then
       't_out' will be IJD if t_in is a string, 'dattim' otherwise

   Does not distinguish between lower and upper case.

   Example:  > timeconv("2009-10-21T09:35:44")
             3581.4

   2009-10-20/NJW

*/
{

   if( typeof(t_in) == "string" ) {
      in = "dattim";
   } else t_in = double(t_in);

   if( is_void(in) ) error,"Keyword 'in' must be specified";
   in = strupcase(in);
   if( in == "UTC" ) in = "DATTIM";
   if( is_void(out) ) {
      if( in == "DATTIM" ) {
         out = "IJD";
      } else out = "DATTIM";
   }
   out = strupcase(out);
   if( out == "UTC" ) out = "DATTIM";

   // Read revolution information if at all requested

   if( in == "REVOL" || out == "REVOL" ) {
      dol = "/r6/jemx/integral_history/revolution_latest.fits+1";
      revol_no = double(rdfitscol(dol, "REVOLUTION"));
      time_perigee = rdfitscol(dol, "TIME_PERIGEE");
   }

   //   Convert t_in to IJD

   if( in == "DATTIM" ) {
      ijd = dattim2ijd( t_in );
   } else if( in == "IJD" ) {
      ijd = t_in;
   } else if( in == "REVOL" ) {
      ijd = interp( time_perigee, revol_no, t_in);
   } else if( in == "MJD" ) {
      ijd = t_in - 51544.0;
   } else if( in == "JD" ) {
      ijd = t_in - 2451544.5;
   } else if( in == "MST" ) {
      ijd = (t_in - 946677533)/86400.0;
   } else {
      error,"Illegal keyword 'in'";
   }

   // Convert ijd to desired output type

   if( out == "DATTIM" ) {
      return ijd2dattim(ijd);
   } else if( out == "IJD" ) {
      return ijd;
   } else if( out == "REVOL" ) {
      return interp( revol_no, time_perigee, ijd);
   } else if( out == "MJD" ) {
      return ijd + 51544.0;
   } else if( out == "JD" ) {
      return ijd + 2451544.5;
   } else if( out == "MST" ) {
      return long(ijd * 86400.0+0.5) + 946677533;
   } else {
      error,"Illegal keyword 'out'";
   }

}

/* Function j_get_arc_events */

func j_get_arc_events( jemxNum, swid )
/* DOCUMENT res = j_get_arc_events( jemxNum, swid )

   Returns array of 'struct Event' (defined in jemx.i)
   with all events from science window 'swid'.

    2010-01-21/NJW cloned from j_get_events in 'jemx.i'
*/

{

   local Events;
   local dummy, extno;

   jmxstr = swrite(format="JMX%1i",jemxNum);
   jstr = swrite(format="%1i",jemxNum);
   revol = strpart(swid,1:4);

// Set externals (_PI_Energy_bds_lo/hi) with PI energy boundaries

   if( is_void(_PI_Energy_bds_lo) ) j_get_pi_ebds;

//  prepare filenames for useful files

   savname = "/net/uhuru/pool/pool28/njw/"+revol+"/j"+jstr+"_"+swid+".ysav";
   corname = "/jemx/arc/rev_2/scw/"+revol+"/"+swid+".001/jmx"+jstr+"_full_cor.fits";

//  Check for previously saved event file for faster reading

   if( file_test(savname) ) { // The easy way

      stream = openb(savname);
      restore, stream, Events;
      close, stream;

   } else { // start the entire machinery

      cor = 0;
      if( file_test(corname) || file_test(corname+".gz") ) {

// Check for jmxi_full_cor.fits file in JEM-X archive

         full_cor = gz_proxy_file( corname );
         cor = 1;

      } else {

         write,"full_cor file is not available, try using jmxi_events.fits";

      }

   //     The event file is to be found in the data archive:
      evts_file = "/jemx/arc/rev_2/scw/"+revol+"/"+swid+".001/jmx"+jstr+"_events.fits";
      evts_file_p = gz_proxy_file( evts_file );
      if( is_void(evts_file_p) ) {
         write,"Failed to find: "+evts_file;
         return [];
      }

      rhdr = headfits( evts_file_p+"+1" );
      rswid = itoa(fxpar(rhdr, "SWID"));
      rinstr = itoa(fxpar(rhdr, "INSTRUME"));

      if( cor ) {
         fhdr = headfits( full_cor+"+1" );
         fswid = itoa(fxpar(fhdr, "SWID"));
         finstr = itoa(fxpar(fhdr, "INSTRUME"));
         if( fswid  !=  rswid ) {
            write,"Mismatching SWIDs: ", fswid+"  "+rswid;
            return [];
         }
         if( finstr  !=  rinstr ) {
            write,"Mismatching INSTRUMEs: ", finstr+"  "+rinstr;
            return [];
         }
      }

      //  Get the events
      //  Since jmxi_full_cor.fits.gz with columns DETX, DETY, PI, ENERGY, STATUS
      //  may have better correction than jmxi_events.fits[JMXi-FULL-ALL]
      //  these values are loaded afterwards

      extnam = finstr+"-FULL-ALL";
      get_exten_no, evts_file_p+"["+extnam+"]", dummy, extno;
      if( extno == -1 ) {
         write,"No FULL-ALL extension found in jxmi_events.fits, quit!";
         return [];
      }
      dol = evts_file_p+"+"+itoa(extno);
      hdr = headfits( dol );
      ptr = rdfitsbin( dol );
      rawx   = *ptr(fits_colnum( hdr, "RAWX"));
      rawy   = *ptr(fits_colnum( hdr, "RAWY"));
      detx   = *ptr(fits_colnum( hdr, "DETX"));
      dety   = *ptr(fits_colnum( hdr, "DETY"));
      pha    = *ptr(fits_colnum( hdr, "PHA"));
      evtime = *ptr(fits_colnum( hdr, "TIME"));
      piarr  = *ptr(fits_colnum(hdr,"PI"));
      status = *ptr(fits_colnum(hdr,"STATUS"));
      cn = fits_colnum(hdr,"ENERGY");
      if( cn ) energy = *ptr(cn);
      nrows = numberof(rawx);

      if( cor ) { // if jmxi_full_cor.fits exists then override some values
         dol = full_cor+"+1";
         hdr = headfits( dol );
         ptr = rdfitsbin( dol );
         detx   = *ptr(fits_colnum( hdr, "DETX"));
         dety   = *ptr(fits_colnum( hdr, "DETY"));
         piarr  = *ptr(fits_colnum(hdr,"PI"));
         cn = fits_colnum(hdr,"ENERGY");
         if( cn ) energy = *ptr(cn);
         status = *ptr(fits_colnum(hdr,"STATUS"));
      }
      if( nrows == 0 ) {
         write,"No events in  file";
         return [];
      }

      Events = array(Event, nrows);
      Events.rawx = toint(rawx);
      Events.rawy = toint(rawy);
      Events.pha  = toint(pha);
      Events.evtime  = evtime;
      if( cn ) {
         Events.energy  = energy;
      } else {
          Events.energy = _PI_Energy_bds_lo(piarr+1) + \
            random(nrows)*(_PI_Energy_bds_hi(piarr+1) - _PI_Energy_bds_lo(piarr+1));
      }

      Events.detx = detx;
      Events.dety = dety;
      Events.piarr = toint(piarr);
      Events.status = toint(status);

//  Save this event array for quicker read next time it is requested

      savname = "/net/uhuru/pool/pool28/njw/"+revol+"/j"+jstr+"_"+swid+".ysav";
      stream = createb(savname);
      save, stream, Events;
      close, stream;

   }

   return Events;

}

/* Function j_comb_dsp_spectra */

func j_comb_dsp_spectra( filelist, outspe=, noplot=, silent=, nolog= )
/* DOCUMENT j_comb_dsp_spectra, filelist, outspe=, noplot=, silent=, nolog=

   Get several detector spectra combined from data e.g. produced with j_bin_spec

   Assumes PHAII representation of spectra i.e. in a vector columns: RATE and
   STAT_ERR

    2008-01-30/NJW Cloned from collect_spectra.i
    2008-05-19/NJW Cloned from j_comb_spectra.i

*/
{
   local strnum;

   if( ! numberof(filelist) ) {
      write,"There is no indication of where to find the spectra ...";
      return [];
   }
   v = !silent;

   num_of_spec = 1; // Standard for detector spectra
   pflag = is_void(noplot);

   nlist = numberof(filelist);
   filelist = filelist(sort(filelist));
   filelist_used = filelist;
   nlist_used = 0;


   // Prepare the output files jmxi_nnnn_spe.fits
   // in the current directory but only if keyword outspe is set

   if( !numberof(outspe) ) {

      fname_spe = get_next_filename("jemx_????_spe.fits", strnum);
      logfile = "j_comb_dsp_spectra"+strnum+".log";

   } else {

      fname_spe = outspe;
      logfile = get_next_filename("j_comb_dsp_spectra????.log");

   }

   cp,"/home/njw/jemx/spectra/jmx1_full_dsp_sample.fits",fname_spe;

   tot_spec = array(float,256);
   tot_err2 = array(float,256);
   tot_expo = 0.0;

   if( !nolog ) {
      write,"Output logging data in "+logfile;
      lun = open(logfile,"w");

      write,lun,"  Logging of j_comb_dsp_spectra   "+ndate(3);
      write,lun;
      write,lun,"Resulting SPE file: "+fname_spe;
   }

   for( i = 1; i <= nlist; i++ ) {

      if(v)write,"Analyzing "+itoa(i)+" of "+itoa(nlist);
      if( !nolog ) {
         write,lun,"-------------------------------";
         write,lun,filelist(i);
      }
      // Get header
      hdr = headfits(filelist(i)+"+1");
      naxis2 = fxpar(hdr,"NAXIS2");
      if( naxis2  <=  0 ) {
         if(v)write,"Skip - no rows";
         if(!nolog)write,lun,"Skip this one, there are no rows";
         continue;
      }
      if( naxis2 < num_of_spec ) {
         if(v)write,"Too few rows in file";
         if(!nolog)write,lun,"Too few rows in file";
         continue;
      }

      pick_swid_str, filelist(i), swid;
      swid = numberof(swid) ? swid(1) : "Unknown SWID";

      // read the exposure times
      exposure = rdfitscol(filelist(i)+"+1","EXPOSURE");

      // Get the spectrum etc.

      rate =     rdfitscol(filelist(i)+"+1","RATE");
      stat_err = rdfitscol(filelist(i)+"+1","STAT_ERR");

      if( pflag ) {
         dataplot,indgen(256),rate(,num_of_spec),stat_err(,num_of_spec);
         xyouts,0.25,0.82,swid,charsize=1.3,ndc=1;
         xyouts,0.25,0.80,swrite(format="Exposure %10.2f s",exposure(num_of_spec)), \
                      charsize=1.3,ndc=1;
      }

      // include this one in the list of used spectral files;
      filelist_used(++nlist_used) = filelist(i);

      if(!nolog)write,lun,format="Exposure time is %10.2f s\n",exposure(num_of_spec);

      tot_spec += reform(rate(,num_of_spec),256)*exposure(num_of_spec);
      tot_err2 += (reform(stat_err(,num_of_spec),256)*exposure(num_of_spec))^2;
      tot_expo += exposure(num_of_spec);

   }

   if( !nolog ) {
      write,lun,"// total_exposure = ", tot_expo," ; s";
      write,lun,"//  --- Normal exit ---";

      close,lun;
   }

   tot_spec = tot_spec / tot_expo;
   tot_err  = sqrt(tot_err2) / tot_expo;

   if( pflag ) dataplot,indgen(256),tot_spec,tot_err;

   //  write file with collected spectrum;

   write,"New spectrum file: "+fname_spe;

   fh = headfits( fname_spe+"+1" );
   colnum = get_colnum( fh, "rate" );
   fits_bintable_poke, fname_spe+"+1",  1, colnum, float(tot_spec);
   colnum = get_colnum( fh, "stat_err" );
   fits_bintable_poke, fname_spe+"+1",  1, colnum, float(tot_err);
   colnum = get_colnum( fh, "exposure" );
   fits_bintable_poke, fname_spe+"+1",  1, colnum, double(tot_expo);


   //  Update the checksum;

   //+ system,"fchecksum "+fname_spe+" update=yes";


}

/* Function gti_print */

func gti_print( filename, outfile= )
/* DOCUMENT gti_print, filename, outfile=

   Nice print of GTI information in jmxi_gti.fits

   2010-04-16/NJW
*/
{
   if( !file_test(filename) ) {
      if( !file_test(filename+".gz") ) {
         error,filename+" not found";
      } else {
         filename = gz_proxy_file( filename );
      }
   }

   if( typeof(outfile) == "string" ) {
      fo = open(outfile,"a");
   } else fo = [];

   nexts = nfits_extens( filename );

// ---   PASS 1 --- get earliest GTISTART

   gti0 = [];
   for( iext = 1; iext <= nexts; iext++ ) {
      fh = headfits( filename+"+"+itoa(iext) );
      extname = fxpar( fh, "EXTNAME" );
      ending = strpart( extname, -2:0 );
      if( ending == "GTI" ) {
         if( numberof( (gtistart = rdfitscol(filename+"+"+itoa(iext),"start")))) {
            gtistop  = rdfitscol(filename+"+"+itoa(iext),"stop");
            if( is_void(gti0) ) {
               gti0 = min(gtistart);
            } else {
               if( min(gtistart) < gti0 ) gti0 = min(gtistart);
            }
         }
      }
   }

// ---   PASS 2 --- print out the GTI IJD values

   for( iext = 1; iext <= nexts; iext++ ) {
      fh = headfits( filename+"+"+itoa(iext) );
      extname = fxpar( fh, "EXTNAME" );
      ending = strpart( extname, -2:0 );
      write,fo,format="\nExt# %2i - EXTNAME = %s\n\n", iext, extname;
      if( ending == "GTI" ) {
         gtiname = fxpar( fh, "GTI_NAME" );
         if( is_void(gtiname) ) gtiname = "?????";
         write,fo,format="    GTI_NAME = %s\n", gtiname;
         if( numberof( (gtistart = rdfitscol(filename+"+"+itoa(iext),"start")))) {
            gtistop  = rdfitscol(filename+"+"+itoa(iext),"stop");
            ngti = numberof(gtistart);
            for( i = 1; i <= ngti; i++ ) {
               write,fo,format="   %13.8f %13.8f %10.2f %10.2f\n", \
                      gtistart(i), gtistop(i), (gtistart(i)-gti0)*86400., \
                                               (gtistop(i)-gti0)*86400.;
            }
         }
      }
   }

   if( !is_void(fo) ) close,fo;

}

/* Function find_swid_slice */

func find_swid_slice( p0, q0, dp, dq, rev=, tstart=, \
                      tstop=, nof=, silent=, lst=, gal=, constw= )
/* DOCUMENT list = find_swid_slice( p0, q0, dp, dq,
                       [,rev=][, tstart=][, tstop=]
                       [,nof=][, silent=][, lst=][, gal=][, constw=] )

    Find the INTEGRAL SWIDs where the pointings are inside the slice
    p0 - dp/2 <= p <= p0 + dp/2 AND q0 - dq/2 <= q <= q0 + dq/2

    (p,q) is either (ra,dec)- no keyword -  or (lon,lat) when 'gal' is set.

    The interval where ra0 is close to zero or 360 deg is treated as expected.
    No declination is outside [-90,90] degrees.

    2011-01-18/NJW  Cloned from find_swid_radec

   Keywords:
             rev   :  Either scalar integer or 2 element integer
                      array with min and max revolution number
             tstart:  Time in IJD for start of interval
             tstop :  Time in IJD for end of interval
             lst   :  Makes returned list a list of SWIDs in jemx.lst format
                         (overrides setting of 'list')
             nof   :  Flag to avoid file writing
             gal   :  Flag to interpret input coordinates as galactic
             constw:  Constant width in true angle - 'dp' applies for
                      q == 0
*/
{

   local swid, ra, dec, posangle, ut, ijd, telapse, mode1, mode2;

   if( is_void(dq) ) {
      write,"Syntax: list = find_swid_radec_slice(p0,q0, dp, dq, keywords... )";
      return [];
   }
   //
   //  Initialize
   //
   if( is_void(silent) ) silent = 0;
   first = 1;
   tbegin = is_void( tstart ) ? 0.0 : tstart;
   // if( tstart ) { tbegin = tstart; } else { tbegin = 0.0; }
   tend = is_void( tstop ) ? 1.0e9 : tstop;
   // if( tstop ) { tend = tstop; } else { tend = 1.0e9; }
   p0 = double(p0);
   q0 = double(q0);
   dp = double(dp);
   dq = double(dq);
   if( gal ) {
      lon0 = p0;
      lat0 = q0;
      radec0 = equatorial( p0, q0 );
      ra0 = radec0(1);
      dec0 = radec0(2);
   } else {
      ra0 = p0;
      dec0 = q0;
      galac0 = galactic( p0, q0 );
      lon0 = galac0(1);
      lat0 = galac0(2);
   }

   //
   // Get list of pointing files
   //
   base = get_env("J_POINTINGS");

   if( numberof(rev) ) {
      if( typeof(rev) == "string" ) {
         revarr = str2arr( rev );
      } else {
         if( numberof( rev ) == 2 ) {
            revarr = indgen(long(rev(2)-rev(1))+1) + long(rev(1)) - 1;
         } else {
            revarr = long(rev)
         }
      }
      nrev = numberof(revarr);
      for( i = 1; i <= nrev; i++ ) {
         revstr = swrite(revarr(i),format="%4.4i");
         tmp = base+"/pointings_"+revstr+"p.dat";
         if( !silent ) write,tmp;
         ybase = base+"/ysav"+swrite(revarr(i)/100,format="%02i/");
         ytmp = ybase+"pointings_"+revstr+"p.ysav";
         if( !silent ) write,ytmp;
         if( i == 1 ) {
            pf_list = tmp;
            ypf_list = ytmp;
         } else {
            grow,pf_list,tmp;
            grow,ypf_list,ytmp;
         }
      }
   } else {
      pf_list = file_search("pointings_*p.dat", base);
      ypf_list = pf_list;
      npf_list = numberof(pf_list);
      for( i = 1; i <= npf_list; i++ ) {
         pos = strpos( pf_list(i),"_" );
         revstra = strpart(pf_list(i), pos+1:pos+4 );
         drevstra = strpart(pf_list(i),pos+1:pos+2);
         ybase = base+"/ysav"+drevstra;
         ytmp = ybase+"/pointings_"+revstra+"p.ysav";
         ypf_list(i) = ytmp;
      }
   }
   npf_list = numberof(pf_list);
   if( npf_list == 0 ) {
      write,"find_swid_radec_slice error: no pointing files of required kind found";
      return -1;
   }

   if( !nof ) {

      // Open output file

      outfilename = get_next_filename("find_swid_radec_???.dat");
      fout = open(outfilename,"w");
      n = write(fout,format="%s\n","// Results from find_swid_radec_slice");
      n = write(fout,format="// created %s\n", ndate(3));
      n = write(fout,format="// ra0  = %7.3f; deg\n", ra0);
      n = write(fout,format="// dec0 = %7.3f; deg\n", dec0);
      n = write(fout,format="// lon0 = %7.3f; deg\n", lon0);
      n = write(fout,format="// lat0 = %7.3f; deg\n", lat0);
      n = write(fout,format="//   dp = %7.3f; deg\n",   dp);
      n = write(fout,format="//   dq = %7.3f; deg\n",   dq);
      if( tstart ) {
         n = write(fout,format="// tstart = %14.8f; IJD\n", tstart);
      }
      if( tstop ) {
         n = write(fout,format="// tstop = %14.8f; IJD\n", tstop);
      }
      if( numberof(rev) ) {
         if( nrev == 1 ) {
            n = write(fout,format="// rev_begin = %4i\n", revarr(1));
            n = write(fout,format="// rev_end   = %4i\n", revarr(1));
         } else {
            n = write(fout,format="// rev_begin = %4i\n", revarr(1));
            n = write(fout,format="// rev_end   = %4i\n", revarr(0));
         }
      }

   }

   ntotal = 0;
   for( ipf_list = 1; ipf_list <= npf_list; ipf_list++ ) {

      if( file_test(ypf_list(ipf_list)) ) {
         if( !silent ) write,"Reading binary file "+ypf_list(ipf_list);
         bfile = openb( ypf_list(ipf_list) );
         restore,bfile, swid, ra, dec, posangle, ut, ijd, telapse, \
                     mode1, mode2;
         close, bfile;
      } else {
         if( !silent ) write,"Reading usual text file "+pf_list(ipf_list);
         if( ! file_test(pf_list(ipf_list)) ) {
            if( !silent ) write,pf_list(ipf_list)+" was not found";
            continue;
         }
      /*
       * swid = rscol( pf_list(ipf_list),1, str=1, silent=1);
       * ra = rscol( pf_list(ipf_list), 2, silent=1);
       * dec = rscol( pf_list(ipf_list), 3, silent=1);
       * posangle = rscol( pf_list(ipf_list), 4, silent=1);
       * ut = rscol( pf_list(ipf_list), 5, str=1, silent=1);
       * ijd = rscol( pf_list(ipf_list), 6, silent=1);
       * telapse = rscol( pf_list(ipf_list),7, silent=1);
       * mode1 = rscol( pf_list(ipf_list), 8, str=1, silent=1);
       * mode2 = rscol( pf_list(ipf_list), 9, str=1, silent=1);
       */

         rstab,pf_list(ipf_list),9,swid,ra,dec,posangle,ut,ijd,telapse, \
              mode1, mode2,typ="sfffsffss",silent=1;

         bfile = createb( ypf_list(ipf_list) );
         save, bfile,  swid, ra, dec, posangle, ut, ijd, telapse, \
                 mode1, mode2;
         close, bfile;
      }

      lonlat = galactic(ra, dec);
      lon = lonlat(,1);
      lat = lonlat(,2);

      if( gal ) {
         p = lon;
         q = lat;
      } else {
         p = ra;
         q = dec;
      }

      if( constw ) dp = dp/cos(q*pi/180.);

      ip = near360( p0, p, 0.5*dp );
      iq = q >= q0 - 0.5*dq & q <= q0 + 0.5*dq;
      iboth = ip & iq;
      w = where( iboth );
      nw = numberof(w);

      if( nw > 0 ) {

         if( first ) {
            first = 0;
            swid_all = swid(w);
            ra_all = ra(w);
            dec_all = dec(w);
            posangle_all = posangle(w);
            ut_all = ut(w);
            ijd_all = ijd(w);
            telapse_all = telapse(w);
            mode1_all = mode1(w);
            mode2_all = mode2(w);
         } else {
            grow,swid_all,swid(w);
            grow,ra_all,ra(w);
            grow,dec_all,dec(w);
            grow,posangle_all,posangle(w);
            grow,ut_all,ut(w);
            grow,ijd_all,ijd(w);
            grow,telapse_all,telapse(w);
            grow,mode1_all,mode1(w);
            grow,mode2_all,mode2(w);
         }

         ntotal += nw;

      }

   }
   if( ntotal == 0 ) {
      write,"Sorry, no pointings found!";
      return [];
   }

   noutput = 0;
   list = "";
   list_list = [];
   for( i = 1; i <= ntotal; i++ ) {
      // apply the time selection
      if( ijd_all(i) > tbegin && ijd_all(i) < tend ) {
         grow,list_list,swid_all(i);
         if( !nof) {
            write,fout,format="%s%10.4f%9.4f%9.3f  %s%10.3f%6.0f  %s  %s %8.2f %7.0f\n",
            swid_all(i),ra_all(i),dec_all(i),posangle_all(i),
            ut_all(i),ijd_all(i),telapse_all(i),
            mode1_all(i),mode2_all(i),dist_all(i), expo_contrib;
         }
         noutput++;
      }
   }


   lst_list = array("",ntotal);
   for( i = 1; i <= ntotal; i++ ) {
      lst_list(i) = "./scw/"+strpart(swid_all(i),1:4)+"/"+swid_all(i)+".001/swg.fits[1]";
   }

   if( !silent ) {
      write,format="Found %i SWIDs in selected revolutions\n", ntotal;
      if( noutput == 1 ) {
         write,format="%i has been selected by time\n", noutput;
      } else {
         write,format="%i have been selected by time\n", noutput;
      }
      if( !nof ) write,"Output is directed to "+outfilename;

   }

   if(!nof) close,fout;

   if( !is_void(lst) ) { return lst_list; } else {return list_list;}

}

/* Function bti_info */

func bti_info( jemxNum, outfile= )
/* DOCUMENT bti_info, jemxNum, outfile=

     Make a table of most recent BTI information in OSA9.

     Outputs to a text file if 'outfile' contains a string (filename).

   2012-04-19/NJW

*/
{
   if( typeof(outfile) == "string" ) {
      p = 1;
      f = open(outfile,"w");
   } else p = 0;

   jstr = itoa(jemxNum);
   dir = "/pack/osa_sw-9.0/rep_base_prod/ic/jmx"+jstr+"/lim";
   name = "jmx"+jstr+"_gnrl_bti_*.fits";
   list = file_search(name,dir);
   write,format="Files available in %s:\n", dir;
   if(p)write,f,format="Files available in %s:\n", dir;
   for(i=1;i<=numberof(list);i++) {
      write,format="   %s\n", basename(list(i));
      if(p)write,f,format="   %s\n", basename(list(i));
   }
   dol = list(0)+"+1"; // Choose most recent
   tstart = rdfitscol(dol,"start");
   tstop = rdfitscol(dol,"stop");
   w = where( tstart > 1097. );
   tstart = tstart(w);
   tstop = tstop(w);
   n = numberof(tstart);

   for( i = 1; i <= n; i++ ) {
      write,format="%12.6f %12.6f  ", tstart(i), tstop(i);
      if(p)write,f,format="%12.6f %12.6f  ", tstart(i), tstop(i);
      revol_start = long(get_revol_no(tstart(i)+0.04));
      revol_stop  = long(get_revol_no(tstop(i)));
      for( revol = revol_start; revol <= revol_stop; revol++ ) {
         if( revol > revol_start ) {
            write,format="%s","                           ";
            if(p)write,f,format="%s","                           ";
      }
         write,format="%04i ", revol;
         if(p)write,f,format="%04i ", revol;
         pointfile = "/r6/jemx/pointings/pointings_"+itoa(revol,4)+".fits";
         if( file_test(pointfile) ) {
            pointdol = pointfile+"+1";
            swid = rdfitscol( pointdol, "swid" );
            tswid1 = rdfitscol( pointdol, "tstart" );
            tswid2 = rdfitscol( pointdol, "tstop" );
            w = where( tswid1 > tstart(i) ); // those later than BTI start
            m = where( tswid2 < tstop(i)  ); // those earlier than BTI stop
            swid_first = numberof(w) ? swid(w(1)) : "000000000000";
            swid_last  = numberof(m) ? swid(m(0)) : "000000000000";
            write,format="  %s  %s\n", swid_first, swid_last;
            if(p)write,f,format="  %s  %s\n", swid_first, swid_last;
         } else {
            write,"  <pointing file not available>";
            if(p)write,f,"  <pointing file not available>";
         }
      }
   }
   if(p) close,f;
}

/* Function bti_struck */

func bti_struck( jemxNum, t1, t2 )
/* DOCUMENT res = bty_struck( jemxNum, t1, t2 )

    Returns "Y" if there is a BTI set up somewhere after 't1' (IJD)
    and before 't2' (IJD). Typically t1 and t2 will be start and stop
    for a SWID or a revolution.

   2012-04-19/NJW
*/
{
   extern BTI_JMX1_TSTART, BTI_JMX1_TSTOP, BTI_JMX2_TSTART, BTI_JMX2_TSTOP;

   jstr = itoa(jemxNum);
   if( t2 < t1 ) { x = t1; t1 = t2; t2 = x; } // swap so t1 <= t2


   if( ( jemxNum == 1 && is_void(BTI_JMX1_TSTART) ) || \
       ( jemxNum == 2 && is_void(BTI_JMX2_TSTART) ) ) { // data reading is required

      dir = "/pack/osa_sw-9.0/rep_base_prod/ic/jmx"+jstr+"/lim";
      name = "jmx"+jstr+"_gnrl_bti_*.fits";
      list = file_search(name,dir);
      write,format="Files available in %s:\n", dir;
      for(i=1;i<=numberof(list);i++) {
         write,format="   %s\n", basename(list(i));
      }
      dol = list(0)+"+1"; // Choose most recent
      if( jemxNum == 1 ) {
         BTI_JMX1_TSTART = rdfitscol(dol,"start");
         BTI_JMX1_TSTOP  = rdfitscol(dol,"stop");
      } else {
         BTI_JMX2_TSTART = rdfitscol(dol,"start");
         BTI_JMX2_TSTOP  = rdfitscol(dol,"stop");
      }
   }
   if( jemxNum == 1 ) {
      bti_tstart = BTI_JMX1_TSTART;
      bti_tstop  = BTI_JMX1_TSTOP;
   } else {
      bti_tstart = BTI_JMX2_TSTART;
      bti_tstop  = BTI_JMX2_TSTOP;
   }

   w = where(bti_tstop > t1 );
   if( numberof(w) == 0 ) return "N";
   if( bti_tstart(w(1)) < t2 ) return "Y";
   return "N";

}
%FILE% kfits.i
/*
 * kfits.i -
 *
 *	Implement FITS files input/output and editing in Yorick.
 *
 *--------
 * Updated version 2008-10-01 by NJW from fits.i from yorick-2.1.04
 *--------
 *
 * Copyright (c) 2000-2002 Eric THIEBAUT.
 *
 * History:
 *	$Id: fits.i,v 1.25 2007/02/15 08:19:38 thiebaut Exp $
 *	$Log: fits.i,v $
 *	Revision 1.25  2007/02/15 08:19:38  thiebaut
 *	Force CVS revison number to match RCS one.
 *	
 *	Revision 1.4  2006/11/27 16:56:15  thiebaut
 *	fixed True and Not methods for built-in and interpreted functions
 *	
 *	Revision 1.25  2006/11/03 12:09:18  eric
 *	 - Fixed bug in fits_pack_bintable (thanks to Ariane Lançon for
 *	   discovering this bug).
 *	 - Slightly change the calling sequence of fits_pack_bintable
 *	   (no side effects w.r.t. previous version).
 *
 *	Revision 1.24  2006/10/17 12:11:07  eric
 *	 - Fixed fits_write function to properly pad FITS file with
 *	   zeroes (thanks to Christophe Pichon for discovering this
 *	   bug).
 *
 *	Revision 1.23  2006/09/07 07:20:31  eric
 *	 - Fixed documentation (thanks to Ariane Lançon).
 *
 *	Revision 1.22  2006/09/02 12:39:04  eric
 *	 - Minor changes to make the code portable with different versions
 *	   of Yorick.
 *
 *	Revision 1.21  2006/05/03 15:50:58  eric
 *	 - Handle TDIM keyword in BINTABLE.
 *	 - New function: fits_get_list.
 *	 - Fix some documentation.
 *	 - Minor speedup.
 *
 *	Revision 1.20  2006/02/07 12:09:46  eric
 *	 - be more tolerant for non-compliant FITS file: completely
 *	   ignore header bytes after the "END" card;
 *
 *	Revision 1.19  2006/01/26 08:06:07  eric
 *	 - fixed "errmode" argument in fits_check_file;
 *	 - improved documentation of fits_read function.
 *
 *	Revision 1.18  2005/03/29 13:57:54  eric
 *	 - fix guessing of column type when TFORM# keyword is already defined
 *	 - fix fits_is_... routines
 *
 *	Revision 1.17  2004/10/22 15:19:29  eric
 *	 - fits_write_bintable takes into account existing "TFORM#" FITS
 *	   cards to format the columns (thanks to Clémentine Béchet).
 *	 - New function: fits_strcmp.
 *
 *	Revision 1.16  2004/09/03 09:13:27  eric
 *	 - New function fits_pad_hdu to round up file size to a multiple
 *	   of FITS blocking factor.
 *	 - fits_new_hdu: fix offset of data part by calling fits_pad_hdu
 *	   (thanks to Antoine Mérand for pointing this bug).
 *	 - fits_close: call fits_pad_hdu to finalize stream open for
 *	   writing.
 *	 - fits_new_image: bitpix and dimension list can be guessed from
 *	   suplementary argument.
 *
 *	Revision 1.15  2004/09/02 12:51:59  eric
 *	 **************** POTENTIAL INCOMPATIBILITY ******************
 *	 ***                                                       ***
 *	 ***  fits_read_bintable and fits_write_bintable modified  ***
 *	 ***  so that field dimensions are more consistent with    ***
 *	 ***  usual definition: the 'rows' of the table now run    ***
 *	 ***  along the first dimension of the fields and fields   ***
 *	 ***  with a repeat count of 1 can be simple vectors.      ***
 *	 ***                                                       ***
 *	 *************************************************************
 *
 *	 - fits_read_bintable: keyword SELECT has a different meaning
 *	 - fits_read_bintable: new keyword TRIM
 *	 - new function fits_pack_bintable, old version fits_pack_table
 *	   removed (it was broken and of little interest)
 *
 *	Revision 1.14  2004/07/09 18:05:34  eric
 *	 - Fix setting of BSCALE/BZERO in fits_create.
 *
 *	Revision 1.13  2004/07/09 12:45:58  eric
 *	 - New function fits_best_scale to compute optimal BSCALE and BZERO
 *	   for real to integer conversion.
 *	 - Function fits_write modified to use fits_best_scale by default.
 *	 - New keyword NATIVE for fits_bitpix_type function.
 *
 *	Revision 1.12  2004/07/09 09:30:37  eric
 *	 - Fixed bug in fits_move and typo in error message for fits_create
 *	   (thanks to Clémentine Béchet).
 *
 *	Revision 1.11  2004/06/22 16:22:49  eric
 *	 - Fix a bug in fits_write_bintable which prevents writing strings in
 *	   a binary table (thanks to Clémentine Béchet).
 *
 *	Revision 1.10  2004/03/19 18:28:45  eric
 *	 - New functions: fits_current_hdu, fits_info, fits_eof, fits_list.
 *	 - Fix bug in fits_goto_hdu when arriving at the end of the file
 *	   (thanks to Bastien Aracil).
 *
 *	Revision 1.9  2003/12/04 15:57:23  eric
 *	 - Fixed a bug in column order for BINTABLE.
 *
 *	Revision 1.8  2003/11/16 13:57:02  eric
 *	 - fits_read_bintable: new keywords RAW_STRING and RAW_LOGICAL;
 *	 - fits_set: fix for commentary card;
 *	 - fits_read_bintable_as_hashtable: new function to read a BINTABLE
 *	   and return it as a hash table (requires Yeti extension);
 *
 *	Revision 1.7  2003/05/23 14:12:43  eric
 *	 - New function fits_pack_table, resulting in new keywords PACK
 *	   and SELECT in fits_read and fits_read_bintable.
 *
 *	Revision 1.6  2003/03/28 14:48:54  eric
 *	 *** POSSIBLE INCOMPATIBILITY ***
 *	 Fields of a BINTABLE are now NCOLS(i)xNROWS arrays
 *	 (instead of NROWS or NROWSxNCOLS(i) arrays).
 *
 *	Revision 1.5  2003/03/28 14:01:17  eric
 *	 - fits_new_bintable: add optional comment.
 *
 *	Revision 1.4  2003/03/25 13:10:55  eric
 *	 - Keyword LOGICAL removed in fits_read.
 *
 *	Revision 1.3  2003/03/17 16:51:54  eric
 *	 - New keywords in fits_write, fits_create: template, history
 *	   and comment.
 *
 *	Revision 1.2  2003/01/31 15:10:07  eric
 *	 - Added support for obsolete FITS API.
 *
 *	Revision 1.1  2003/01/07 17:10:59  eric
 *	Initial revision
 *
 */

/*---------------------------------------------------------------------------*/
local fits;
fits = "$Revision: 1.25 $";
/* DOCUMENT fits - an introduction to Yorick interface to FITS files.

     The  routines  provided by  this  (standalone)  package  are aimed  at
     reading/writing  FITS (Flexible Image Transport  System) files from/to
     Yorick.  These  routines attempt to follow the  FITS standard (version
     1.1)  as defined in  NOST report  [1].  Nevertheless  the user  may be
     aware of some  limitations (some of which are  unavoidable with such a
     "flexible" format as FITS):

      - It  is still possible to  produce a non-standard  FITS file because
        (for obvious  efficiency reasons)  routines in this  package cannot
        check  everything.  At  least, FITS  routines check  that compliant
        FITS keywords  are used and that  mandatory cards (SIMPLE/XTENSION,
        BITPIX,  NAXIS, ...)   get written  in the  correct order  and with
        correct value types (see  fits_set).  Nevertheless, the user has to
        know only  very little  about FITS standard  to be able  to produce
        valid FITS files.

      - In this version  of the package, headers of  any FITS extension can
        be read/produced but  you can only read/write Yorick  array data or
        binary tables, i.e.  corresponding to primary data and FITS "IMAGE"
        or  "BINTABLE" extensions  (see  fits_read_array, fits_write_array,
        fits_read_bintable, and fits_write_bintable).  Support for standard
        extensions (such  as ASCII  table "TABLE") is  planned but  not yet
        done.

      - There  is   no  special   handling  of  IEEE  special  values  NaN,
        +/-Infinity (using such values is  likely to raise a floating point
        error catched by Yorick).

      - You  cannot read/write  compressed  FITS  files.   You'll  have  to
        pre-decompress or post-compress files  (you can use Yorick "system"
        function to that end).

      - It is (not yet) possible to re-open an existing FITS file to modify
        it.  But it would be very easy to allow for appending extensions to
        an existing file (should be provided very soon).

     Some simple driver routines  are provided to allow for reading/writing
     Yorick arrays from/to FITS file  and may be sufficient for basic usage
     (see fits_read and fits_write).


   READING AN EXISTING FITS FILE

     There is a simplified driver fits_read  (which see) to read data in an
     existing FITS file.  The following example demontrates how to read the
     contents of a FITS file with the basic routines:

     fh = fits_open(name);                 // open existing file and read
                                           // header of 1st (primary) HDU
     data1 = fits_read_array(fh);          // read all "image" data in 1st HDU
     slice = fits_read_array(fh, which=n); // read N-th data slice in current
                                           // HDU
     fits_next_hdu, fh;                    // move to next HDU and read header
     data2 = fits_read_array(fh);          // read data of secondary HDU
     ...;


   CREATING A NEW FITS FILE:

     There is a (very) simplified driver fits_write (which see) to create a
     new  FITS  file to  store  a  Yorick  array.  The  following  examples
     demontrates how to write a moderately complex FITS file with the basic
     routines (assuming DATA1 is a 2-dimensional array):

       fh = fits_open(name, 'w');      // create new file
       fits_set, fh, "SIMPLE", 'T',    "true FITS file";
       fits_set, fh, "BITPIX", bitpix, "bits per pixel";
       fits_set, fh, "NAXIS",  naxis,  "number of dimensions";
       fits_set, fh, "NAXIS1", dim1,   "length of 1st dimension";
       fits_set, fh, "NAXIS2", dim2,   "length of 2nd dimension";
       fits_set, fh, "EXTEND", 'T', "this file may contain FITS extensions";
       fits_set, fh, ...               // set any number of other cards with
       ...                             // several calls to fits_set
       fits_write_header, fh;          // write header part of current HDU
       fits_write_array, fh, data1;    // write data part of current HDU

       fits_new_hdu, fh, "IMAGE";        // append new "IMAGE" extension
       fits_set, fh, "BITPIX", bitpix, "bits per pixel";
       fits_set_dims, fh, dimsof(data2); // set all dimensions in one call
       fits_set, fh, ...                 // set any number of other cards with
       ...
       fits_write_header, fh;            // write header part of extension
       fits_write_array, fh, data2;      // write data part of extension
       fits_close, fh;                   // close stream of FITS handle, the
                                         // header can still be examined

     Note  that the cards  with the  dimensions of  the data  array (NAXIS,
     NAXIS1, ...)  which  are explicitly set with fits_set  for the primary
     header can  also be instanciated  in a more  simple way thanks  to the
     function fits_set_dims as shown for the second HDU.

     Alternatively, The function fits_create can be used to open a new file
     and setup  a basic primary header.   In this case, the  first lines of
     the above examples become:

       fh = fits_create(name, extend=1,
                        bitpix=fits_bitpix_of(data1),
                        dimlist=dimsof(data1));
       fits_set, fh, ...               // set any number of other cards with
       ...                             // several calls to fits_set
       fits_write_header, fh;          // write header part of current HDU
       fits_write_array, fh, data1;    // write data part of current HDU

     If you intend to write more than one HDU, do not forget to set card
     EXTEND to true in the primary header (this is done in the two examples
     above with fits_open and with fits_create).


   LIST OF ROUTINES

     By convention, in this Yorick package, all public symbols (routines or
     variables)  are prefixed  with  "fits_" and  all  private symbols  are
     prefixed with "_fits_".  The following (public) routines are provided:

     File routines:
       fits_check_file     - check whether a file may be a FITS file
       fits_open           - open existing FITS file or create new FITS file
       fits_close          - close file stream in FITS handle
       fits_create         - creates a new FITS file with minimal header
       fits_filename       - get full path name of FITS stream

     Header/HDU routines:
       fits_current_hdu    - returns number of current HDU
       fits_goto_hdu       - go to a given HDU number
       fits_list           - get list of extensions in a FITS file
       fits_next_hdu       - move to next HDU and parse the header part
       fits_pad_hdu        - pad current HDU to a multiple of 2880 bytes
       fits_rewind         - goto first (primary) HDU
       fits_new_hdu        - start a new FITS extension
       fits_read_header    - read header part of current HDU
       fits_write_header   - write header part of current HDU

     Card routines:
       fits_delete         - delete card(s) from header of current HDU
       fits_get            - get value of FITS card(s) in current HDU
       fits_get_bitpix     - get BITPIX value
       fits_get_bscale     - get BSCALE value
       fits_get_bzero      - get BZERO value
       fits_get_cards      - get all cards matching a pattern
       fits_get_comment    - get value(s) of COMMENT card(s)
       fits_get_coordinate - get coordinate information for a given axis
       fits_get_data_size  - get size of data part in current HDU.
       fits_get_dims       - get dimension list of array data
       fits_get_gcount     - get GCOUNT value
       fits_get_history    - get value(s) of HISTORY card(s)
       fits_get_keywords   - get list of defined keywords
       fits_get_list       - get list of integer values
       fits_get_naxis      - get NAXIS value
       fits_get_pcount     - get PCOUNT value
       fits_get_xtension   - get name of FITS primary/extension HDU
       fits_move_card      - move FITS card
       fits_parse          - parse FITS card(s)
       fits_set            - set value of FITS card(s) in current HDU
       fits_set_dims       - set FITS card(s) for dimension list of array

     Reading/writing data (also see binary table routines):
       fits_read           - simple driver to read "IMAGE" or "BINTABLE" data
       fits_write          - simple driver to write "IMAGE" data
       fits_new_image      - creates a new "IMAGE" HDU
       fits_read_array     - read array data from current HDU
       fits_write_array    - write array data in current HDU

     Binary tables:
       fits_new_bintable   - creates a new "BINTABLE" HDU
       fits_read_bintable  - read binary table from current HDU
       fits_write_bintable - write binary table in current HDU
       fits_pack_bintable  - make table columns into a single array

     Expert users routines:
       fits_get_special    - get FITS value of mandatory FITS key
       fits_init           - (re)initialize FITS internals
       fits_id             - get numerical identifier of a single card
       fits_ids            - get numerical identifier of FITS card(s)
       fits_key            - converts numerical identifier into string
       fits_match          - find FITS card(s) which match a pattern
       fits_rehash         - recalculate the numerical identifiers of cards

     Miscellaneous routines:
       fits_best_scale     - compute best BSCALE and BZERO parameters
       fits_bitpix_info    - get description of FITS bits-per-pixel value
       fits_bitpix_of      - compute FITS bits-per-pixel value
       fits_bitpix_type    - convert FITS bits-per-pixel value to data type
       fits_check_bitpix   - test if FITS bits-per-pixel value is valid
       fits_date           - get current time as standard FITS date string
       fits_is_integer     - checks whether argument is integer
       fits_is_integer_scalar - checks whether argument is integer scalar
       fits_is_real_scalar - checks whether argument is real scalar
       fits_is_scalar      - checks whether argument is scalar or not
       fits_is_string_scalar - checks whether argument is scalar string or not
       fits_map            - map scalar function onto array argument
       fits_move           - move element of an array in-place
       fits_nth            - format a string in the form: "1st", "2nd", ...
       fits_tolower        - convert string(s) to lower case letters
       fits_toupper        - convert string(s) to upper case letters
       fits_trim           - removes trailing spaces
       fits_strcmp         - compare strings according to FITS conventions


   CHANGES WITH RESPECT TO "OLD" FITS PACKAGES

     This  package is  intended to  be used  in place  of the  old "fits.i"
     (written by me  and distributed along with Yorick)  which had too many
     limitations and restrictions to allow for further extensions.  However
     the API provided by this novel package is quite different from the old
     one (in particular  the FITS header is no longer  stored into a Yorick
     structure but in some "opaque"  object: a FITS handle).  Hopefully the
     new package provides all the  routines needed to deal with this opaque
     handle but  the name of the  routines (all prefixed  with "fits_") and
     their calling sequences have changed.

     The new FITS interface was written with the aim of being:
       (1) conformable with FITS standards (although try to be not too strict
           when _reading_ files)
       (2) flexible and extensible
       (3) fast (e.g. fits_get takes ~ 150 microseconds for a FITS header
           with 200 cards on an PIII @ 1GHz)


   FITS HANDLE

     In this package, a FITS handle  (denoted FH in the documentation) to a
     FITS file  is intended to  be an "opaque"  object.  Actually, it  is a
     list of 4 items organized as follow:
        _lst(cards, ids, descr, stream)
        cards  = vector of strings which are the header cards of the
                 current HDU;
        ids    = vector of card identifier values (this is for fast search
                 of cards);
        descr  = descriptor, vector of long integers:
                   DESCR(1)= current HDU number (1 for primary HDU);
                   DESCR(2)= file address of the current HDU
                   DESCR(3)= file address of the data part for the current HDU
                   DESCR(4)= file address of the next HDU in read mode,
                             number of written bytes in write mode
                   DESCR(5)= file mode: 'r' (read) or 'w' (write)
        stream = void (no associated file) or stream for input or output;

     Of course the  end-user should never directly access  the items of the
     FITS handle  but rather  use the provided  FITS routines (so  that, in
     order  to  warant portability  of  the user  level  code,  it will  be
     sufficient  to  only modify  routines  in  this  package whenever  the
     internals of the FITS handle change).


   WISH LIST

     The following is a list of missing features or things I would like to
     test:

       1. Implement  support  for  "random groups"  records  (FITS keywords
          GROUPS, PCOUNT  and GCOUNT) and other  "standard" FITS extensions
          (only "IMAGE" and "BINTABLE" are implemented): ASCII table, ...
       2. Extensively test the package (this is mainly because I lack
          of sample FITS files written by other software).
       3. Deal with compressed FITS files; this will be possible thanks to
          the "channel" interface in Yeti (my own extension of Yorick).
       4. Enhance  the consistency  checks  (for instance,  in the  current
          version, you can read/write an "image" into a "table" extension).


   GLOSSARY

     HDU - Header and Data Unit
     Indexed Keyword -


   REFERENCES

     [1] "Definition of Flexible Image Transport System (FITS)", NASA/Science
         Office of Standards and Technology, report NOST 100-1.1, September 29,
         1995.

     [2] "A User's Guide for the Flexible Image Transport System (FITS)"
         http://archive.stsci.edu/fits/users_guide/

*/

/* TO DO LIST:
    - support for strings in fits_write_bintable
    - complex integer
    - ASCII tables
    - free format for real numbers
    - in fits_init: _fits_digitize -> double ?
*/

/*---------------------------------------------------------------------------*/
/* INFORMATION */

func fits_info(fh, hdu)
/* DOCUMENT fits_info, fh;
       -or- fits_info, fh, hdu
       -or- fits_info, filename;
       -or- fits_info, filename, hdu;
     Prints header contents of current HDU in FITS handle FH or all HDU's
     in FITS file FILENAME.  If argument HDU is given, only this header unit
     get printed out (HDU may be an array).

   SEE ALSO: fits, fits_open. */
{
  local cards, offset;
  if (structof(fh) == string) {
    fh = fits_open(fh);
    if (is_void(hdu)) {
      while (_fits_info_worker(fh)) {
        fits_next_hdu, fh;
      }
    } else {
      for (i=1 ; i<=numberof(hdu) ; ++i) {
        _fits_info_worker, fits_goto_hdu(fh, hdu(i));
      }
    }
  } else {
    if (is_void(hdu)) {
      _fits_info_worker, fh;
    } else {
      for (i=1 ; i<=numberof(hdu) ; ++i) {
        _fits_info_worker, fits_goto_hdu(fh, hdu(i));
      }
    }
  }
}

func _fits_info_worker(fh)
{
  local cards; eq_nocopy, cards, _car(fh,1);
  ncards = numberof(cards);
  if (ncards) {
    local offset; eq_nocopy, offset, _car(fh,3);
    write, format="********  HDU - %3d  ***********************************************************\n", offset(1);
    for (i=1; i<=ncards ; ++i) write, format="%s\n", cards(i);
  } else {
    write, format="******** %s ***********************************************************\n", "END OF FILE";
  }
  return ncards;
}


/*---------------------------------------------------------------------------*/
/* SIMPLIFIED DRIVERS */

func fits_read(filename, &fh, encoding=, hdu=, which=, rescale=,
               pack=, select=)
/* DOCUMENT           a = fits_read(filename)
       -or- local fh; a = fits_read(filename, fh)

     Open  FITS file  FILENAME and  read data.   FH is  an  optional output
     symbol where  the FITS handle  will be stored  for future use  such as
     moving  to  a  FITS  extension  in  the  same  file  and  reading  its
     header/data.  (Note:  a FITS handle is  a Yorick list  that contains a
     file  handle and  all header  information from  the current  HDU.)  By
     default, the data get read from  the first HDU but this can be changed
     with the HDU keyword (default  HDU=1, i.e., primary HDU).  If data get
     read  from the  primary  HDU or  a  FITS image  extension, the  result
     returned  by  the  function  fits_read()  is a  numerical  array  (see
     fits_read_array); if the data get  read from a binary table extension,
     the result is a vector of pointers (see fits_read_bintable).

     Keyword ENCODING has the same meaning as in fits_open (which see).

     Keywords WHICH and RESCALE have the same meaning as in fits_read_array
     (which see).  These keywords are ignored if HDU to read is not primary
     HDU nor an "image" extension.

     Keywords   PACK   and   SELECT   have   the   same   meaning   as   in
     fits_read_bintable (which see).


   SEE ALSO: fits, fits_write, fits_open,
             fits_read_array, fits_read_bintable. */
{
  fh = fits_open(filename, 'r', encoding=encoding);
  if (is_void(hdu)) hdu = 1;
  else if (hdu != 1) fits_goto_hdu, fh, hdu;
  if (hdu == 1 || (xtension = fits_get_xtension(fh)) == "IMAGE")
    return fits_read_array(fh, which=which, rescale=rescale);
  if (xtension == "BINTABLE")
    return fits_read_bintable(fh, pack=pack, select=select);
  if (structof(xtension) == string)
    error, "FITS extension \""+xtension+"\" not supported";
  error, "invalid FITS file (missing/bad XTENSION card)";
}

func fits_write(filename, data, encoding=, overwrite=,
                bitpix=, extend=, bscale=, bzero=,
                template=, history=, comment=)
/* DOCUMENT fits_write, filename, data;
       -or- fits_write(filename, data)
     Creates a new FITS file FILENAME  and write array DATA in primary HDU.
     When called  as a function,  the result is  a FITS handle that  can be
     used to append extensions to the file.

     FITS "bits-per-pixel"  can be specified by  keyword BITPIX; otherwise,
     BITPIX   is   automatically   guessed   from  the   data   type   (see
     fits_bitpix_of).

     Keywords  EXTEND, TEMPLATE, HISTORY  COMMENT, BSCALE,  BZERO, ENCODING
     and OVERWRITE have the same meaning as in fits_create (to see).

     If BITPIX is explicitely specified  and corresponds to an integer file
     type (8, 16 or 32) and neither BSCALE nor BZERO are specified, optimal
     BSCALE  and BZERO  values  will be  automatically  computed thanks  to
     fits_best_scale (which see).


   SEE ALSO: fits, fits_best_scale, fits_bitpix_of, fits_create,
             fits_write_header, fits_write_array. */
{
  if (! is_array(data)) error, "non-array data";
  if (is_void(bitpix)) {
    bitpix = fits_bitpix_of(data);
  } else if (bitpix > 0 /* integer file type */
             && is_void(bscale) && is_void(bzero)) {
    scale = fits_best_scale(bitpix, data);
    bscale = scale(1);
    bzero = scale(2);
  }
  fh = fits_create(filename, encoding=encoding, overwrite=overwrite,
                   bitpix=bitpix, bzero=bzero, bscale=bscale,
                   dimlist=dimsof(data), extend=extend,
                   template=template, history=history, comment=comment);
  fits_write_header, fh;
  fits_write_array, fh, data;
  if (am_subroutine()) {
    fits_close, fh;
  } else {
    return fits_pad_hdu(fh);
  }
}

func fits_best_scale(bitpix, cmin, cmax, debug=)
/* DOCUMENT fits_best_scale(bitpix, data)
       -or- fits_best_scale(bitpix, cmin, cmax)
     Returns [BSCALE,BZERO]  where BSCALE and BZERO are  optimal values for
     rescaling to BITPIX  file type.  BITPIX must correspond  to an integer
     type (BITPIX = 8, 16 or 32).  The array DATA contains all the physical
     values  to save to  the file;  alternatively, CMIN  and CMAX  give the
     minimal and maximal values in physical data.

   SEE ALSO: fits, fits_write. */
{
  if (bitpix == 8) {
    fmin = 0;
    fmax = 255;
  } else if (bitpix == 16) {
    fmin = -32768;
    fmax =  32767;
  } else if (bitpix == 32) {
    fmin = -2147483648;
    fmax =  2147483647;
  } else {
    error, "expecting BITPIX for integer file type";
  }
  if (is_void(cmax)) {
    /* CMIN is in fact the data array */
    cmax = max(cmin);
    cmin = min(cmin);
  }
  if (cmin == cmax) {
    return [1.0, cmin];
  }
  bscale = (double(cmax) - double(cmin))/(double(fmax) - double(fmin));
  bzero = floor(((cmin/bscale - fmin) + (cmax/bscale - fmax) + 1.)/2.)*bscale;
  if (debug) {
    if (bzero != (floor(cmin/bscale + 0.5) - fmin)*bscale ||
        bzero != (floor(cmax/bscale + 0.5) - fmax)*bscale) {
      _fits_warn, "rounding error in optimal BSCALE/BZERO";
    }
  }
  return [bscale, bzero];
}

/*---------------------------------------------------------------------------*/

func fits_open(filename, filemode, encoding=, overwrite=)
/* DOCUMENT fits_open(filename)
       -or- fits_open(filename, filemode)
     Opens  the FITS  file FILENAME  according to  FILEMODE.   The returned
     value is a FITS handle used  in most other FITS routines.  FILEMODE is
     one of:
       "r" or 'r' - read mode,  the header of the primary  HDU get read and
                    is parsed.
       "w" or 'w' - write   mode,  new  file  is  created  (unless  keyword
                    OVERWRITE is true, FILENAME must not already exists).
       "a" or 'a' - append  mode, stream  get positionned  at last HDU, the
                    header of the last HDU get read and parsed.
     The default FILEMODE is "r" -- open an existing FITS file for reading.

     Keyword ENCODING can  be used to change the data  encoding of the FITS
     file which is  "xdr" for a regular FITS file  (XDR means eXternal Data
     Representation,  which is  natively  used by  all  IEEE compliant  big
     endian machine).  The value of the keyword is a string like:
       "xdr", "sun"    - eXternal Data Representation (the default)
       "native"        - native data representation (i.e. no conversion)
       "i86", "pc"     - IEEE little endian machines
       ...
     see documentation for "__sun" for  a list of supported encodings. Note
     that  using  an encoding  different  from  IEEE  big endian  (or  XDR)
     violates FITS standard.

     Keyword OVERWRITE can be used to force overwriting of an existing file
     (otherwise it is an error to create a file that already exists).


   SEE ALSO: fits, fits_read_header, fits_write_header,
             fits_get, fits_set, fits_read_array, fits_write_array,
             fits_next_hdu, fits_new_hdu, fits_rewind, __sun. */
{
  /* Open stream. */
  if (is_void(filemode) || filemode == 'r' || filemode == "r") {
    filemode = 'r';
    stream = open(filename, "rb");
  } else if (filemode == 'w' || filemode == "w") {
    filemode = 'w';
    if (! overwrite && open(filename, "r", 1))
      error, "file \""+filename+"\" already exists";
    logfile = filename + "L";
    if (open(logfile, "r", 1)) logfile = string(0);
    stream = open(filename, "wb");
    if (logfile) remove, logfile;
  } else if (filemode == 'a' || filemode == "a") {
    filemode = 'a';
    error, "sorry \"append\" mode not yet implemented";
    stream = open(filename, "ab");
  }

  /* Set data primitives. */
  if (is_void(encoding)) encoding= "xdr";
  if (encoding != "native") {
    set_encoding = symbol_def(encoding+"_primitives");
    if (is_func(set_encoding) != 1) error, "bad encoding \""+encoding+"\"";
    set_encoding, stream;
  }
  save, stream, complex; /* make stream aware of the definition of a complex */

  /* Create handle. */
  fh = _lst([], [], [1, 0, 0, 0, filemode], stream);
  return (filemode == 'r' ? fits_read_header(fh) : fh);
}

/* Function fits_close */

func fits_close(fh, nopad=, last= )
/* DOCUMENT fits_close(fh, nopad=, last= )
     Closes stream in FITS handle  FH.  The header information stored in FH
     remain unchanged  (e.g. you can keep  editing the header  in FH).  The
     returned  value is FH.   Note that  if you  destroy all  references to
     handle FH, the  associated file (if any) gets  automatically closed by
     Yorick.

     Keywords 'nopad' and 'last' added [2008-10-02/NJW]

   SEE ALSO: fits, fits_pad_hdu, fits_open, close. */
{
  local offset; eq_nocopy, offset, _car(fh,3);
  local stream; eq_nocopy, stream, _car(fh,4);
  if (offset(5) == 'w' && !nopad ) {
    /* Pad file up to a multiple of 2880 bytes. */
    fits_pad_hdu, fh, last=last;
  }
  offset(*) = 0;
  if (is_stream(stream)) {
    _car, fh, 4, [];
    close, stream;
  }
  return fh;
}

/* Function fits_create */

func fits_create(filename, encoding=, overwrite=, bitpix=, dimlist=, extend=,
                 template=, history=, comment=, bzero=, bscale=)
/* DOCUMENT fits_create(filename)
     Creates  a new  FITS  file FILENAME  and  returns a  FITS handle  with
     mandatory cards (i.e. SIMPLE, BITPIX, NAXIS, NAXISn) and some optional
     cards (i.e. EXTEND, BSCALE and BZERO) already initialized.

     Keyword  BITPIX can  be  used to  set  FITS "bits-per-pixel"  (default
     is BITPIX=8, i.e. byte data).

     Keyword DIMLIST  should be used to  specify the dimension  list of the
     array data that  is intended to be written in  primary HDU.  The value
     of DIMLIST is similar to the result returned by dimsof.

     Keyword EXTEND can  be used to indicate whether  the file may contains
     FITS extensions.  It is probably a good idea to always use EXTEND=1.

     Keyword TEMPLATE can be set with  an existing FITS handle to copy some
     FITS cards  of the template into  the new header.  The  FITS card that
     are  _never_  copied  are:  "SIMPLE", "XTENSION",  "BITPIX",  "NAXIS",
     "NAXIS#" (with  # an integer),  "BSCALE" and "BZERO"; the  other cards
     get copied.  See keywords BSCALE and BZERO if you specifically want to
     set these values.

     Keywords BSCALE and BZERO can  be used to specify physical value scale
     and offset.   See fits_write_array to figure out  how keywords BITPIX,
     BSCALE and BZERO are used to convert data values into file values.

     Keywords HISTORY  and COMMENT can be  set to add some  comments in the
     new handle.  The values of these keywords may be array of strings.

     Keywords ENCODING and OVERWRITE have the same meaning as in fits_open
     routine (to see).


   SEE ALSO: fits, fits_open, fits_set, fits_set_dims. */
{
  /* Checking. */
  if (am_subroutine()) error, "fits_create must be called as a function";
  if (is_void(bitpix)) {
    bitpix = 8;
  } else if (! fits_is_integer_scalar(bitpix) || ! fits_check_bitpix(bitpix)) {
    error, "bad value for keyword BITPIX";
  }
  if (! is_void(extend)) {
    if (! fits_is_scalar(extend) || ((s = structof(extend)) != long &&
                                     s != int && s != short && s != char))
      error, "keyword EXTEND must be a scalar integer";
    if (s != char) extend = (extend ? 'T' : 'F');
    else if (extend!='T' && extend!='F') error, "bad value for keyword EXTEND";
  }

  /* Some constants. */
  scale_comment = "data_value = BZERO + BSCALE*file_value";

  /* Create new file and set minimal header. */
  fh = fits_open(filename, 'w', encoding=encoding, overwrite=overwrite);
  fits_set, fh, "SIMPLE", 'T',   "true FITS file created by Yorick";
  fits_set, fh, "BITPIX", bitpix, fits_bitpix_info(bitpix);
  fits_set_dims, fh, dimlist;
  if (! is_void(extend)) fits_set, fh, "EXTEND", extend,
                           ("this file "
                            + (extend == 'T' ? "may contain" : "contains no")
                            + " FITS extensions");
  if (! is_void(template)) {
    /* remove cards that we sureley don't want to keep */
    local ids; eq_nocopy, ids, _car(template, 2);
    keep = array(1n, numberof(ids));
    if (is_array((i = where(ids == _fits_id_simple  )))) keep(i) = 0n;
    if (is_array((i = where(ids == _fits_id_xtension)))) keep(i) = 0n;
    if (is_array((i = where(ids == _fits_id_bitpix  )))) keep(i) = 0n;
    if (is_array((i = where(ids == _fits_id_naxis   )))) keep(i) = 0n;
    if (is_array((i = where(ids == _fits_id_end     )))) keep(i) = 0n;
    if (is_void(bscale) &&
        is_array((i = where(ids == _fits_id_bscale  )))) keep(i) = 0n;
    if (is_void(bzero) &&
        is_array((i = where(ids == _fits_id_bzero   )))) keep(i) = 0n;
    if (is_array((i = where(keep)))) {
      /* Make a dummy FITS handle with cards to keep, perform final cleanup
         on this expurged template, then merge with cards of new handle. */
      template = _lst(_car(template, 1)(i), ids(i), [1, 0, 0, 0, 'r'], []);
      fits_delete, template, "NAXIS#";
      if (is_array((i = where(_car(template, 1))))) {
        if (is_array((j = where(_car(fh, 1))))) {
          j = j(where(_car(fh, 2)(j) != _fits_id_end));
        }
        _car, fh, 1, grow([], _car(fh, 1)(j), _car(template, 1)(i));
        _car, fh, 2, grow([], _car(fh, 2)(j), _car(template, 2)(i));
      }
    }
    template = [];
  }
  if (! is_void(bscale)) fits_set, fh, "BSCALE", bscale, scale_comment;
  if (! is_void(bzero)) fits_set, fh, "BZERO", bzero, scale_comment;
  for (i=1 ; i<=numberof(history) ; ++i) fits_set, fh, "HISTORY", history(i);
  for (i=1 ; i<=numberof(comment) ; ++i) fits_set, fh, "COMMENT", comment(i);
  return fh;
}

func fits_check_file(filename, errmode)
/* DOCUMENT fits_check_file(filename)
       -or- fits_check_file(filename, errmode)
     Returns 1/0  depending whether FILENAME is  a valid FITS  file or not.
     If ERRMODE is true (non-nil  and non-zero), unreadable file results in
     false result otherwise it is  a runtime error.  Note that the checking
     is very simple: it is sufficient that the first FITS card in the first
     2880 bytes has keyword "SIMPLE" with logical value 'T' (true).

  SEE ALSO: fits, open. */
{
  stream = open(filename, "rb", (errmode ? 1n : 0n));
  if (! stream) return 0n;
  block_size = sizeof((block = array(char, 80, 36)));
  if (_read(stream, 0, block) != block_size) return 0n;
  digit = _fits_digitize(1 + block(1:8,1));
  if (min(digit) < 0 || min((!digit)(dif)) < 0) return 0n;
  id = sum(_fits_multiplier*digit);
  if (id != _fits_id_simple) return 0n;
  value = fits_parse(string(&block(,1)), id, safe=1);
  if (structof(value) != char) return 0n;
  return (value == 'T');
}

func fits_read_header(fh)
/* DOCUMENT fits_read_header(fh)
     (Re)read  and parse  header of  current  HDU of  FITS handle  FH.
     Contents of FH is updated with  header part of new HDU.  To allow
     for linked calls,  the returned value is FH.   If the current HDU
     is empty (i.e. last HDU in the file), the header will be empty.

   SEE ALSO: fits, fits_open, fits_read_array, fits_next_hdu. */
{
  /* Completely read the header: check that the first card is
     SIMPLE or XTENSION and read FITS blocks until the END card is
     encountered. */
  local offset; eq_nocopy, offset, _car(fh,3);
  if (offset(5) != 'r') error, "FITS file not open for reading";
  unit    = offset(1);
  address = offset(2);
  file    = _car(fh,4);
  block_size = sizeof((block = array(char, 80, 36)));
  nblocks = 0;
  hdr = ids = [];
  for (;;) {
    /* Read next header block. */
    if ((nbytes = _read(file, address, block)) != block_size) {
      if (nbytes == 0 && nblocks == 0) {
        offset(4) = offset(3) = offset(2);
        _car, fh, 1, [];
        _car, fh, 2, [];
        return fh;
      }
      error, "cannot read FITS header or keyword END not found";
    }
    ++nblocks;
    address += block_size;

    /* Get numerical ID's of _all_ cards in the new block (I do not use
       fits_id for efficiency reasons and because any errors will be
       raised later). */
    block_id = _fits_id(block);
    
    /* Pre-search for the END keyword to cleanup header after the END card
       (in case invalid/corrupted FITS cards have been left after this
       card). */
    if (is_array((end_index = where(block_id == _fits_id_end)))) {
      end_index = end_index(1);
      if (end_index < 36) {
        block_id(end_index+1:36) = 0;
      }
    } else {
      end_index = -1;
    }

    /* Check 1st card of 1st header block. */
    if (nblocks == 1) {
      if (block_id(1) < 0.0) error, _fits_bad_keyword(block(1:8, 1));
      id = block_id(1);
      card = string(&block(,1));
      value = fits_parse(card, id, safe=1);
      type = structof(value);
      if (unit == 1) {
        if (id != _fits_id_simple || type != char)
          error, "not a FITS file";
        if (value != 'T') error, "file does not conform to FITS standard";
      } else if (id != _fits_id_xtension || type != string) {
        error, swrite(format="invalid FITS extension (unit=%d)", unit);
      }
    }

    /* Now we can check the validity of FITS keywords. */
    if (min(block_id) < 0.0) {
      /* Bad keyword detected: report first one. */
      error, _fits_bad_keyword(block(1:8, where(block_id < 0.0)(1)));
    }

    /* Search for the END keyword. */
    if (end_index > 0) {
      /* Append last cards and corresponding identifiers, convert
         cards to strings and store things in FITS handle. */
      if (end_index > 1) {
        grow, hdr, block(,:end_index-1);
        grow, ids, block_id(:end_index-1);
      }
      block = [];
      if (is_array((i = where(hdr=='\a')))) {
        /* In scan format strings of the parsing routines, I assume that
           the bell character '\a' is never present in a FITS header.  At
           least this character must therefore always be replaced by a
           space. */
        if (_fits_strict) error, "invalid character '\\a' in FITS header";
        hdr(i) = ' ';
      }
      ncards = numberof(ids);
      cards = array(string, ncards);
      for (i=1 ; i<=ncards ; ++i) cards(i) = string(&(hdr(,i)));
      _car, fh, 1, cards;
      _car, fh, 2, ids;
      break;
    }

    /* Grow the card and numerical identifier arrays. */
    grow, hdr, block;
    grow, ids, block_id;
  }

  /* Get minimum header information (possibly fixing location of cards) and
     update offsets. */
  data_size = fits_get_data_size(fh, 1);
  offset(3) = address; /* address of data in current HDU */
  offset(4) = address + ((data_size + block_size - 1)/block_size)*block_size;

  return fh;
}

func fits_goto_hdu(fh, hdu)
/* DOCUMENT fits_goto_hdu(fh, hdu)
     Move FITS handle FH to Header  Data Unit number HDU (starting at 1 for
     the primary HDU) and parse the  header part of the new unit.  Contents
     of FH  is updated with  header part of  new HDU.  To allow  for linked
     calls, the returned value is FH.

   SEE ALSO: fits, fits_next_hdu, fits_read_header, fits_rewind. */
{
  local offset; eq_nocopy, offset, _car(fh,3);
  if (offset(5) != 'r') error, "FITS file not open for reading";
  while (hdu != offset(1)) {
    if (hdu < offset(1)) {
      if (hdu <= 0) error, "bad HDU number";
      offset(1:4) = 0;
    }
    ++offset(1);
    offset(2) = offset(4);
    fits_read_header, fh;
  }
  return fh;
}

func fits_next_hdu(fh)
/* DOCUMENT fits_next_hdu(fh)
     Move FITS handle FH to next Header Data Unit and parse the header part
     of the  new unit.  Contents of FH  is updated with header  part of new
     HDU.  To allow for linked calls, the returned value is FH.

   SEE ALSO: fits, fits_goto_hdu, fits_read_header, fits_rewind. */
{
  local offset; eq_nocopy, offset, _car(fh,3);
  if (offset(5) != 'r') error, "FITS file not open for reading";
  ++offset(1);
  offset(2) = offset(4);
  return fits_read_header(fh);
}

func fits_rewind(fh)
/* DOCUMENT fits_rewind(fh)
     Move FITS handle FH to primary Header Data Unit and parse the header part
     of the unit.  FH is returned when called as a function.

   SEE ALSO: fits, fits_read_header, fits_next_hdu. */
{
  local offset; eq_nocopy, offset, _car(fh,3);
  if (offset(5) != 'r') error, "FITS file not open for reading";
  if (offset(1) == 1) return fh;
  offset(1) = 1;
  offset(2) = 0;
  return fits_read_header(fh);
}

func fits_eof(fh)
/* DOCUMENT fits_eof(fh)
     Returns non-zero if FITS handle FH is at end of file.

   SEE ALSO: fits, fits_open, fits_next_hdu. */
{
  if (_car(fh,3)(5) != 'r') error, "FITS file not open for reading";
  return is_void(_car(fh, 1));
}

func fits_current_hdu(fh) { return _car(fh,3)(1); }
/* DOCUMENT fits_current_hdu(fh);
     Return number of current Header Data Unit in FITS handle FH.

   SEE ALSO: fits, fits_read_header, fits_rewind, fits_next_hdu. */

func fits_list(fh, key)
/* DOCUMENT fits_list, fh;
       -or- fits_list(fh)
     Get the names of  the FITS extensions in FH.  FH can  be the name of a
     FITS file  or a FITS handle  FH (the input handle  is left unchanged).
     When called  as a  subroutine, the list  is printed to  terminal; when
     called as  a function, the returned  value is a string  array with the
     names of the FITS extensions in FH.

   SEE ALSO: fits, fits_read_header, fits_next_hdu. */
{
  /* Get header of primary HDU. */
  if (structof(fh) == string) {
    /* open FITS file for reading */
    fh = fits_open(fh);
  } else {
    /* make private copy of FITS handle */
    if (typeof(fh) != "list" || _len(fh) != 4) error, "bad FITS handle";
    filemode = _car(fh,3)(5);
    stream = _car(fh,4);
    if (filemode != 'r') error, "FITS file not open for reading";
    fh = fits_read_header(_lst([], [], [1, 0, 0, 0, filemode], stream));
  }
  if (is_void(key)) {
    key = _fits_id_xtension;
  } else if (structof(key) == string) {
    key = fits_id(key);
  }
  if (key == _fits_id_xtension || key == _fits_id_extname) {
    result = "IMAGE";
    fits_next_hdu, fh;
  } else {
    result = [];
  }
  while (! is_void(_car(fh,1))) {
    grow, result, fits_get(fh, key);
    fits_next_hdu, fh;
  }
  if (! am_subroutine()) return result;
  if ((s = structof(result)) == string) {
    f = "\"%s\"";
  } else if (s == char || s == short || s == int || s == long) {
    f = "%d";
  } else if (s == float || s == double) {
    f = "%g";
  } else {
    error, "cannot print \""+typeof(result)+"\" result";
  }
  f = swrite(format="  HDU = %%3d   %s = %s\n", fits_key(key), f);
  write, format=f, indgen(numberof(result)), result;
}

func _fits_warn(msg) { write, format="FITS - WARNING: %s\n", msg; }
/* DOCUMENT _fits_warn, msg;
     Private FITS routine: print out warning message MSG. */

func fits_nth(n)
/* DOCUMENT fits_nth(n)
     Returns a string in the form "1st", "2nd", "3rd" or "#th" where # is
     the human readable value of integer N.

   SEE ALSO: fits, fits_set_dims. */
{
  return (n == 1 ? "1st" :
          (n == 2 ? "2nd" :
           (n == 3 ? "3rd" :
            swrite(format="%dth", n))));
}

func fits_date(nil) { return rdline(popen("date -u +%D",0)); }
/* DOCUMENT fits_date()
     Returns current Universal Time date as a string conforming to FITS
     standard: "DD/MM/YY"

   SEE ALSO: fits, rdline, popen. */

func fits_get_bitpix(fh, fix)
/* DOCUMENT fits_get_bitpix(fh)
       -or- fits_get_bitpix(fh, fix)
     Get  BITPIX   value  from  current   HDU  in  FITS  handle   FH.   See
     fits_get_special for the meaning of FIX.

   SEE ALSO: fits, fits_check_bitpix, fits_get_special,
            fits_get_naxis, fits_get_dims. */
{
  bitpix = fits_get_special(fh, "BITPIX", _fits_id_bitpix, 2, fix);
  if (structof(bitpix)!=long || ! fits_check_bitpix(bitpix))
    error, "bad BITPIX value";
  return bitpix;
}

func fits_get_naxis(fh, fix)
/* DOCUMENT fits_get_naxis(fh)
       -or- fits_get_naxis(fh, fix)
     Get  NAXIS   value  from   current  HDU  in   FITS  handle   FH.   See
     fits_get_special for the meaning of FIX.

   SEE ALSO: fits, fits_get_special, fits_get_bitpix, fits_get_dims. */
{
  naxis = fits_get_special(fh, "NAXIS", _fits_id_naxis, 3, fix);
  if (structof(naxis)!=long || naxis<0) error, "bad NAXIS value";
  return naxis;
}

func fits_get_dims(fh, fix)
/* DOCUMENT fits_get_dims(fh)
       -or- fits_get_dims(fh, fix)
     Get all  NAXIS* values from current  HDU in FITS handle  FH and return
     vector  [NAXIS, NAXIS1,  NAXIS2, ...].   If the  value of  any  of the
     "NAXIS#" card is  zero, then there is no data in  the current unit and
     fits_get_dims returns [] (nil) in this case.  See fits_get_special for
     the meaning of FIX.

   SEE ALSO: fits, fits_get_special, fits_get_bitpix, fits_get_naxis. */
{
  naxis = fits_get_naxis(fh, fix);
  if (! naxis) return;
  dims = array(naxis, naxis+1);
  for (ith=1 ; ith<=naxis ; ++ith) {
    key = swrite(format="NAXIS%d", ith);
    id = fits_id(key);
    value = fits_get_special(fh, key, id, 3+ith, fix);
    if (structof(value) != long || value < 0) error, "bad "+key+" value";
    dims(ith+1) = value;
  }
  if (nallof(dims)) return; /* empty data */
  return dims;
}

func fits_get_xtension(fh)
/* DOCUMENT fits_get_xtension(fh)
     Get XTENSION value from current HDU in FITS handle FH.  The returned
     value is a scalar string in upper case letters with the name of the
     extension (without trailing spaces); "IMAGE" is returned for the
     primary HDU.

   SEE ALSO: fits, fits_get, fits_parse. */
{
  location = 1;
  hdu = _car(fh,3)(1);
  id = _car(fh,2)(location);
  value = fits_parse(_car(fh,1)(location), id);
  if (hdu == 1) {
    if (id == _fits_id_simple && structof(value) == char && value == 'T')
      return "IMAGE";
    error, "not a valid FITS file";
  }
  if (hdu > 1) {
    if (id == _fits_id_xtension && structof(value) == string) {
      return fits_toupper(value);
    }
    error, "bad/missing XTENSION card in FITS header";
  }
  error, "bad unit number in FITS handle";
}

func fits_get_special(fh, key, id, location, fix)
/* DOCUMENT fits_get_special(fh, key, id, location, fix)
     Get  value of  a special  FITS card  given its  key  string, numerical
     identifier and absolute  LOCATION (1 for first FITS  card).  If FIX is
     true,  various further  verifications  are made  and,  if FITS  strict
     checking mode is  off, the header may be fixed  in case of unambiguous
     error.

   SEE ALSO: fits, fits_get_bitpix, fits_get_naxis, fits_get_dims
             fits_parse. */
{
  if (is_void(id)) id = fits_id(key);
  if (fix) {
    if (! is_array((i = where(_car(fh,2) == id))))
      error, key+" card not found in FITS header";
    if (numberof(i) != 1)
      error, "too many "+key+" cards in FITS header";
    i = i(1);
    if (i != location) {
      if (_fits_strict) error, "wrong location of "+key+" card in FITS header";
      fits_move_card, fh, i, location;
    }
  } else if (_car(fh,2)(location) != id) {
    error, key+" card not found in FITS header";
  }
  return fits_parse(_car(fh,1)(location), id);
}

local fits_coordinate;
func fits_get_coordinate(fh, axis, span=)
/* DOCUMENT fits_get_coordinate(fh, axis)
     Gets AXIS-th coordinate information for current HDU in FITS handle FH.
     By  default, the  result  is a  fits_coordinate  structure defined  as
     follows:
       struct fits_coordinate {
         long axis;    // axis number
         long length;  // number of elements along this axis
         string ctype; // name of the coordinate represented by this axis
         double crpix; // location of a reference point (starting at 1)
                       // along this axis
         double crval; // value of the coordinate along this axis at the
                       // reference point
         double cdelt; // partial derivative of the coordinate with respect
                       // to the pixel index along this axis, evaluated at
                       // the reference point
         double crota; // used to indicate a rotation from a standard
                       // coordinate system described by the value of CTYPE
                       // to a different coordinate system in which the
                       // values in the array are actually expressed
       }

     If keyword  SPAN is true, then the  result is a vector  that gives the
     coordinate of each element along given axis:
        CDELT*(indgen(LENGTH) - CRPIX) + CRVAL
     Note that, if the axis length is zero, a nil value is returned.

   SEE ALSO: fits, fits_get, fits_get_dims. */
{
  if (! fits_is_integer_scalar(axis))
    error, "AXIS number must be a scalar integer";
  ith = swrite(format="%d", axis);
  if (structof((length = fits_get(fh, (key = "NAXIS"+ith)))) != long ||
      length < 0) error, ((is_void(length) ? "missing" : "bad value/type for")
                          + " FITS card \"" + key + "\"");
  if (structof((crpix = fits_get(fh, (key = "CRPIX"+ith),
                                 default=1.0))) != double ||
      structof((crval = fits_get(fh, (key = "CRVAL"+ith),
                                 default=1.0))) != double ||
      structof((cdelt = fits_get(fh, (key = "CDELT"+ith),
                                 default=1.0))) != double ||
      structof((crota = fits_get(fh, (key = "CROTA"+ith),
                                 default=0.0))) != double ||
      structof((ctype = fits_get(fh, (key = "CTYPE"+ith),
                                 default=string(0)))) != string)
    error, "bad data type for FITS card \"" + key + "\"";
  if (span) return (length ? cdelt*(indgen(length) - crpix) + crval : []);
  return fits_coordinate(axis=axis, length=length, ctype=ctype,
                         crpix=crpix, crval=crval, cdelt=cdelt, crota=crota);
}
struct fits_coordinate {
  long axis, length;
  string ctype;
  double crpix, crval, cdelt, crota;
}

func fits_get_keywords(fh, ordered)
/* DOCUMENT fits_get_keywords(fh)
       -or- fits_get_keywords(fh, ordered)
     Get list  of FITS keywords defined  in current HDU of  FITS handle HF.
     The returned value is an array of strings. If ORDERED is true (non-nil
     and non-zero),  the keywords get  sorted.  Note: the "END"  keyword is
     always missing in a (non-corrupted) FITS handle.

   SEE ALSO: fits, sort, strtok. */
{
  local cards; eq_nocopy, cards, _car(fh,1);
  if (is_void(cards) || ! is_array((i = where(cards)))) return;
  s = strtok(strpart(cards(i), 1:8))(1,);
  return (ordered ? s(sort(s)) : s);
}

/*---------------------------------------------------------------------------*/
/* EDITION OF HEADER */

func fits_move_card(fh, from, to)
/* DOCUMENT fits_move_card(fh, from, to);
     Change location of FROM-th card to  index TO into FITS handle FH.  The
     operation is made in place.

   SEE ALSO: fits, fits_move. */
{
  fits_move, _car(fh,1), from, to;
  fits_move, _car(fh,2), from, to;
}

func fits_move(a, i, j)
/* DOCUMENT fits_move, a, i, j;
     Move I-th element of array A  in place of J-th element.  The operation
     is done in-place.

   SEE ALSO: fits, fits_move_card. */
{
#if 0
  n = numberof(a);
  if (i <= 0) i += n;
  if (j <= 0) j += n;
#endif
  if (i < j) {
    t = a(i);
    a(i:j-1) = a(i+1:j);
    a(j) = t;
  } else if (i > j) {
    t = a(i);
    a(j+1:i) = a(j:i-1);
    a(j) = t;
  }
}

func fits_write_header(fh)
/* DOCUMENT fits_write_header(fh)
     Write  header  information of  FITS  handle  FH  into current  HDU  of
     associated file.   It is possible to  re-write header as  long as this
     would not overwrite existing written data if any (i.e. the new header,
     rounded up  to a multiple of 2880  bytes, must not be  longer than the
     old one or there must be no data written.

   SEE ALSO: fits, fits_open, fits_write, fits_write_array. */
{
  local cards, ids; _fits_get_cards, fh, cards, ids;
  local offset; eq_nocopy, offset, _car(fh, 3);
  stream = _car(fh, 4);
  if (offset(5) != 'w' /* FIXME: && offset(5) != 'a' */)
    error, "FITS file not open for writing/appending";

  /* Locate last FITS card. */
  if (is_array((i = where(ids == _fits_id_end)))) {
    /* keyword "END" already in header */
    last = i(1);
  } else {
    /* "END" card will be appended automatically */
    i = where(cards);
    last = (is_array(i) ? i(0) : 0) + 1;
  }

  /* Compute number of header cards to write. */
  no_data = (offset(4) <= offset(3));
  if (no_data) {
    /* Round up the number of cards to write to a multiple of 36. */
    ncards = ((last + 35)/36)*36;
  } else {
    /* Data already written in file.  Check that writing header will not
       overwrite any data. */
    nbytes = offset(3) - offset(2); /* size of written header */
    if (nbytes % 2880) error, "##1## corrupted FITS handle";
    if (nbytes < last*80)
      error, "overwriting current header would overwrite data";
    ncards = nbytes/80;
  }

  /* Convert textual header to bytes. */
  hdr = array(' ', 80, ncards);
  for (k=1 ; k<last ; ++k) {
    s = cards(k);
    if ((l = strlen(s)) >= 1) {
      rng = 1:min(l, 80);
      hdr(rng, k) = (*pointer(s))(rng);
    }
  }
  hdr(1, last) = 'E';
  hdr(2, last) = 'N';
  hdr(3, last) = 'D';

  /* Write header and update offset information. */
  address = offset(2);
  _write, stream, address, hdr;
  offset(3) = address + sizeof(hdr);
  if (no_data) offset(4) = offset(3);
  return fh;
}

//func _fits_check_offset(offset)
//{
//  n1 = offset(3) - offset(2);
//  n2 = offset(4) - offset(3);
//  if (n1 < 0 || n1 % 2880 || n2 < 0 || n2 % 2880)
//    error, "corrupted FITS handle";
//  return [n1, n2];
//}

func fits_get_data_size(fh, fix)
/* DOCUMENT fits_get_data_size(fh)
       -or- fits_get_data_size(fh, fix)
     Computes  the number  of bytes  in data  part of  current HDU  of FITS
     handle FH.  This value is computed  according to the header part of FH
     and may be different from the  number of bytes actually written in the
     data part of the current HDU.

   SEE ALSO: fits, fits_read_header. */
{
  bitpix = fits_get_bitpix(fh, fix);
  dims   = fits_get_dims(fh, fix);
  gcount = fits_get_gcount(fh);
  pcount = fits_get_pcount(fh);
  if (is_void(dims)) {
    naxis = 0;
    ndata = 0;
  } else {
    naxis = dims(1);
    i = numberof(dims);
    ndata = 1;
    while (i > 1) ndata *= dims(i--);
  }
  return (abs(bitpix)/8)*gcount*(pcount + ndata);
}

/* Function fits_pad */

/*             input              output
 * offset(1) = HDU                (unchanged)
 * offset(2) = header offset      (unchanged)
 * offset(3) = data offset        (unchanged)
 * offset(4) = file size          next header offset
 * offset(5) = file mode          (unchanged)
 */
func fits_pad_hdu(fh, last= )
/* DOCUMENT fits_pad_hdu(fh, last= )

     Fix file size in handle FH to a multiple of FITS blocking factor (2880
     bytes) by writting null or space characters at the end of the file and
     update FH offsets accordingly.  FH must be open for writing.

     Keyword last: latest address written to file. If set then some testing
        is skipped.  [Added 2008-10-02/NJW]

   SEE ALSO: fits, fits_close, fits_new_hdu. */
{
  /* Check offsets and sizes of header and data parts. */
  local offset; eq_nocopy, offset, _car(fh, 3);
  if (offset(5) != 'w') error, "FITS file not open for writing";

  BLOCKSIZE = 2880; /* FITS blocking factor */

  if( last ) {
     file_size = last;
  } else { // usual routine
     if (min(offset) < 0 || (header_offset = offset(2)) % BLOCKSIZE ||
         (data_offset = offset(3)) % BLOCKSIZE ||
         (file_size = offset(4)) < data_offset || data_offset < header_offset) {
       error, "##2## corrupted FITS handle";
     }
     if (data_offset <= header_offset) {
       error, "no header written";
     }
     if (file_size - data_offset < fits_get_data_size(fh)) {
       error, "no data written or short data part";
     }
  }

  /* Possibly pad file with null bytes or spaces. */
  rounded_size = ((file_size + BLOCKSIZE - 1)/BLOCKSIZE)*BLOCKSIZE;
  if (rounded_size > file_size) {
   /* Adhoc change for fits_bintable_poke [2008-10-03/NJW]
    *   pad = char((fits_get_xtension(fh) == "TABLE" ? ' ' : 0));
    */
    pad = char(0);
    _write, _car(fh, 4), file_size, array(pad, rounded_size - file_size);
    offset(4) = rounded_size; /* update file size */
  }
  return fh;
}

/* Function fits_new_hdu */

func fits_new_hdu(fh, xtension, comment)
/* DOCUMENT fits_new_hdu(fh, xtension)
       -or- fits_new_hdu(fh, xtension, comment)
     Starts a new extension in FITS  file open for writing.  FH is the FITS
     handle, XTENSION is  the name of the FITS extension  and COMMENT is an
     optional string comment.  After calling fits_new_hdu, there is no need
     to call:

       fits_set, FH, "XTENSION", XTENSION, COMMENT;

     since this is already done by this routine.  However, beware that FITS
     standard requires that, if any  extension is present in the file, that
     the keyword "EXTEND" with logical  value 'T' (true) must appear in the
     primary header.


   SEE ALSO: fits, fits_pad_hdu, fits_set,
             fits_write_header, fits_write_array. */
{
  /* Minimal check to avoid errors which would left a
     corrupted handle after the final fits_set. */
  if (! fits_is_string_scalar(xtension)) {
    error, "extension must be a scalar string";
  }
  if (! is_void(comment) && ! fits_is_string_scalar(comment)) {
    error, "comment must be nil or a scalar string";
  }

  local offset;
  fits_pad_hdu, fh; /* round up file size and clash if invalid mode */
  eq_nocopy, offset, _car(fh, 3);
  if (offset(1) == 1 && fits_get(fh, "EXTEND", default='F') != 'T')
    error, "primary header must set EXTEND='T' to allow for extensions";
  offset(2) = offset(3) = offset(4); /* update file offsets */
  ++offset(1); /* increment HDU number */
  _car, fh, 1, []; /* clear cards */
  _car, fh, 2, []; /* clear keys */
  return fits_set(fh, "XTENSION", xtension, comment);
}

/*---------------------------------------------------------------------------*/
/* SETTING VALUE OF FITS CARDS */

func fits_set(fh, key, value, comment)
/* DOCUMENT fits_set, fh, key, value;
       -or- fits_set, fh, key, value, comment;
     Set (or adds) FITS card in header  of FITS handle FH.  KEY is the card
     name (FITS keyword)  and must be a scalar string,  VALUE is the scalar
     value of the card and COMMENT is an optional string comment.

     Commentary cards -- for which KEY  is one of "COMMENT, "HISTORY" or ""
     (blank) -- get appended to the  existing cards in the header of FH (if
     the VALUE of a commentary card is too long, it may occupy several FITS
     cards).   For any  other  kind of  cards,  the new  card replaces  the
     existing one, if any; or  get appended to the existing cards.  Special
     cards that must appear in a precise order ("SIMPLE", "BITPIX", "NAXIS"
     and "NAXIS#") must  be added in the correct order  (their value can be
     modified afterward).  The "END"  card is not  needed since it  will be
     automatically written when required.


   SEE ALSO: fits, fits_open. */
{
  /* Fix FITS card name and get its numerical identifier. */
  if (! fits_is_string_scalar(key)) error, "expecting a scalar string for KEY";
  key = _fits_key((id = fits_id(key)));

  /* Check other arguments. */
  s = structof(value);
  if (s == string) {
    op = _fits_format_string;
  } else if (s == long || s == int || s == short) {
    op = _fits_format_integer;
  } else if (s == double || s == float) {
    op = _fits_format_real;
  } else if (s == complex) {
    op = _fits_format_complex;
  } else if (s == char) {
    if (dimsof(value)(1) || (value != 'T' && value != 'F'))
      error, "FITS logical value for card \""+key+"\" must be 'T' or 'F'";
    op = _fits_format_logical;
  } else {
    /* Do nothing for "END" card. */
    if (is_void(value) && id == _fits_id_end) {
      if (is_void(comment)) return fh;
      error, "FITS \"END\" card takes no value nor comments";
    }
    error, "unsupported type \""+typeof(value)+"\" for FITS card \""+key+"\"";
  }
  if (! fits_is_scalar(value)) error, "expecting a scalar VALUE";
  if (! is_void(comment) && ! fits_is_string_scalar(comment))
    error, "optional COMMENT must be a scalar string";

  /* Format card and figure out its location (LOCATION > 0 for cards that
     must be at a given position, LOCATION = -1 for commentary cards and
     LOCATION = 0 for other cards). */
  errfmt = "invalid value/type for FITS card \"%s\"";
  if (anyof(id == _fits_id_special)) {
    /* Deal with special keywords. */
    if (id == _fits_id_simple) {
      if (op != _fits_format_logical) error, swrite(format=errfmt, key);
      location = 1;
    } else if (id == _fits_id_xtension) {
      if (op != _fits_format_string) error, swrite(format=errfmt, key);
      location = 1;
    } else if (id == _fits_id_bitpix) {
      if (op != _fits_format_integer || ! fits_check_bitpix(value))
        error, swrite(format=errfmt, key);
      location = 2;
    } else if (id == _fits_id_naxis) {
      if (op != _fits_format_integer || value < 0)
        error, swrite(format=errfmt, key);
      location = 3;
    } else if (id == _fits_id_comment || id == _fits_id_history || id == 0.0) {
      if (! is_void(comment))
        error, "too many arguments for commentary FITS card";
      if (op != _fits_format_string) error, swrite(format=errfmt, key);
      op = _fits_format_comment;
      location = -1; /* append after last valid card */
    } else {
      /* Must be "END" keyword (which is already checked above so it must
         be an error here). */
      error, "FITS \""+key+"\" card takes no value nor comments";
    }
  } else {
    location = 0;
    if (strpart(key, 1:5) == "NAXIS") {
      n = 0;
      s = string(0);
      if (sread(key, format="NAXIS%d%s", n, s) == 1 && n >= 1) {
        if (op != _fits_format_integer || value < 0)
          error, swrite(format=errfmt, key);
        location = 3 + n;
      }
    }
  }
  card = op(key, value, comment);

  /* Get card(s) and numerical identifiers in header. */
  local cards, ids;
  ncards = _fits_get_cards(fh, cards, ids);

  /* Maybe replace existing FITS card. */
  if (location >= 0 && ncards) {
    if (location > 0) {
      if (location <= ncards && ids(location) == id) {
        cards(location) = card;
        return fh;
      }
    } else if (is_array((i = where(ids == id)))) {
      cards(i(1)) = card;
      return fh;
    }
  }

  /* At this point we have to append the card(s) after the last one. */
  n = numberof(card);
  nfree = (ncards ? numberof((i = where(! cards))) : 0);
  if (nfree < n) {
    /* round up the new number of cards to a multiple of 36 cards */
    new = ((ncards + n - nfree + 35)/36)*36 - ncards;
    _, cards, array(string, new); _car, fh, 1, cards;
    _,   ids, array(-1.0,   new); _car, fh, 2,   ids;
    i = where(! cards);
  }
  j = i((n > 1 ? indgen(n) : 1));
  if (location > 0 && location != j) {
    error, swrite(format="FITS card \"%s\" must be written at index %d",
                  key, location);
  }
  cards(j) = card;
  ids(j) = id;
  return fh;
}

func _fits_get_cards(fh, &cards, &ids)
/* DOCUMENT _fits_get_cards(fh, cards, ids)
     Stores  in  variables CARDS  and  IDS  the  FITS cards  and  numerical
     identifiers from header in FITS  handle FH.  The returned value is the
     number of FITS cards (including empty ones).

   SEE ALSO: fits, fits_set. */
{
  eq_nocopy, cards, _car(fh, 1);
  eq_nocopy,   ids, _car(fh, 2);
  if ((ncards = numberof(cards)) != numberof(ids)) {
    _fits_warn, "##3## corrupted FITS handle, trying to fix it...";
    fits_rehash, fh;
    eq_nocopy,   ids, _car(fh, 2);
  }
  return ncards;
}

/* FITS card format:
 *       bytes   description
 *      ------   ------------------------------------------------------------
 *        1:8  = keyword
 *        9:10 = value indicator "= "
 *       11:80 = value / comment
 *
 * STRING value format:
 *       bytes   description
 *      ------   ------------------------------------------------------------
 *          11 = ' (quote)
 *    11+(1:N) = string value, 8<=N<=68 (with quotes doubled, and padded with
 *               spaces to have N>=8, trailing spaces are not significant,
 *               leading spaces are significant)
 *        12+N = ' (quote)
 *
 * LOGICAL value format:
 *       bytes   description
 *      ------   ------------------------------------------------------------
 *       11:29 = spaces
 *          30 = T or F
 */

func _fits_format_logical(key, value, comment)
/* DOCUMENT _fits_format_logical(key, value)
       -or- _fits_format_logical(key, value, comment)
     Private  routine to format  FITS logical  card, return  a 80-character
     string.

   SEE ALSO: fits, fits_set. */
{
  if (value=='T') value= "T";
  else if (value=='F') value= "F";
  else error, "invalid logical value for FITS card \""+key+"\"";
  return strpart(swrite(format="%-8s= %20s / %-47s",
                        key, value, (is_void(comment)?"":comment)), 1:80);
}

func _fits_format_integer(key, value, comment)
/* DOCUMENT _fits_format_integer(key, value)
       -or- _fits_format_integer(key, value, comment)
     Private routine to format FITS integer card, return a 80-character
     string.

   SEE ALSO: fits, fits_set. */
{
  return strpart(swrite(format="%-8s= %20d / %-47s",
                        key, value, (is_void(comment)?"":comment)), 1:80);
}

func _fits_format_real(key, value, comment)
/* DOCUMENT _fits_format_real(key, value)
       -or- _fits_format_real(key, value, comment)
     Private routine to format FITS real card, return a 80-character
     string.

     Note: FITS standard imposes that the ASCII representation of a real
           number makes 20 characters;  the full precision of 64-bit values
           can not be represented with this restriction.

   SEE ALSO: fits, fits_set. */
{
  /* With exponential representation, the maximum number of significant digit
     is LEN-7=13 hence the %20.12E format */
  return strpart(swrite(format="%-8s= %20.12E / %-47s",
                        key, value, (is_void(comment)?"":comment)), 1:80);
}

func _fits_format_complex(key, value, comment)
/* DOCUMENT _fits_format_complex(key, value)
       -or- _fits_format_complex(key, value, comment)
     Private routine to format FITS complex card, return a 80-character
     string.

   SEE ALSO: fits, fits_set. */
{
  return strpart(swrite(format="%-8s= %20.12E%20.12E / %-27s",
                        key, value.re, value.im,
                        (is_void(comment)?"":comment)), 1:80);
}

func _fits_format_string(key, value, comment)
/* DOCUMENT _fits_format_string(key, value)
       -or- _fits_format_string(key, value, comment)
     Private routine to format FITS string card, return a 80-character
     string.

     Note: enclose input string in quotes, replacing each quote in input
           string by 2 quotes.  Since opening quote should appear in
           column 11 and closing quote in columns 20 to 80 of the FITS
           card, make sure that string is not longer than 68 characters
           (too long strings get silently truncated).

   SEE ALSO: fits, fits_set. */
{

  /* Replace every quote character (ASCII 0x27) in VALUE by two quotes and
     make sure the result is not longer than 68 characters. */
  len = strlen(value);
  src = *pointer(value);
  dst = array(char, 2*len + 1);
  i = j = 0;
  n = min(34, len);
  while (i < n) {
    /* faster loop: no need to check length of result */
    if ((c = src(++i)) == '\'') dst(++j) = '\'';
    dst(++j) = c;
  }
  while (i < len) {
    /* slower loop: need to check length of result */
    if ((c = src(++i)) == '\'') {
      if (j >= 67) break;
      dst(++j) = '\'';
    } else if (j >= 68) break;
    dst(++j) = c;
  }
  value = swrite(format="'%-8s'", string(&dst));
  return strpart(swrite(format="%-8s= %-20s / %-47s",
                        key, value, (is_void(comment)?"":comment)), 1:80);
}

func _fits_format_comment(key, text, unused)
/* DOCUMENT _fits_format_comment(key)
       -or- _fits_format_comment(key, text)
     Private routine  to format  FITS commentary card,  return an  array of
     80-character string(s).   Text comment, if longer  than 72 characters,
     will result in more than one comment cards.

   SEE ALSO: fits, fits_set. */
{
  len = strlen(text);
  if (len <= 72) {
    if (! len) return swrite(format="%-80s", key);
    return swrite(format="%-8s%-72s", key, text);
  }
  n = (len + 71)/72;
  card = array(string, n);
  text += swrite(format="%71s", "");
  for (i=1, j=1 ; i<=n ; ++i, j+=72) card(i) = strpart(text, j:j+71);
  return swrite(format="%-8s", key)+card;
}

/*---------------------------------------------------------------------------*/
/* IMAGE/ARRAY DATA */

func fits_read_array(fh, which=, rescale=)
/* DOCUMENT fits_read_array(fh)
     Gets "image" (actually a Yorick array) from current HDU of FITS handle
     FH.  Note that the result may be [] (nil) if the current unit contains
     no data.

     Keyword  WHICH may  be  used  to indicate  which  sub-array should  be
     returned.  WHICH always  applies to the last dimension  of the "image"
     data  stored in current  HDU.  For  instance, if  the array  DATA with
     dimensions  (235,453,7)  is  stored  in  the  current  FITS  HDU,  the
     sub-array DATA(,,4) can be obtained by:

         fits_read_array(FH, which=4);

     If keyword RESCALE is true,  returned values get rescaled according to
     FITS keywords BSCALE and BZERO.  If RESCALE=2 and one of BSCALE and/or
     BZERO exists in  the FITS header and  BITPIX was 8, 16, 32,  or -32, a
     single precision  array (float)  is returned.  If  RESCALE is  not set
     (nil), the  default is to  rescale data values  if BSCALE is not  1 or
     BZERO is not  0 (i.e. the default is RESCALE=1).  In  order to get raw
     data (i.e. as written in the file), use RESCALE=0.

   SEE ALSO: fits, fits_open. */
{
  local offset; eq_nocopy, offset, _car(fh,3);
  if (offset(5) != 'r') error, "FITS file not open for reading";
  dims = fits_get_dims(fh, 1);
  if (is_void(dims)) return; /* no data */
  if (is_void(which)) {
    which = 0;
  } else {
    if (! fits_is_integer_scalar(which))
      error, "WHICH must be a scalar integer";
    last = dims(0);
    if (which <= 0)
      which += last;
    if (which > last || which < 1)
      error, "WHICH out of range";
    dims = dims(:-1);
    dims(1) -= 1;
  }
  bitpix = fits_get_bitpix(fh, 1);
  if (bitpix == 8) {
    data_type = char;
    data_size = 1;
  } else if (bitpix == 16) {
    data_type = short;
    data_size = 2;
  } else if (bitpix == 32) {
    data_type = long;
    data_size = 4;
  } else if (bitpix == -32) {
    data_type = float;
    data_size = 4;
  } else if (bitpix == -64) {
    data_type = double;
    data_size = 8;
  } else {
    error, "congratulations: you have found a BUG!";
  }
  data = array(data_type, dims);
  address = offset(3);
  if (which > 1) address += (which - 1)*numberof(data)*data_size;
  if (_read(_car(fh,4), address, data) != numberof(data))
    error, "cannot read data";

  /* Possibly rescale pixel values. */
  if (is_void(rescale) || rescale) {
    if ((bscale = fits_get_bscale(fh)) != 1.0) data *= bscale;
    if ((bzero  = fits_get_bzero(fh)) != 0.0) data += bzero;
    if (rescale == 2 && abs(bitpix) <= 32 && structof(data) == double) {
      return float(data);
    }
  }
  return data;
}

func fits_write_array(fh, data, which=, rescale=)
/* DOCUMENT fits_write_array, fh, data;
     Write  array DATA  into  curent HDU  of  FITS handle  FH.   DATA is  a
     so-called "image"  in FITS jargon but  it can be a  numerical array of
     any-dimension.   FITS cards BITPIX,  BSCALE and  BZERO are  taken into
     account to convert data values into file values.  The file values are:

         (DATA  - BZERO)/BSCALE

     with BZERO=0 and  BSCALE=1 by default (i.e. if not found  in FH) or if
     keyword RESCALE  is explicitely set  to zero.  The values  are further
     subject to rounding  to the nearest integer and  clipping for positive
     BITPIX.  If  keyword RESCALE is  explicitely set to false  (zero), the
     file values get written without BSCALE/BZERO scale conversion.

     The N dimensions of DATA must  match the values of the NAXIS1, NAXIS2,
     ..., NAXISn  cards of  the FITS  file (it is  assumed that  the header
     information  stored in  FH  are synchronized  to  the header  actually
     written) extra dimensions in the  FITS file are considered as possible
     data slices.  By  default, the first data slice  get written.  Keyword
     WHICH may be used to write a given slice of data.  The value WHICH may
     be less or equal zero to choose  a slice with respect to the last one.

  EXAMPLE:
     The following  example creates a FITS file  with a 100-by-45-by-4-by-7
     "image" data made of random  values computed and written one 100-by-45
     slice at a time:

       fh = fits_create("newfile.fits", bitpix=16, dimlist=[4,100,45,4,7],
                        bscale=1e-4, bzero=0.0);
       fits_write_header, fh;
       nslices = 4*7; // product of last FITS dimensions
       for (i=1 ; i<=nslices ; ++i)
         fits_write_array, fh, random(100, 45), which=i;
       fits_close, fh;


   SEE ALSO: fits, fits_write, fits_write_header. */
{
  local offset; eq_nocopy, offset, _car(fh, 3);
  stream = _car(fh, 4);
  if (offset(5) != 'w' && offset(5) != 'a')
    error, "FITS file not open for writing/appending";
  if ((n1 = offset(3) - offset(2)) < 0 || n1 % 2880 ||
      (n2 = offset(4) - offset(3)) < 0) error, "corrupted FITS handle";
  if (n1 == 0) error, "no header written";

  /* Check data type and dimension list. */
  data_type = structof(data);
  if (data_type != char && data_type != short && data_type != int &&
      data_type != long && data_type != float && data_type != double) {
    error, "bad data type for FITS array";
  }
  file_dims = fits_get_dims(fh);
  data_dims = dimsof(data);
  file_ndims = file_dims(1);
  data_ndims = data_dims(1);
  if (data_ndims > file_ndims) error, "too many dimensions in DATA";
  for (i=1 ; i<=data_ndims ; ++i) {
    if (data_dims(i+1) != file_dims(i+1))
      error, fits_nth(i)+" dimension of data does not match that of FITS file";
  }
  nslices = 1;
  for (i=data_ndims+1 ; i<=file_ndims ; ++i) nslices *= file_dims(i+1);
  if (is_void(which)) {
    which = 1;
  } else {
    if (! fits_is_integer_scalar(which)) error, "WHICH must be integer scalar";
    if (which <= 0) which += nslices;
    if (which <= 0 || which > nslices) error, "bad value for WHICH";
  }

  /* Convert data according to BITPIX, BSCALE and BZERO. */
  if (is_void((bitpix = fits_get_bitpix(fh))))
    error, "missing BITPIX card in FITS header";
  if (is_void(rescale) || rescale) {
    if ((bzero = fits_get_bzero(fh)) != 0.0) data -= double(bzero);
    if ((bscale = fits_get_bscale(fh)) != 1.0) data *= 1.0/bscale;
    data_type = structof(data); /* may have changed because of BSCALE/BZERO */
  }
  if (bitpix > 0) {
    /* Integer type. */
    if (data_type == double || data_type == float) {
      /* round to nearest integer */
      data = floor(data + 0.5);
      data_type = structof(data); /* should be "double" now */
    }
    if (bitpix == 8) {
      file_type = char;
      file_min = 0;
      file_max = 255;
    } else if (bitpix == 16) {
      file_type = short;
      file_min = -32768;
      file_max =  32767;
    } else if (bitpix == 32) {
      file_type = long;
      file_min = -2147483648;
      file_max =  2147483647;
    } else {
      error, "bad BITPIX value in FITS header";
    }
    if (file_type != data_type) {
      if (min(data) < file_min || max(data) > file_max) {
        _fits_warn, "truncating data values outside range allowed by BITPIX";
        data = file_type(min(max(data, file_type(file_min)),
                             file_type(file_max)));
      } else {
        data = file_type(data);
      }
    }
  } else {
    /* Floating point type. */
    if (bitpix == -32) {
      if (data_type != float) data = float(data);
    } else if (bitpix == -64) {
      if (data_type != double) data = double(data);
    } else {
      error, "bad BITPIX value in FITS header";
    }
  }

  /* Write data and update offsets (note: the padding to a multiple of 2880
     bytes will be done when creating next HDU with fits_new_hdu). */
  data_size = sizeof(data);
  address = offset(3);
  if (which != 1) {
    address += (which - 1)*data_size;
    if (address > offset(4)) /* pad file with null's */
      _write, stream, offset(4), array(char, address - offset(4));
  }
  _write, stream, address, data;
  offset(4) = max(offset(4), address + data_size);
  return fh;
}

func fits_set_dims(fh, dimlist)
/* DOCUMENT fits_set_dims(fh, dimlist)
      Set NAXIS  and NAXIS1,  NAXIS2, ... values  into current HDU  of FITS
      handle FH according to dimension list DIMLIST.  DIMLIST may be empty.

   SEE ALSO: fits, fits_get_dims. */
{
  if (is_void(dimlist)) {
    fits_set, fh, "NAXIS", 0, "this HDU contains no data";
  } else {
    if ((s = structof(dimlist)) != long && s != int && s != short && s != char)
      error, "non-integer data type for DIMLIST";
    n = dimsof(dimlist)(1);
    if (n == 0) {
      naxis = 1;
    } else if (n == 1 && allof(dimlist >= 1) &&
               (naxis = dimlist(1)) == numberof(dimlist) - 1) {
      dimlist = dimlist(2:);
    } else {
      error, "bad dimension list DIMLIST";
    }
    fits_set, fh, "NAXIS", naxis, "number of dimensions";
    for (k=1 ; k<=naxis ; ++k) {
      fits_set, fh, swrite(format="NAXIS%d", k), dimlist(k),
        "length of " + fits_nth(k) + " dimension";
    }
  }
  return fh;
}

func fits_new_image(fh, data, bitpix=, dimlist=, bzero=, bscale=)
/* DOCUMENT fits_new_image(fh, data)
       -or- fits_new_image(fh, bitpix=..., dimlist=...)
     Starts a new image (array) FITS extension in handle FH and returns FH.
     This routine starts a new FITS extension with name "IMAGE" and pre-set
     FITS cards  needed to describe  the array data according  to keywords:
     BITPIX, DIMLIST, BZERO, and BSCALE.   If argument DATA is given, it is
     used  to guess  the  bits per  pixel  and the  dimension  list if  not
     specified by the keywords BITPIX and DIMSLIST respectively.

   SEE ALSO: fits, fits_write_array. */
{
  fits_new_hdu, fh, "IMAGE", "this HDU contains FITS image extension";
  if (! is_void(data)) {
    if (is_void(bitpix)) bitpix = fits_bitpix_of(data);
    if (is_void(dimlist)) dimlist = dimsof(data);
  }
  fits_set, fh, "BITPIX", bitpix, fits_bitpix_info(bitpix);
  fits_set_dims, fh, dimlist;
  if (! is_void(bzero)) fits_set, fh, "BZERO", bzero,
                          "data_value = BZERO + BSCALE*file_value";
  if (! is_void(bscale)) fits_set, fh, "BSCALE", bscale,
                           "data_value = BZERO + BSCALE*file_value";
  return fh;
}

/*---------------------------------------------------------------------------*/
/* BINARY TABLE */

func fits_new_bintable(fh, comment)
/* DOCUMENT fits_new_bintable(fh)
       -or- fits_new_bintable(fh, comment)

     Starts a new  binary table FITS extension.  This  routine starts a new
     FITS extension with  name "BINTABLE" and pre-set FITS  cards needed to
     describe the  table with fake values  (the correct values  will be set
     when  fits_write_bintable  is called  to  actually  write the  table).
     After calling this  routine, the user can add new  FITS cards (but not
     XTENSION,  BITPIX,   NAXIS,  NAXIS1,  NAXIS2,   GCOUNT,  nor  PCOUNT).
     Optional argument COMMENT is the comment string for the XTENSION card.

     The returned value is FH.

   SEE ALSO: fits, fits_write_bintable. */
{
  fits_new_hdu, fh, "BINTABLE",
    (is_void(comment) ? "this HDU contains FITS binary table extension"
                      : comment);
  _fits_bintable_header, fh, 0, 0, 0;
  return fh;
}

/* Function fits_write_bintable */

func fits_write_bintable(fh, ptr, logical=, var=, stype= )
/* DOCUMENT fits_write_bintable(fh, ptr)
     Writes contents  of pointer PTR in  a binary table in  FITS handle FH.
     Arrays pointed  by PTR  become the  fields of the  table (in  the same
     order as  in PTR) and must  all have 1  or 2 dimensions with  the same
     first  dimension  (i.e. the  number  of  rows  in the  table),  second
     dimensions can have any values and may all be different: they count as
     the number of 'columns' of the field.  In other words:

       *PTR(i) = i-th  field  in the table,  is an  NROWS-by-NCOLS(i) array
                 where  NROWS  is the  number  of  rows  in the  table  and
                 NCOLS(i) is  the repeat  count of the  i-th field;  it can
                 also be simply a NROWS element vector if NCOLS(i) = 1.

     The current version supports writing a variable length vector column
     indicated by the keyword 'var' that must be set to the column number.
     When 'var' is set then 'stype' must also be set holding a character
     as one of 'I', 'J', 'E', or 'D' to define the data type of the
     column in question. Also ptr(var) must point to a 2 x nrows array of
     zeros of type long.
     Only writing of the ordinary columns will be performed. The variable
     length column data must be written using a number of calls of the
     function fits_bintable_poke.

     In the current  version of the routine, only  arrays of numbers (char,
     short, int,  long, float,  double or complex)  and vectors  of strings
     (you  can  use several  vectors  to  circumvent  this limitation)  are
     supported.  Before writing  the data part of a  binary table, you must
     creates proper header:

        fits_new_bintable, fh;        // starts a new binary table
        fits_set, fh, "...", ...;     // (optional) set more info. in header
        fits_set, ...;
        fits_write_bintable, fh, ptr; // write binary table

     If  FITS cards "TFORM#"  (with #  equal to  the field  number) already
     exists   in  the  current   header,  fits_write_bintable   checks  the
     consistency of the  corresponding data field in PTR  (and performs any
     required conversion);  otherwise, the format  is automatically guessed
     and set accordingly in the header of the binary table.

     If keyword LOGICAL is true (non nil and non-zero) then arrays of int's
     in  PTR  are considered  as  logical arrays  and  saved  as arrays  of
     characters: 'F' for false, 'T' for true or '\0' for bad/invalid value.
     Following Yorick's convention, a "false"  value is integer zero in the
     arrays of  int's and  a "true" is  any non-zero integer.   However, if
     LOGICAL has the  special value 2, then strictly  positive integers are
     treated as "true" values and strictly negative integers are treated as
     invlaid  values.  Note  that this  only  affect arrays  of int's  (not
     long's  nor short's nor  char's).  The  default is  to save  arrays of
     int's as array of 32 bits integers.

     The returned value is FH.

   SEE ALSO: fits, fits_new_bintable, fits_read_bintable, fits_bintable_poke. */
{

  /* Minimal checking. */

  if (fits_get_xtension(fh) != "BINTABLE")
    error, "current HDU is not a FITS BINTABLE";
  if (structof(ptr) == pointer) {
    ptr = ptr; /* force private copy */
  } else if (is_array(ptr)) {
    /* will save as binary table with a single field */
    ptr = &ptr;
  } else {
    error, "expecting array or pointer to save in BINTABLE";
  }

  /* Checking the pair of keywords: var and stype */

  if( !is_void(var) ) {
     if( is_void(stype) ) error,"Keyword stype must be given along with var";
     if( numberof(var) != numberof(stype) ) error,"Mismatch between 'var' and 'stype'";
     if( structof(stype) != char ) error,"Keyword stype must be of type char";
     for( i = 1; i <= numberof(stype); i++ ) {
        if( stype(i) != 'I' && stype(i) != 'J' && stype(i) != 'E' && stype(i) != 'D' ) \
           error,"Keyword stype must be one of I, J, E, and D";
     }
  } else var = 0;

  /* Find the format. */

  tfields = numberof(ptr);
  mult = size = array(long, tfields);
  nrows = -1;
  for (i=1 ; i<=tfields ; ++i) {
    local a; eq_nocopy, a, *ptr(i);
    if (is_void(a)) {
      ncells = 0;
    } else {
      if (! is_array(a)) error, "unexpected non-array field for BINTABLE";
      dims = dimsof(a);
      ndims = dims(1);
      if (ndims == 0) {
        /* fix for scalars */
        ndims = 1;
        dims = [1,1];
      }
      if (i == 1) {
        nrows = dims(2);
      } else if (dims(2) != nrows) {
        error, "all fields of a BINTABLE must have the same number of rows";
      }
      ncells = numberof(a)/nrows;
    }
    type = structof(a);
    if (type == string && ncells != 1) {
      error, "only string vectors implemented in BINTABLE";
    }

    /* Deal with TDIM# card. */
    key = swrite(format="TDIM%d", i);
    tdim = fits_get_list(fh, key);
    if (is_void(tdim)) {
      if (ndims > 2) {
        str = swrite(format="(%d", dims(3));
        for (j = 4 ; j <= ndims ; ++j) {
          str += swrite(format=",%d", dims(j));
        }
        str += ")";
        fits_set, fh, key, str, swrite(format="array dimensions for column %d", i);
      }
    } else {
      if (min(tdim) <= 0) {
        error, "bad dimension list for FITS card \"" + key + "\"";
      }
      if (numberof(tdim) != ndims - 1 || anyof(tdim != dims(3:))) {
        error, "incompatible dimension list in FITS card \"" + key + "\"";
      }
    }    

    /* Get/check the format if already specified */
    key = swrite(format="TFORM%d", i);
    tform = fits_get(fh, key);
    if (structof(tform) == string) {

      /**
      *** Parse TFORM# FITS cards.
      **/

      m = -1;
      s = nil = string(0);
      if (sread(format="%d%1s%s", tform, m, s, nil) != 2) {
        m = (sread(format="%1s%s", tform, s, nil) == 1 ? 1 : -1);
      }
      if (m < 0) error, "bad format string in FITS card \""+key+"\"";
      if ((type == string ? m <= 0 : ncells != m)) {
        error, ("bad number of cells in "+fits_nth(i)
                +" field of binary table");
      }
      mult(i) = m;
      t = (*pointer(s))(1);
      if (ncells) {
        if (t == 'A') {
          size(i) = 1;
          bad_type = (type != (cast = char) && type != string);
          if (type == string) {
            len = strlen(a);
            tmp = array(char, nrows, m);
            for (k=1 ; k<=nrows ; ++k) {
              if ((l = min(len(k), m))) {
                tmp(k, 1:l) = (*pointer(a(k)))(1:l);
              }
            }
            ptr(i) = &tmp; /* only affect local (private) copy */
            a = [];
            type = cast; /* prevent conversion below */
          }
        } else if (t == 'B') {
          size(i) = 1;
          bad_type = (type != (cast = char) &&
                      type != long && type != int && type != short);
        } else if (t == 'I') {
          size(i) = 2;
          bad_type = (type != (cast = short) &&
                      type != long && type != int && type != char);
        } else if (t == 'J') {
          size(i) = 4;
          bad_type = (type != (cast = long) &&
                      type != int && type != short && type != char);
        } else if (t == 'E') {
          size(i) = 4;
          bad_type = (type != (cast = float) &&
                      type != double && type != long &&
                      type != int && type != short && type != char);
        } else if (t == 'D') {
          size(i) = 8;
          bad_type = (type != (cast = double) &&
                      type != float && type != long &&
                      type != int && type != short && type != char);
        } else if (t == 'C') {
          size(i) = 8;
          bad_type = (type != complex &&
                      type != double && type != float && type != long &&
                      type != int && type != short && type != char);
          if (! bad_type) {
            tmp = array(float, nrows, 2*ncells);
            tmp(,1::2) = float(a);
            if (type == complex) tmp(,2::2) = a.im;
            ptr(i) = &tmp;
            a = [];
            type = cast = float; /* prevent conversion below */
          }
        } else if (t == 'M') {
          size(i) = 16;
          bad_type = (type != (cast = complex) &&
                      type != double && type != float && type != long &&
                      type != int && type != short && type != char);
        } else if (t == 'L') {
          size(i) = 1;
          bad_type = (type != (cast = char) &&
                      type != long && type != int && type != short);
          if (! bad_type && type != cast) {
            tmp = array('T', nrows, ncells);
            if (is_array((a = where(! a)))) tmp(a) = 'F';
            ptr(i) = &tmp;
            a = [];
            type = cast; /* prevent conversion below */
          }
        } else if (t == 'X') {
          error, "bit array in FITS binary table not yet implemented";
        } else if (t == 'P') {
          error, "pointer array in FITS binary table not yet implemented";
        } else {
          error, "bad format letter in FITS card "+key;
        }

        /* Maybe convert data type. */
        if (bad_type) {
          error, "unconsistent data formats for "+fits_nth(i)+" field";
        }
        if (cast != type) {
          ptr(i) = &cast(a);
          a = [];
        }
      }

    } else if (is_void(tform)) {

      /**
      ***  First see if we have a variable length vector column
      **/

      if( nallof( i - var ) ) {

         // Prepare outputting a two-element vector column with type 'long'
         t = stype(where(i == var)(1));
         ncells = 2;
         size(i) = 4;
         mult(i) = ncells;
         fits_set, fh, key, swrite(format="1P%c(2000)",t);

      } else {

         /**
         *** Otherwise guess it from data tables contents.
         **/

         if (ncells == 0) {
           t = 'A';
           size(i) = 1;
         } else if (type == double) {
           t = 'D';
           size(i) = 8;
         } else if (type == long) {
           t = 'J';
           size(i) = 4;
         } else if (type == char) {
           t = 'B';
           size(i) = 1;
         } else if (type == complex) {
           t = 'M';
           size(i) = 16;
         } else if (type == int) {
           if (logical) {
             t = 'L';
             size(i) = 1;
             tmp = array('F', dims); /* array of "false" values */
             if (logical == 2) {
               /* Treats strictly negative values as "bad" values and strictly
                  positive values as "true" values. */
               if (is_array((j = where(a < 0)))) tmp(j) = '\0';
               if (is_array((j = where(a > 0)))) tmp(j) = 'T';
             } else {
               /* Treats non-zero values as "true" values. */
               if (is_array((j = where(a)))) tmp(j) = 'T';
             }
             ptr(i) = &tmp; /* only affect local (private) copy */
           } else {
             t = 'J';
             size(i) = 4;
           }
         } else if (type == float) {
           t = 'E';
           size(i) = 4;
         } else if (type == short) {
           t = 'I';
           size(i) = 2;
         } else if (type == string) {
           t = 'A';
           size(i) = 1;
           ncells = max((len = strlen(a)));
           tmp = array(char, nrows, ncells);
           for (k=1 ; k<=nrows ; ++k) {
             if ((l = len(k))) tmp(k, 1:l) = (*pointer(a(k)))(1:l);
           }
           ptr(i) = &tmp; /* only affect local (private) copy */
         } else if (type == pointer) {
           error, "pointer fields not yet implemented in BINTABLE";
         } else {
           error, "unsupported data type in BINTABLE";
         }
         mult(i) = ncells;
         fits_set, fh, key, swrite(format="%d%c", ncells, t),
           "format of " + fits_nth(i) + " field";

       }
    } else {
      error, "bad value for FITS card "+key;
    }
  }

  /* Update header information then write header. */
  size *= mult; /* number of bytes per rows for each field */
  nbytes = sum(size);
  pcount = _fits_bintable_header(fh, nbytes, nrows, tfields);
  /* I have a suspicion that 'pcount' is used in the wrong way
     here, but it seems to be of no consequence - must check!
        [2008-10-02, NJW] */
  fits_write_header, fh;

  /* Write data. */
  local offset; eq_nocopy, offset, _car(fh, 3);
  stream = _car(fh, 4);
  address = offset(3);
  if (tfields == 0) {
  /*  Original version had: if (tfields == 1)
      but there is a problem with the writing order in some cases
      so this branch is completely avoided [NJW 2008-10-01] */
    /* Fast write in this case. */
    _write, stream, address, *ptr(1);
    address += nbytes*nrows;
  } else {
    /* Write data, one row at a time, one field at a time. This is really
       inefficient, but I do not see any other way to do that (using some
       equivalent structure in Yorick defined "on-the-fly" would be very
       complicated and cannot solve for all the cases). */
    for (j=1 ; j<=nrows ; ++j) {
      for (i=1 ; i<=tfields ; ++i) {
        _write, stream, address, (*ptr(i))(j,..);
        address += size(i);
      }
    }
  }

  /* Pad with null's to have an integer number of FITS blocks. */
  if (pcount) {
    _write, stream, address, array(char, pcount);
    address += pcount;
  }

  /* Update FITS handle. */
  offset(4) = address;
  return fh;
}

/* Function fits_read_bintable */

func fits_read_bintable(fh, pack=, select=, raw_string=, raw_logical=,
                        bad=, trim=)
/* DOCUMENT fits_read_bintable(fh)
     Reads a binary table in current  HDU of FITS handle FH and returns the
     fields of  the table as  a pointer array  (i-th field of the  table is
     pointed  by  i-th  pointer  element).   Empty fields  and  fields  for
     unsupported data  types (bit array  and array descriptor) result  in a
     null pointer (&[]).  The geometry  of the arrays pointed by the result
     will be  NROWS-by-NCOLS(i) where  NROWS is the  number of rows  in the
     table and NCOLS(i) is the repeat  count of the i-th field in the table
     (see fits_write_bintable).  If NCOLS(i)  = 1, the i-th pointer element
     is the address of a NROWS vector, i.e. not a NROWS-by-1 array.

     Keyword SELECT can be used to retain only some fields of the table (or
     re-order them).  For instance,  use SELECT=[2,5,3] to return only 2nd,
     5th and 3rd fields (in that  order) of the table.  The fields can also
     be selected by their names, e.g. SELECT=["flux","distance"] (note that
     trailing spaces and case is not significant for the field names).

     If keyword  PACK is  true, fits_pack_bintable (which  see) is  used to
     pack the  columns of  the binary table  into a single  array (possibly
     after selection/re-ordering by SELECT).

     If keyword TRIM is true,  then trailing spaces get removed from string
     fields (this has no effect if RAW_STRING is true).

     If keyword RAW_STRING is true,  fields made of char's ('A' format) are
     returned as  arrays of char's.  The  default is to  convert 'A' format
     fields into 1-by-NROWS array of strings.

     If  keyword  RAW_LOGICAL is  true,  logical  fields  ('L' format)  are
     returned as  arrays of char's.  The  default is to  convert 'L' format
     fields  into array of  int's as  follows: 'T'  -> 1  (true), 'F'  -> 0
     (false), and any other character ->  -1 (bad).  The 'bad' value can be
     set by keyword BAD (default is -1).

   SEE ALSO: fits, fits_write_bintable, fits_pack_bintable. */
{
  /* Minimal checking. */
  if (fits_get_xtension(fh) != "BINTABLE" || fits_get_naxis(fh) != 2) {
    error, "current HDU is not a valid FITS BINTABLE";
  }
  nbytes = fits_get(fh, "NAXIS1");
  nrows = fits_get(fh, "NAXIS2");
  tfields = fits_get(fh, "TFIELDS");
  if (nbytes <= 0 || nrows <= 0) return;

  /* May-be we just want some fields given their names. */
  if (structof(select) == string) {
    select = fits_index_of_table_field(fh, select);
    keep = array(0n, tfields);
    keep(select) = 1n;
  } else {
    keep = array(1n, tfields);
  }

  /* Extract formats. */
  ptr = array(pointer, tfields);
 /*
  *  the following 'if' is lifted because of what happens later
  *    (approx. 120 lines down)
  *
  *  if (nrows > 1) row = array(pointer, tfields);
  */
  row = array(pointer, tfields);
  is_string = array(int, tfields);
  is_logical = array(int, tfields);
  is_complex = array(int, tfields);
  is_not_byte = array(int, tfields);
  size = array(long, tfields); /* number of bytes per column per row */
  mult = array(long, tfields);
  s = nil = string(0);
  m = 0;
  warn_X = warn_P = 1;
  for (i=1 ; i<=tfields ; ++i) {
    tform = fits_get(fh, (key = swrite(format="TFORM%d", i)));
    if (structof(tform) != string) {
      error, ((is_void(tform) ? "missing" : "unexpected data type for")
              + " FITS card \""+key+"\"");
    }
    // Check for variable length column. Will be returned as
    // int array(2,nrows)
    if( strpart( tform, 1:2 ) == "1P" ) tform = "2J";
    if (sread(format="%d%1s%s", tform, m, s, nil) != 2) {
      if (sread(format="%1s%s", tform, s, nil) == 1) m = 1;
      else error, "bad format string in FITS card \""+key+"\"";
    }
    c = (*pointer(s))(1);
    if (c == 'L') {
      type = char;
      size(i) = (mult(i) = m);
      is_logical(i) = 1n;
    } else if (c == 'B') {
      type = char;
      size(i) = (mult(i) = m);
    } else if (c == 'I') {
      type = short;
      size(i) = 2*(mult(i) = m);
    } else if (c == 'J') {
      type = long;
      size(i) = 4*(mult(i) = m);
    } else if (c == 'E') {
      type = float;
      size(i) = 4*(mult(i) = m);
    } else if (c == 'D') {
      type = double;
      size(i) = 8*(mult(i) = m);
    } else if (c == 'C') {
      type = float;
      size(i) = 4*(mult(i) = 2*m);
      is_complex(i) = 1n;
    } else if (c == 'M') {
      type = complex;
      size(i) = 16*(mult(i) = m);
    } else if (c == 'A') {
      type = char;
      size(i) = (mult(i) = m);
      is_string(i) = 1n;
    } else if (c == 'X') {
      /* bit array */
      size(i) = (m + 7)/8; /* round up to a number of 8-bit bytes */
      mult(i) = 0;  /* skip this field */
      if (warn_X) {
        _fits_warn, "bit array in FITS binary table not yet implemented";
        warn_X = 0;
      }
    } else if (c == 'P') {
      /* array descriptor */
      size(i) = 8*m;
      mult(i) = 0;  /* skip this field */
      if (warn_P) {
        _fits_warn, "pointer array in FITS binary table not yet implemented";
        warn_P = 0;
      }
    } else {
      error, "unknown format \""+tform+"\" in FITS binary table";
    }
    if (mult(i) && keep(i)) {
      ncells = mult(i);
      key = swrite(format="TDIM%d", i);
      tdim = fits_get_list(fh, key);
      if (is_void(tdim)) {
        if (ncells > 1) {
          dimlist = ncells;
        } else {
          dimlist = [];
        }
      } else {
        if (min(tdim) <= 0) {
          error, "bad dimension list for FITS card \"" + key + "\"";
        }
        number = 1L;
        ndims = numberof(tdim);
        for (j = ndims ; j >= 1 ; --j) {
          number *= tdim(j);
        }
        if (number != ncells) {
          error, "incompatible dimension list in FITS card \"" + key + "\"";
        }
        dimlist = array(long, ndims + 1);
        dimlist(1) = ndims;
        if (ndims >= 1) {
          dimlist(2:0) = tdim;
        }
      }
      ptr(i) = &array(type, nrows, dimlist);
 /*
  *  the following 'if' is lifted because of what happens later
  *    (approx. 24 lines down)
  *
  *   if (nrows > 1) row(i) = &array(type, dimlist);
  */
      row(i) = &array(type, dimlist);
      is_not_byte(i) = (type != char);
    } else {
      keep(i) = 0n; /* will not read this column */
    }
  }

  /* Read data. */
  local a, offset;
  eq_nocopy, offset, _car(fh, 3);
  address = offset(3);
  stream = _car(fh, 4);
  if ((row_pad = (nbytes - sum(size))) < 0)
    error, "inconsistent NAXIS1 in FITS binary table";

 /*
  *   Eliminate the first option here. Original 'if' is saved here:
  *     if (nrows == 1 || (row_pad == 0 && tfields == 1)) (tuborg begin)
  *    2009-05-07/NJW
  */
  if( 0 ) {
    /* Faster read: avoid unnecessary copies if NROWS=1, or read the whole
       table can in a single call to _read if TFIELDS=1 and there are no
       padding bytes. */
    for (i=1 ; i<=tfields ; ++i) {
      if (keep(i)) {
        eq_nocopy, a, *ptr(i);
        if (is_not_byte(i)) _read, stream, address, a;
        else if (_read(stream, address, a) != size(i)) error, "short file";
      }
      address += size(i);
    }
  } else {
    /* Multiple rows _and_ multiple fields: must read one row at a time,
       one field at a time. */
    for (k=1 ; k<=nrows ; ++k) {
      for (i=1 ; i<=tfields ; ++i) {
        if (keep(i)) {
          eq_nocopy, a, *row(i);
          if (is_not_byte(i)) _read, stream, address, a;
          else if (_read(stream, address, a) != size(i))
            error, "short file";
          (*ptr(i))(k,) = a;
        }
        address += size(i);
      }
      address += row_pad;
    }
  }

  /* Fix single precision complex array. */
  if ((n = numberof((i = where(is_complex & keep)))) > 0) {
    for (k=1 ; k<=n ; ++k) {
      j = i(k);
      eq_nocopy, a, *ptr(j);
      a = a(,1::2) + 1i*a(,2::2);
      ptr(j) = &(mult(j) == 2 ? a(,1) : a);
    }
  }

  /* Fix logical array: 'T' -> 1 (true), 'F' -> 0 (false), and any other
     character -> -1 (bad). */
  if (! raw_logical && (n = numberof((i = where(is_logical & keep)))) > 0) {
    if (is_void(bad)) bad = -1;
    for (k=1 ; k<=n ; ++k) {
      j = i(k);
      r = (*ptr(j) == 'T');
      if (is_array((l = where(! ((*ptr(j) == 'F') | r))))) r(l) = bad;
      ptr(j) = &r;
    }
  }

  /* Fix string array. */
  if (! raw_string && (n = numberof((i = where(is_string & keep)))) > 0) {
    local a;
    for (k=1 ; k<=n ; ++k) {
      j = i(k);
      eq_nocopy, a, *ptr(j);
      tmp = array(string, nrows);
      for (l=1 ; l<=nrows ; ++l) {
        if ((c = a(l,))(1)) {
          if (trim) {
            r = numberof(c);
            t = 0;
            while (++t <= r && c(t))
              ;
            while (--t && c(t) == ' ')
              ;
            if (t >= 1) tmp(l) = string(&c(1:t));
          } else {
            tmp(l) = string(&c);
          }
        }
      }
      ptr(j) = &tmp;
    }
  }
  if (pack) {
    return fits_pack_bintable(ptr, select);
  }
  if (is_void(select)) {
    return ptr;
  }
  return ptr(select);
}

func fits_pack_bintable(ptr, list)
/* DOCUMENT fits_pack_bintable(ptr)
       -or- fits_pack_bintable(ptr, list)
     Packs binary  table PTR  into a  single array; PTR  must be  a pointer
     array  (e.g. as  the one  returned by  fits_read_bintable  which see).
     Second  argument LIST  can be  specified  to select  or re-order  some
     fields: LIST is a vector of indices of selected and re-ordered fields,
     the result will be as if  PTR(LIST) was given as unique argument.  The
     returned array is NROWS-by-NCOLS where NROWS is the first dimension of
     all fields (which must be the same) and NCOLS is the sum of the second
     dimension of all fields.

   SEE ALSO: fits_read_bintable. */
{
  if (structof(ptr) != pointer) {
    error, "expecting array of pointer argument";
  }
  if (is_void(list)) {
    seletct = 0n;
    n = numberof(ptr);
  } else {
    seletct = 1n;
    n = numberof(list);
  }
  start = stop = array(long, n);
  ncols = 0;
  type = [];
  for (i=1 ; i<=n ; ++i) {
    local a; eq_nocopy, a, *ptr((select ? list(i) : i));
    if (is_void(a)) continue; /* ignore empty field */
    if ((s = structof(a)) != char && s != short && s != int &&
        s != long && s != float && s != double && s != string) {
      error, "bad data type in table column";
    }
    dims = dimsof(a);
    ndims = dims(1);
    start(i) = 1 + ncols;
    if (ndims == 1) {
      ++ncols;
    } else if (ndims == 2) {
      ncols += dims(3);
    } else {
      error, "unexpected dimension list in table column";
    }
    stop(i) = ncols;
    if (i == 1) {
      nrows = dims(2);
      type = s;
    } else {
      if (dims(2) != nrows) error, "bad number of rows in table column";
      if (s != type) {
        if (s == string || type == string)
          error, "mixing of text and numerical data";
        type = structof(type(0) + s(0));
      }
    }
  }

  /* Pack selected columns. */
  arr = array(type, nrows, ncols);
  for (i=1 ; i<=n ; ++i) {
    arr(, start(i):stop(i)) = *ptr((select ? list(i) : i));
  }
  return arr;
}

func _fits_bintable_header(fh, nbytes, nrows, tfields)
/* DOCUMENT _fits_bintable_header(fh, nbytes, nrows, tfields)
     Set/update header  information in  FITS handle FH  for a  binary table
     extension.  NBYTES is the number of  bytes per row of the table, NROWS
     is  the number  of table  rows  and TFIELDS  is the  number of  fields
     (columns in  the table).  FITS  card "XTENSION" with  value "BINTABLE"
     must already exists  in the header (this is  not checked).  FITS cards
     "BITPIX",  "NAXIS",   "NAXIS1",  "NAXIS2",  "PCOUNT",   "GCOUNT",  and
     "TFIELDS" get created/updated by this routine.  The value of PCOUNT is
     computed by the routine and returned to the caller.

   SEE ALSO: fits, fits_new_bintable, fits_write_bintable. */
{
  block = 2880;
  pcount = ((nbytes*nrows + block - 1)/block)*block - nbytes*nrows;
  fits_set, fh, "BITPIX", 8, "data contains array of bytes";
  fits_set, fh, "NAXIS", 2, "two-dimensional binary table";
  fits_set, fh, "NAXIS1", nbytes, "number of 8-bit bytes in a table row";
  fits_set, fh, "NAXIS2", nrows, "number of rows in the table";
  fits_set, fh, "PCOUNT", pcount,
    "total number of bytes is PCOUNT + NAXIS1*NAXIS2";
  fits_set, fh, "GCOUNT", 1, "always 1 for binary table extensions";
  fits_set, fh, "TFIELDS", tfields, "number of fields in each row";
  return pcount;
}

func fits_read_bintable_as_hashtable(fh, h, format=,
                                     select=, raw_string=, raw_logical=, bad=)
/* DOCUMENT fits_read_bintable_as_hashtable(fh)
       -or- fits_read_bintable_as_hashtable(fh, h)

     Read  binary table  in current  HDU (see  fits_read_bintable)  of FITS
     handle FH  and make it into a  hash table.  If optional  argument H is
     given, it  must be  an existing  hash table to  be augmented  with the
     contents of the binary table.  The (augmented) hash table is returned.
     This function can only be used with the hash table extension.

     The  members of  the  hash table  get  named after  the  value of  the
     'TTYPEn' card  converted to lowercase  (where n is the  field number).
     For missing  'TTYPEn' cards,  the value of  keyword FORMAT is  used to
     define the member name  as swrite(format=FORMAT,n).  The default value
     for FORMAT is "_%d".  If  FORMAT is specified, it must contain exactly
     one directive to write an  integer and no other format directives.  If
     a card 'TUNITn' exists, its  value is stored into member with "_units"
     appended to the corresponding field name.

     Keywords SELECT, RAW_STRING, RAW_LOGICAL and BAD have the same meaning
     as in fits_read_bintable.

   SEE ALSO: fits_read_bintable, swrite, h_new. */
{
  local names;
  if (structof(select) == string) {
    eq_nocopy, names, select; /* save literal names for further use */
    select = fits_index_of_table_field(fh, select);
  }
  ptr = fits_read_bintable(fh, select=select, bad=bad,
                           raw_string=raw_string, raw_logical=raw_logical);
  n = numberof(ptr);
  augment = is_hash(h);
  if (! augment) {
    if (is_void(h)) h = h_new();
    else error, "expecting a hash table";
  }
  if (is_void(format)) format = "_%d";
  for (i=1 ; i<=n ; ++i) {
    /* J is the column number for I-th element in PTR. */
    j = (is_void(select) ? i : select(i));

    /* Get member name. */
    if (is_void(names)) {
      name = fits_get(fh, swrite(format="TTYPE%d", j));
      if (structof(name) == string && strlen(name)) {
        name = fits_tolower(name);
      } else {
        name = swrite(format=format, j);
      }
    } else {
      name = names(i);
    }

    /* Instanciate hash members for column data and units. */
    h_set, h, name, *ptr(i);
    units = fits_get(fh, swrite(format="TUNIT%d", j));
    name_units = name + "_units";
    if (structof(units) == string && strlen(units)) {
      h_set, h, name_units, units;
    } else if (augment) {
      h_pop, h, name_units;
    }
  }
  return h;
}

func fits_index_of_table_field(fh, name)
/* DOCUMENT fits_index_of_table_field(fh, name)
     Returns index(es) of FITS table columns with their TTYPE# value
     matching array of string(s) NAME.  The table header is read from
     current HDU of FITS handle FH.

   SEE ALSO: fits, fits_read_bintable. */
{
  if (structof(name) != string) error, "expecting table column name(s)";
  tfields = fits_get(fh, "TFIELDS");
  ttype = array(string, tfields);
  for (i=1 ; i<=tfields ; ++i) {
    s = fits_get(fh, swrite(format="TTYPE%d", i));
    if (structof(s) == string && strlen(s)) {
      ttype(i) = fits_tolower(s);
    }
  }
  n = numberof(name);
  index = array(long, dimsof(name)); // result will have same geometry
  for (i=1 ; i<=n ; ++i) {
    j = where(fits_tolower(fits_trim(name(i))) == ttype);
    if (numberof(j) != 1) {
      if (is_array(j)) error, "more than one field match \""+name(i)+"\"";
      error, "no field matches \""+name(i)+"\"";
    }
    index(i) = j(1);
  }
  return index;
}

/*---------------------------------------------------------------------------*/
/* MISCELLANEOUS */

/* Note: The following fits_toupper and fits_tolower routines are ~2 times
   faster than their ancestors in "string.i". */

local fits_toupper, fits_tolower;
/* DOCUMENT fits_tolower(s)
       -or- fits_toupper(s)
     Converts a string or an array of strings S to lower/upper case letters.

   SEE ALSO: fits, fits_trim. */

local _fits_tolower;
local _fits_toupper;
/* DOCUMENT _fits_tolower
            _fits_toupper
     Private arrays to convert char to upper/lowercase letters.

   SEE ALSO: fits, fits_tolower, fits_toupper. */
(_fits_tolower=char(indgen(0:255)))(1+'A':1+'Z')=_fits_tolower(1+'a':1+'z');
(_fits_toupper=char(indgen(0:255)))(1+'a':1+'z')=_fits_toupper(1+'A':1+'Z');

func _fits_tolower_0(s)
{
  extern _fits_tolower;
  n = numberof((r = array(string, dimsof(s))));
  for (i=1 ; i<=n ; ++i) {
    r(i) = string(&_fits_tolower(1 + *pointer(s(i))));
  }
  return r;
}

func _fits_toupper_0(s)
{
  extern _fits_toupper;
  n = numberof((r = array(string, dimsof(s))));
  for (i=1 ; i<=n ; ++i) {
    r(i) = string(&_fits_toupper(1 + *pointer(s(i))));
  }
  return r;
}

func _fits_tolower_1(s)
{
  return strcase(0, s);
}

func _fits_toupper_1(s)
{
  return strcase(1, s);
}

func fits_trim(s)
/* DOCUMENT fits_trim(s)
     Removes trailing  spaces (character 0x20) from scalar  string S (note:
     trailing spaces are not significant in FITS).

   SEE ALSO: fits, fits_tolower, fits_toupper. */
{
  if (! (i = numberof((c = *pointer(s))))) return string(0);
  while (--i) { if (c(i) != ' ') return string(&c(1:i)); }
  return "";
}

local fits_strcmp;
/* DOCUMENT fits_strcmp(a, b)
     Returns non-zero where (array of) strings A and B are the same in FITS
     sense, i.e., ignore case and trailing ordinary spaces (code 0x20). For
     instance, "Hello" and "HELLO " are the same strings.

   SEE ALSO: fits, fits_toupper. */

func _fits_strcmp_0(a,b) /* code for Yorick versions older than 1.6 */
{
  n = numberof((r = array(int, dimsof(a,b))));
  for (i=1 ; i<=n ; ++i) {
    if ((na = numberof((ca = *pointer(a(i))))))
      while (--na && ca(na) == ' ') ;
    if ((nb = numberof((cb = *pointer(b(i))))))
      while (--nb && cb(nb) == ' ') ;
    if (na == nb)
      r(i) = (na ? allof(_fits_toupper(1 + ca(1:na)) ==
                         _fits_toupper(1 + cb(1:nb))) : 1n);
  }
  return r;
}

func _fits_strcmp_1(a,b)
{
  blank=" "; /* only trim ordinary spaces */
  return (strcase(1, strtrim(a, 2, blank=blank)) ==
          strcase(1, strtrim(b, 2, blank=blank)));
}

/* Install function code according to Yorick capabilities. */
if (is_func(strcase) == 2) {
  fits_toupper = _fits_toupper_1;
  fits_tolower = _fits_tolower_1;
  fits_strcmp = _fits_strcmp_1;
} else {
  fits_toupper = _fits_toupper_0;
  fits_tolower = _fits_tolower_0;
  fits_strcmp = _fits_strcmp_0;
}
_fits_toupper_0 = _fits_toupper_1 = [];
_fits_tolower_0 = _fits_tolower_1 = [];
_fits_strcmp_0 = _fits_strcmp_1 = [];

func fits_map(op, src)
/* DOCUMENT fits_map(op, src)
     Map scalar function OP onto array argument SRC to mimics element-wise
     unary operation.

   SEE ALSO: fits. */
{
  if (! (n = numberof(src))) return;
  /* use structof to avoid unecessary string duplication for string result */
  dst = array(structof((dst1 = op(src(1)))), dimsof(src));
  dst(1) = dst1;
  for (i=2 ; i<=n ; ++i) dst(i) = op(src(i));
  return dst;
}

func fits_is_scalar(x) { return (is_array(x) && ! dimsof(x)(1)); }
/* DOCUMENT fits_is_scalar(x)
     Returns true if X is a scalar.

   SEE ALSO: fits_is_integer_scalar, fits_is_real_scalar,
             fits_is_string_scalar. */

func fits_is_integer(x)
/* DOCUMENT fits_is_integer(x)
     Returns true if array X is of integer type.

   SEE ALSO: fits_is_scalar. */
{ return ((s=structof(x)) == long || s == int || s == char || s == short); }

func fits_is_integer_scalar(x)
/* DOCUMENT fits_is_integer_scalar(x)
     Returns true if array X is a scalar of integer type.

   SEE ALSO: fits_is_real_scalar, fits_is_scalar, fits_is_string_scalar. */
{
  return (((s=structof(x)) == long || s == int || s == char || s == short) &&
          ! dimsof(x)(1));
}

func fits_is_real_scalar(x)
/* DOCUMENT fits_is_real_scalar(x)
     Returns true if array X if of real type (i.e. double or float).

   SEE ALSO: fits_is_integer_scalar, fits_is_scalar, fits_is_string_scalar. */
{ return (((s=structof(x)) == double || s == float) && ! dimsof(x)(1)); }

func fits_is_string_scalar(x)
/* DOCUMENT fits_is_string_scalar(x)
     Returns true if array X is a scalar of string type.

   SEE ALSO: fits_is_integer_scalar, fits_is_real_scalar, fits_is_scalar. */
{ return (structof(x) == string && ! dimsof(x)(1)); }

func fits_filename(stream)
/* DOCUMENT fits_filename(fh)
     Return path name  of file associated with FITS handle  FH (in fact the
     argument may also be any Yorick open stream).

   SEE ALSO: fits. */
{
  /* Get stream from FITS handle. */
  if ((id = typeof(stream)) == "list") {
    if (_len(stream) != 4) error, "bad FITS handle";
    id = typeof((stream = _car(stream, 4)));
  }

  /* Check input and get description of stream by the print() command. */
  if ((id = typeof(stream)) == "stream") { id = 1; s = print(stream); }
  else if (id == "text_stream")          { id = 2; s = print(stream)(2:); }
  else error, "unexpected non-stream argument";

  /* Join backslash terminated lines from print() result (another
     possibility would be to change the line length with `print_format' but
     there is no way to restore the previous line_lenght unles we building
     a wrapper around original `print_format' routine and make a
     substitution). */
  join = (strpart(s, 0:0) == "\\");
  if (anyof(join)) {
    r = array(string, (ns= numberof(s)) - sum(join) + join(0));
    i = j= 0;
    while (i<ns) {
      w = s(++i);
      while (join(i)) {
        w = strpart(w, :-1);
        if (++i>ns) break;
        w += s(i);
      }
      r(++j) = w;
    }
    s = r;
    w = r = [];
  }

  /* Recover the full path of the stream file from the joined lines. */
  if (id == 1) {
    /* Binary stream. */
    if (numberof(s)==2) {
      w1= w2= string(0);
      if (sread(s(1), format="%[^:]", w1)==1 &&
          sread(s(2), format="%[^/]", w2)==1) {
        return strpart(s(2), strlen(w2)+1:0) + strpart(s(1), strlen(w1)+3:0);
      }
    }
    error, "unexpected binary stream descriptor";
  } else {
    /* Text stream. */
    if (numberof(s) == 1) {
      w = string(0);
      if (sread(s(1), format="%[^/]", w)==1) {
        return strpart(s(1), strlen(w)+1:0);
      }
    }
    error, "unexpected text stream descriptor";
  }
}

func fits_check_bitpix(bitpix)
/* DOCUMENT fits_check_bitpix(bitpix)
     Test if FITS bits-per-pixel value BITPIX is valid.

   SEE ALSO: fits, fits_bitpix_of, fits_bitpix_type, fits_bitpix_info. */
{
  return ((bitpix>0 && (bitpix==8 || bitpix==16 || bitpix==32)) ||
          bitpix==-32 || bitpix==-64);
}

func fits_bitpix_info(bitpix)
/* DOCUMENT fits_bitpix_info(bitpix)
     Return string information about FITS bits-per-pixel value.

   SEE ALSO: fits, fits_bitpix_of, fits_bitpix_type, fits_check_bitpix. */
{
  if (bitpix ==   8) return "8-bit twos complement binary unsigned integer";
  if (bitpix ==  16) return "16-bit twos complement binary integer";
  if (bitpix ==  32) return "32-bit twos complement binary integer";
  if (bitpix == -32) return "IEEE single precision floating point";
  if (bitpix == -64) return "IEEE double precision floating point";
  error, "invalid BITPIX value";
}

func fits_bitpix_type(bitpix, native=)
/* DOCUMENT fits_bitpix_type(bitpix)
       -or- fits_bitpix_type(bitpix, native=1)
     Returns Yorick data type given by FITS bits-per-pixel value BITPIX.
     If keyword NATIVE is true, return the native data type matching BITPIX.

   SEE ALSO: fits, fits_bitpix_of, fits_bitpix_info, fits_check_bitpix. */
{
  if (native) {
    /* Figure out native type matching BITPIX. */
    if (bitpix > 0) {
      if (bitpix ==  8*sizeof(long))   return long;
      if (bitpix ==  8*sizeof(int))    return int;
      if (bitpix ==  8*sizeof(short))  return short;
      if (bitpix ==  8*sizeof(char))   return char;
    } else {
      if (bitpix == -8*sizeof(double)) return double;
      if (bitpix == -8*sizeof(float))  return float;
    }
  } else {
    /* Assume XDR type. */
    if (bitpix ==   8) return char;
    if (bitpix ==  16) return short;
    if (bitpix ==  32) return long;
    if (bitpix == -32) return float;
    if (bitpix == -64) return double;
  }
  error, "invalid/unsupported BITPIX value";
}

func fits_bitpix_of(x, native=)
/* DOCUMENT fits_bitpix_of(x)
       -or- fits_bitpix_of(x, native=1)
     Return FITS bits-per-pixel value BITPIX for binary data X which can be
     an array or a data  type (structure definition).  If keyword NATIVE is
     true, the routine assumes that  binary data will be read/write to/from
     FITS file using native machine data representation.  The default is to
     conform to FITS standard and to  assume that XDR binary format will be
     used in FITS file.

   SEE ALSO: fits, fits_bitpix_type, fits_check_bitpix. */
{
  if (is_array(x)) {
    x = structof(x);
  } else if (typeof(x) != "struct_definition") {
    error, "expecting array or data type argument";
  }
  if (native) {
    /* Compute BITPIX. */
    bpb = 8; /* assume 8 bits per byte */
    if (x==char || x==short || x==int || x==long) {
      bitpix = bpb*sizeof(x);
      if (bitpix == 8 || bitpix == 16 || bitpix == 32) return bitpix;
    } else if (x == float || x == double) {
      bitpix = -bpb*sizeof(x);
      if (bitpix == -32 || bitpix == -64) return bitpix;
    }
  } else {
    /* Assume data will be read/written as XDR. */
    if (x == char) return 8;
    if (x == short) return 16;
    if (x == int || x == long) return 32;
    if (x == float) return -32;
    if (x == double) return -64;
  }
  error, "unsupported data type \""+nameof(x)+"\"";
}

/*---------------------------------------------------------------------------*/
/* CARDS AND KEYS */

local _fits_parse_comment;
func fits_parse(card, id, safe=)
/* DOCUMENT fits_parse(card);
       -or- fits_parse(card, id);
     Return value  of a single  FITS card (CARD  is a scalar  string).  The
     type of the scalar result is as follow:
        - string for a string or a commentary FITS card
        - char ('T' for true or 'F' for false) for a logical FITS card
        - long for an integer FITS card
        - double for a real FITS card
        - complex for a complex FITS card

     Trailing   spaces   (which    are   irrelevant   according   to   FITS
     specifications)   get   discarded   from   the  returned   value   for
     string-valued cards (not commentary cards).

     In order to save a call to  fits_id, if ID is non-nil it is assumed to
     be the numerical identifier of the card, i.e. fits_id(CARD).

     The   comment  part   of   CARD  is   stored   into  external   symbol
     _fits_parse_comment which is a string (possibly nil) for a valued card
     and void (i.e. []) for a commentary card.

     If the  SAFE keyword is true,  the routine returns an  empty result in
     case of error.

   SEE ALSO: fits, fits_get, fits_id. */
{
  extern _fits_parse_comment;
  extern _fits_id_comment, _fits_id_history;

  if (is_void(id)) id = fits_id(card);
  tail = strpart(card, 9:);

  /* Deal with commentary card. */
  if (id == 0.0 || id == _fits_id_comment || id == _fits_id_history) {
    _fits_parse_comment = [];
    return tail;
  }

  /* Use first non-space character after '=' for faster guess (I don't
     want to be too strict there: FITS standard requires that bytes
     9-10 be "= " for a valued-card, but the following sread format
     succeeds if bytes 9-80 is a "=" followed by any number of spaces
     and at least a non-space character). */
  r = s = _fits_parse_comment = string(0);
  if ((n = sread(tail, format="%1[=]%1s", r, s)) != 2) {
    if (n == 0) {
      /* Must be END card. */
      if (id == _fits_id_end) {
        _fits_parse_comment = [];
        return;
      }
    } else /* n = 1 */ {
      /* Undefined keyword. */
      return;
    }
  } else if (strmatch("0123456789+-.", s)) {
    /* Numerical value...
       ... try integer value: */
    re = 0;
    n = sread(tail, format="=%d%1s %[^\a]", re, s, _fits_parse_comment);
    if (n==1 || (n>1 && s=="/")) return re;

    /* ... try real value: */
    re = 0.0;
    n = sread(tail, format="=%f%1s %[^\a]", re, s, _fits_parse_comment);
    if (n==1 || (n>1 && s=="/")) return re;

    /* ... try complex value: */
    im = 0.0;
    n = sread(tail, format="=%f%f%1s %[^\a]", re, im, s, _fits_parse_comment);
    if (n==2 || (n>2 && s=="/")) return re + 1i*im;

  } else if (s=="T" || s=="F") {
    /* Logical value. */
    value = (s == "T" ? 'T' : 'F');
    n = sread(tail, format="= "+s+"%1s %[^\a]", s, _fits_parse_comment);
    if (n==0 || (n>0 && s=="/")) return value;

  } else if (s=="'" && sread(tail, format="= '%[^\a]", s)) {
    /* String value. */
    q = p1 = p2 = string(0);
    value = "";
    do {
      if (sread(s, format="%[^']%[']%[^\a]", p1, q, p2)) value += p1;
      else if (! sread(s, format="%[']%[^\a]", q, p2)) break;
      if ((n = strlen(q)) > 1) value += strpart(q, :n/2);
    } while ((s=p2) && !(n%2));
    if (! sread(s, format="%1s %[^\a]", q, _fits_parse_comment) || q=="/") {
      /* discard trailing spaces which are not significant in FITS */
      i = numberof((c = *pointer(value)));
      while (--i) { if (c(i) != ' ') return string(&c(1:i)); }
      return "";
    }
  } else if (s == "/") {
    /* Undefined keyword with comment. */
    sread, tail, format="= / %[^\a]", _fits_parse_comment;
    return;
  }

  if (! safe) error, "syntax error in FITS card \""+strpart(card, 1:8)+"\"";
}

func fits_get(fh, pattern, &comment, default=, promote=)
/* DOCUMENT fits_get(fh, pattern, comment)
     Get  (array  of)  value(s)   for  FITS  cards  matching  PATTERN  (see
     fits_match) in current header of FITS handle FH.  If present, argument
     COMMENT is  an output symbol  where the corresponding comment  part of
     selected card(s)  will be stored.   In order to avoid  namespace clash
     due to Yorick's  scoping rules, COMMENT should be  declared as a local
     symbol in the calling function, e.g.:
       local comment;
       value = fits_get(fh, pattern, comment);

     If no  cards match PATTERN, the  value of keyword  DEFAULT is returned
     and COMMENT is set to the null string.

     The data  type of  the returned value  depends on the  particular card
     type: a  char ('T' or  'F') is returned  for a logical-valued  card, a
     long is returned for an  integer-valued card, a double is returned for
     a real-valued  card, a complex  is returned for a  complex-valued card
     (either integer  or floating  point), and a  string is returned  for a
     commentary  or  a  string-valued  card.  Trailing  spaces  (which  are
     irrelevant  according  to  FITS  specifications)  get  discarded  from
     the returned value for string-valued cards (not commentary cards).

     If multiple cards match PATTERN, their values must be of the same type
     unless keyword PROMOTE is true, in which case the routine promotes all
     card values to a suitable "highest" type.

     Request fo commentary cards  (i.e. PATTERN is "HISTORY", "COMMENT", or
     "") may returns several cards.

   SEE ALSO: fits, fits_match, fits_parse. */
{
  local _fits_parse_comment;
  extern _fits_match_id, _fits_id_history;
  i = where(fits_match(fh, pattern));
  if (! is_array(i)) {
    comment = string(0);
    return default;
  }
  card = _car(fh,1)(i);

  value = fits_parse(card(1), _fits_match_id);
  if ((number = numberof(card)) == 1) {
    comment = _fits_parse_comment;
    return value;
  }
  type = structof(value);
  result = array(value, number);
  if (is_void(_fits_parse_comment)) {
    comment = [];
  } else {
    comment = array(string, number);
    comment(1) = _fits_parse_comment;
  }
  for (i=2 ; i<=number ; ++i) {
    value = fits_parse(card(i), _fits_match_id);
    if ((new_type = structof(value)) != type) {
      if (! promote) error, "multiple cards with different data types";
      if (type == string || new_type == string)
        error, "cannot mix string cards with other ones";
      if (type == char || new_type == char)
        error, "cannot mix logical cards with other ones";
      new_type = structof(type(0) + new_type(0));
      if (type != new_type) {
        type = new_type;
        result = type(result);
      }
    }
    result(i) = value;
    if (is_array(comment)) comment(i) = _fits_parse_comment;
  }
  return result;
}

local _fits_match_id;
func fits_match(fh, pattern)
/* DOCUMENT fits_match(fh, pattern)
     Return array of int's which are non-zero where FITS card names in FITS
     handle  FH  match PATTERN.   PATTERN  must be  a  scalar  string or  a
     numerical identifier.  As a  special case, if  PATTERN is of  the form
     "KEYWORD#" (i.e.  last character of  PATTERN is a '#'), then any human
     readable integer will match the '#', e.g. "NAXIS#" will match "NAXIS3"
     and "NAXIS11" but not "NAXIS" nor "QNAXIS4.

     Global/extern  variable  _fits_match_id  is  set  with  the  numerical
     identifier of PATTERN (without last '#' if any).

   SEE ALSO: fits, fits_get_cards, fits_rehash. */
{
  extern _fits_multiplier, _fits_match_id;
  if (! is_array(_car(fh,1))) return;
  if ((s = structof(pattern)) == double) {
    return (_car(fh,2) == (_fits_match_id = pattern));
  } else if (s != string) {
    error, "PATTERN must be a scalar string or a numerical identifier";
  }
  if (strpart(pattern, 0:0) != "#") {
    return (_car(fh,2) == (_fits_match_id = fits_id(pattern)));
  }
  if ((len = strlen(pattern)) > 7) {
    _fits_match_id = -1.0; // means something wrong
    return array(0n, numberof(_car(fh,2)));
  }
  if (len <= 1) {
    _fits_match_id = 0.0;
    ok = array(1n, numberof(_car(fh,2)));
  } else {
    _fits_match_id = fits_id(strpart(pattern, 1:-1));
    ok = (_car(fh,2) % _fits_multiplier(len)) == _fits_match_id;
  }
  if (is_array((i = where(ok)))) {
    u = v = string(0);
    n = numberof((w = strpart(_car(fh,1)(i), len:8)));
    for (j=1 ; j<=n ; ++j) {
      if (sread(format="%[0-9]%s", w(j), u, v) != 1) ok(i(j)) = 0n;
    }
  }
  return ok;
}

func fits_get_cards(fh, pattern)
/* DOCUMENT fits_get_cards(fh, pattern);
     Return cards from  FITS handle FH which match  PATTERN (see fits_match
     for the syntax of PATTERN).

   SEE ALSO: fits, fits_match. */
{
  local _fits_match_id;
  i = where(fits_match(fh, pattern));
  if (is_array(i)) return _car(fh,1)(i);
}

func fits_delete(fh, pattern)
/* DOCUMENT fits_delete, fh, pattern;
     Delete all cards  matching PATTERN from current header  of FITS handle
     FH (see fits_match for the syntax of PATTERN).

   SEE ALSO: fits, fits_match. */
{
  local _fits_match_id;
  i = where(! fits_match(fh, pattern));
  if (is_array(i) && numberof(i) < numberof(_car(fh,1))) {
    _car,fh,1,_car(fh,1)(i);
    _car,fh,2,_car(fh,2)(i);
  }
}

func fits_ids(cards) { return fits_map(fits_id, cards); }
func fits_id(card)
/* DOCUMENT fits_id(card)
       -or- fits_ids(cards)
     Convert  FITS  card(s) or  FITS  card  name(s)  into unique  numerical
     identifier.  CARD is a scalar string and CARDS (with an S) is an array
     of string(s) (including a  scalar).  Only the keyword part (characters
     1:8) of CARD(S) is relevant; cards shorter than 8 characters yield the
     same identifier as if they were padded (right filled) with spaces.  In
     other words, all the values  returned by the following expressions are
     identical:
       fits_id("SIMPLE = T / conforming FITS file");
       fits_id("SIMPLE ");
       fits_id("SIMPLE");

   SEE ALSO: fits, fits_key, fits_rehash. */
{
  extern _fits_digitize, _fits_multiplier;
  if ((len = numberof((c = *pointer(card)))) <= 1) return 0.0;
  len = min(8, len - 1);
  digit = _fits_digitize(1 + c(1:len));
  if (min(digit) < 0  || min((!digit)(dif)) < 0) error, _fits_bad_keyword(c);
  return sum(_fits_multiplier(1:len)*digit);
}

func _fits_bad_keyword(c)
/* DOCUMENT _fits_bad_keyword(c)
     Returns error message due to invalid FITS keyword.  C is an array of
     characters that compose the bad FITS keyword.

   SEE ALSO: fits_id, fits_read_header. */
{
  if ((n = min(8, numberof(c)))) {
    digit = _fits_digitize(1 + c(1:n));
    do {
      if (digit(n)) {
        key = string(&c(1:n));
        if (min(digit) < 0)
          return ("bad character(s) in FITS keyword \"" +
                  key + "\" (see option ALLOW in fits_init)");
        if (min((!digit)(dif)) < 0)
          return ("leading/embedded blanks forbidden in FITS keyword \"" +
                  key + "\"");
      }
    } while (--n > 0); /* remove trailing spaces */
  }
  return ("no error in FITS keyword  \"" + key + "\" (BUG?)");
}

func _fits_id(hdr)
/* DOCUMENT _fits_id(hdr)
     Return array  of numerical identifier  for FITS header data  HDR which
     must be  an array(char, 80,  N).  Any invalid  FITS key will  have its
     identifier set to -1.

   SEE ALSO: fits, fits_id, fits_key, fits_rehash. */
{
  digit = _fits_digitize(1 + hdr(1:8,));
  id = _fits_multiplier(+)*digit(+,);
  if (anyof((bad = (digit(min,) < 0) | ((! digit)(dif,)(min,) < 0))))
    id(where(bad)) = -1.0;
  return id;
}

func fits_key(id)
/* DOCUMENT fits_key(id)
     Convert  (array   of)  FITS   numerical  identifier(s)  ID   into  the
     corresponding string FITS keyword(s) without trailing spaces.

   SEE ALSO: fits, fits_id. */
{
  extern _fits_max_id;
  if (min(id) < 0.0 || max(id) > _fits_max_id || max(id%1.0) > 0.0)
    error, "invalid FITS floating point identifier";
  return fits_map(_fits_key, id);
}

func _fits_key(id)
/* DOCUMENT _fits_key(id)
     Private routine used by fits_key, only  useful if ID is a valid scalar
     numerical identifier.

   SEE ALSO: fits_key. */
{
  extern _fits_multiplier, _fits_alphabet;
  c = array(double, 8);
  basis = _fits_multiplier(2);
  r = id;
  for (i=1 ; i<=8 ; ++i) r = (r - (c(i) = r%basis))/basis;
  return string(&_fits_alphabet(1 + long(c)));
}

func fits_rehash(fh)
/* DOCUMENT fits_rehash(fh);
     (Re)compute array of numerical identifier for FITS handle FH (operation
     is done in-place) and return FH.

   SEE ALSO: fits, fits_id. */
{
  if (min(_car(fh,2,fits_ids(_car(fh,1)))) >= 0.0) return fh;
  error, "##4## corrupted FITS header data";
}

/*---------------------------------------------------------------------------*/

func fits_get_bscale(fh) {
  if ((s = structof((value = fits_get(fh, _fits_id_bscale, default=1.0))))
      == double) return value; if (s == long) return double(value);
  _fits_warn, "bad value type for BSCALE"; return 1.0; }
func fits_get_bzero(fh) {
  if ((s = structof((value = fits_get(fh, _fits_id_bzero, default=0.0))))
      == double) return value; if (s == long) return double(value);
  _fits_warn, "bad value type for BZERO"; return 0.0; }
/* DOCUMENT fits_get_bscale(fh)
       -or- fits_get_bzero(fh)
     Get BSCALE and BZERO values  for FITS handle FH.  These parameters are
     used to convert file values into physical values according to:
         physical_value = BZERO + BSCALE * file_value
     if the corresponding card is  missing, BSCALE and BZERO default to 1.0
     and 0.0 respectively.

   SEE ALSO: fits, fits_get, fits_read_array, fits_write_array. */

func fits_get_gcount(fh) {
  if (structof((value = fits_get(fh, _fits_id_gcount, default=1)))
      == long) return value;
  _fits_warn, "bad value type for GCOUNT"; return 1; }
func fits_get_pcount(fh) {
  if (structof((value = fits_get(fh, _fits_id_pcount, default=0)))
      == long) return value;
  _fits_warn, "bad value type for PCOUNT"; return 0; }
/* DOCUMENT fits_get_gcount(fh)
       -or- fits_get_pcount(fh)
     Get PCOUNT and  GCOUNT values for FITS handle FH.   PCOUNT shall be an
     integer  equal  to  the  number  of parameters  preceding  each  group
     (default value 0).  GCOUNT shall be  an integer equal to the number of
     random groups present (default value  1).  The total number of bits in
     the data  array (exclusive of  fill that is  needed after the  data to
     complete the last record) is given by the following expression:

         NBITS = abs(BITPIX)*GCOUNT*(PCOUNT + NAXIS1*NAXIS2*...*NAXISm)


   SEE ALSO: fits, fits_get, fits_get_bitpix,
             fits_read_array, fits_write_array. */

func fits_get_history(fh) {
  if (structof((value = fits_get(fh, _fits_id_history))) == string
      || is_void(value)) return value;
  error, "bad value type for HISTORY"; }
func fits_get_comment(fh) {
  if (structof((value = fits_get(fh, _fits_id_comment))) == string
      || is_void(value)) return value;
  error, "bad value type for COMMENT"; }
/* DOCUMENT fits_get_history(fh)
       -or- fits_get_comment(fh)
     Get COMMENT and  HISTORY values for FITS handle FH.   The result is an
     array of string(s) or nil if no such cards exists in the header of the
     current unit.

   SEE ALSO: fits, fits_get, fits_read_array, fits_write_array. */


func fits_get_list(fh, key)
/* DOCUMENT fits_get_list(fh, key)
      Get value of FITS card KEY in FH and returns it as a vector of integers.
      This function is intended to parse, e.g. the TDIM# cards in BINTABLE
      extensions.  The syntax of the card must be a string of the form:

        '(ARG1,ARG2,...)'

      where ARG1, etc are human readable integer values.

   SEE ALSO: fits_get.
 */
{
  str = fits_get(fh, key);
  if (is_void(str)) return;
  if (structof(str) != string) {
    error, "unexpected data type for FITS card \"" + key + "\"";
  }
  str = strtrim(str, 3);
  c = *pointer(str);
  n = numberof(c);
  if (n >= 3 && c(1) == '(' && c(n-1) == ')' && sum(c == ')') == 1) {
    number = sum(c == ',') + 1;
    result = array(long, number);
    format_first = "(%d %[^\a]";
    format_other = ", %d %[^\a]";
    value = 0L;
    k = 0;
    while (sread(str, format=(k ? format_other : format_first), value, str) == 2) {
      result(++k) = value;
      if (k >= number) return result;
    }
  }
  error, "syntax error in value of FITS card \"" + key + "\"";
}

/*---------------------------------------------------------------------------*/
/* INITIALIZATION OF PRIVATE DATA */

local _fits_true, _fits_false;
/* DOCUMENT _fits_true
            _fits_false
     True/false FITS values ('T' and 'F' respectively). */
_fits_true = 'T';
_fits_false = 'F';

local _fits_digitize, _fits_multiplier, _fits_alphabet, _fits_max_id;
/* DOCUMENT _fits_digitize   - char -> number conversion array;
            _fits_multiplier - multiplier;
            _fits_alphabet   - allowed characters in FITS keys;
            _fits_max_id     - maximum possible ID value.
     Private  arrays  used  to   convert  FITS  keyword  to/from  numerical
     identifiers.  If you experiment  a strange behaviour of FITS routines,
     it may  be because one  of these arrays  get corrupted; in  that case,
     just  run subroutine fits_init  to reinitialize  things (you  may also
     have to rehash your FITS handles: see fits_rehash).

   SEE ALSO: fits, fits_init, fits_rehash, fits_id, fits_key. */

local _fits_id_simple, _fits_id_bitpix, _fits_id_naxis, _fits_id_end;
local _fits_id_comment, _fits_id_history, _fits_id_xtension;
local _fits_id_bscale, _fits_id_bzero, _fits_id_gcount, _fits_id_pcount;
/* DOCUMENT _fits_id_simple    _fits_id_bitpix   _fits_id_naxis
            _fits_id_end       _fits_id_comment  _fits_id_history
            _fits_id_xtension  _fits_id_bscale   _fits_id_bzero
            _fits_id_gcount    _fits_id_pcount
     Numerical  identifers of  common FITS  keywords. If  you  experiment a
     strange behaviour  of FITS  routines, it may  be because one  of these
     values get corrupted;  in that case, just run  subroutine fits_init to
     reinitialize things.

   SEE ALSO: fits, fits_init. */

local _fits_id_special;
/* DOCUMENT _fits_id_special
     Private  array  of  all  numerical  identifers of  common  FITS  keys:
     "SIMPLE",  "BITPIX",  "NAXIS", "END",  "",  "COMMENT", "HISTORY",  and
     "XTENSION".

   SEE ALSO: fits, fits_init. */

local _fits_strict;
/* DOCUMENT _fits_strict
     Private flag: apply strict FITS compliance?  Never change this flag
     directly but rather call `fits_init'.

   SEE ALSO: fits, fits_init. */


func fits_init(sloopy=, allow=, blank=)
/* DOCUMENT fits_init;
     (Re)initializes FITS private  data.  Normally you do not  have to call
     this  routine  because  this  routine  is  automatically  called  when
     "fits.i" is  parsed by Yorick.   You may however need  to explicitely
     call  fits_init  if  you  suspect  that some  FITS  private  data  get
     corrupted or if you want to tune FITS strict/sloopy behaviour.

     If keyword SLOOPY  is true (non-nil and non-zero)  some discrepancy is
     allowed (for reading FITS file only); otherwise strict FITS compliance
     is applied.  If SLOOPY is true, lower case Latin letters have the same
     meaning  as their  upper  case counterparts,  most control  characters
     become identical to regular spaces.

     According to FITS standard, the only characters permitted for keywords
     are  upper  case  (capital)  Latin alphabetic,  numbers,  hyphen,  and
     underscore.  Leading and embedded blanks are forbidden.  If you cannot
     read a FITS file because it does not confrom to this rule, you can use
     keyword ALLOW (a string or an array of characters) to allow additional
     characters for FITS keywords.  For instance:
       fits_init, allow="/."; // fix for invalid headers made by IRAF
     make characters '/'  and '.'  acceptable in FITS  keywords.  Note that
     you  must apply fits_rehash  (to see)  to _every_  FITS handle  in use
     whenever you change  the set of allowed characters  (because this will
     probably corrupt the values of numerical identifiers of FITS card) ...
     It is  therefore a good idea  to change the set  of allowed characters
     before using any FITS routines.

     Keyword  BLANK can  be  used to  add  more characters  that should  be
     considered as blanks (spaces)  when parsing FITS header/keywords.  The
     value  of BLANK  must  be a  string  or an  array  of characters,  for
     instance: BLANK="\t\r\v\n".  Note that this break strict compliance to
     FITS standard.

   SEE ALSO: fits, fits_rehash. */
{
  extern _fits_digitize,    _fits_multiplier;
  extern _fits_alphabet,    _fits_max_id;
  extern _fits_id_simple,   _fits_id_bitpix;
  extern _fits_id_naxis,    _fits_id_end;
  extern _fits_id_comment,  _fits_id_history;
  extern _fits_id_xtension, _fits_id_extname, _fits_id_special;
  extern _fits_id_bscale,   _fits_id_bzero;
  extern _fits_id_pcount,   _fits_id_gcount;
  extern _fits_strict;

  /* Strict FITS compliance? */
  _fits_strict = (strict = (! sloopy && is_void(allow)));

  /* Prepare key<->id conversion arrays. */
  _fits_alphabet = _(, '\0', '-', '_', char(indgen('0':'9')),
                                       char(indgen('A':'Z')));
  if (! is_void(allow)) {
    /* Add more allowed characters for FITS keywords. */
    if ((s = structof(allow)) == string && ! dimsof(allow)(1)) {
      allow = *pointer(allow);
    } else if (s != char) {
      error, "value of keyword ALLOW must be a string or an array of char's";
    }
    n = numberof(allow);
    for (i=1 ; i<=n ; ++i) {
      if (noneof(allow(i) == _fits_alphabet)) grow, _fits_alphabet, allow(i);
    }
  }
  basis = numberof(_fits_alphabet);
  _fits_multiplier = double(basis)^indgen(0:7);
  _fits_max_id = sum(_fits_multiplier * (basis-1.0));
  _fits_digitize = array(-1, 256);
  _fits_digitize(1 + _fits_alphabet) = indgen(0:basis-1);

  /* Deal with "blanck/space" characters (spaces and '\0' _must_ all have
     their digitize value equal to 0). */
  if ((space = _fits_digitize(1 + '\0')) != 0)
    error, "digitize value of spaces must be zero (BUG)";
  _fits_digitize(1 + ' ') = space;
  if (! is_void(blank)) {
    if ((s = structof(blank)) == string && ! dimsof(blank)(1)) {
      blank = *pointer(blank);
    } else if (s != char) {
      error, "value of keyword BLANK must be a string or an array of char's";
    }
    _fits_digitize(1 + blank) = space;
  }

  if (! strict) {
    _fits_digitize(1 + '\t') = space;
    _fits_digitize(1 + '\r') = space;
    _fits_digitize(1 + '\v') = space;
    _fits_digitize(1 + '\n') = space;
    _fits_digitize(indgen(1+'a':1+'z')) = _fits_digitize(indgen(1+'A':1+'Z'));
  }

  /* Numerical ID's of common keys. */
  _fits_id_simple   = fits_id("SIMPLE");
  _fits_id_bitpix   = fits_id("BITPIX");
  _fits_id_naxis    = fits_id("NAXIS");
  _fits_id_history  = fits_id("HISTORY");
  _fits_id_comment  = fits_id("COMMENT");
  _fits_id_end      = fits_id("END");
  _fits_id_xtension = fits_id("XTENSION");
  _fits_id_extname  = fits_id("EXTNAME");
  _fits_id_bscale   = fits_id("BSCALE");
  _fits_id_bzero    = fits_id("BZERO");
  _fits_id_pcount   = fits_id("PCOUNT");
  _fits_id_gcount   = fits_id("GCOUNT");
  //_fits_id_extend = fits_id("EXTEND");
  _fits_id_special  = [_fits_id_simple, _fits_id_bitpix, _fits_id_naxis,
                       _fits_id_end, 0.0, _fits_id_comment, _fits_id_history,
                       _fits_id_xtension];
}

/*---------------------------------------------------------------------------*/
/* CLOSURE */

/* Initializes FITS internals (must be last statement of this file).  The
   following allows for non-standard keyword characters usually found in
   FITS files produced by IRAF... */
if (is_void(_fits_alphabet)) fits_init, allow="/."; /*  */

/*---------------------------------------------------------------------------*/
/* SUPPORT FOR OBSOLETE API */

/* Here are the _public_ routines defined in the old API:
     func fitsHeader(&header)
     func fitsFixHeader(&header)
     func fitsAddComment(&header, str)
     func fitsAddHistory(&header, str, stamp=)
     func fitsRescale(data, bitpix, &bscale, &bzero, data_min=, data_max=)
     func fitsWrite(name, data, header, rescale=, pack=)
     func fitsRead(name, &header, which=, pack=, rescale=) */

local fitsHeader, fitsFixHeader, fitsAddComment, fitsAddHistory;
local fitsRescale, fitsWrite;
func fitsObsolete(..,stamp=,data_min=,data_max=,rescale=,pack=,which=)
/* DOCUMENT obsolete FITS routines

     In order to help you to upgrade your code and use the new FITS API,
     you can use the following equivalence table:
       fitsAddComment, hdr, str;    ==>  fits_set, fh, "COMMENT", str;
       fitsAddHistory, hdr, str;    ==>  fits_set, fh, "HISTORY", str;
       fitsWrite, name, data;       ==>  fits_write, name, data;
       fitsWrite, name, data, hdr;  ==>  fits_write_array, fh, data;
       fitsRead(name);              ==>  fits_read(name);
       data = fitsRead(name, hdr);  ==>  data = fits_read(name, fh);
     where NAME is the file name, STR is a string comment, HDR is the
     header structure (obsolete but see fitsMakeOldHeader), FH is
     the (new) FITS handle and DATA is an array of numbers.

     The following old routines have no real equivalent:
       fitsHeader
       fitsFixHeader
       fitsRescale

   SEE ALSO: fits. */
{ error, "update your code to use new FITS API (type \"help, fits\")"; }
fitsHeader = fitsFixHeader = fitsAddComment = fitsAddHistory =
fitsRescale = fitsWrite = fitsRead = fitsObsolete;

func fitsRead(name, &header, which=, pack=, rescale=)
/* DOCUMENT a= fitsRead(filename, header)

     *** WARNING: Obsolete fits routine (see fits_read) ***

     Returns the data of the  FITS file FILENAME.  If present, the optional
     argument HEADER will be used to  store the contents of the FITS header
     file (a FitsHeader structure).

     Keyword  WHICH may  be  used  to indicate  which  sub-array should  be
     returned.  For instance, if the array DATA with dimensions (235,453,7)
     is stored in the FITS file "data.fits", the sub-array DATA(,,4) can be
     read by:
               SUB_DATA= fitsRead("data.fits", which= 4);

     Keyword PACK, if non-nil and  non-zero, indicates that axis whith unit
     dimension  should be  ignored.  The  default  is to  ignore only  zero
     length axis.

     Keyword RESCALE, if non-nil and  zero, indicates that read data values
     should not  be rescaled according  to FITS keywords BSCALE  and BZERO.
     The default is to rescale data values  if BSCALE is not 1. or BZERO is
     not 0.

  SEE ALSO: fits, fits_read, fitsObsolete. */
{
  local fh;
  data = fits_read(name, fh, which=which, rescale=rescale /*pack=pack*/);
  header = fitsMakeOldHeader(fh);
  return data;
}

local FitsHeader;
/* DOCUMENT FitsHeader - a Yorick structure  defined to store (part of) FITS
     header information.  The structure has the following members:

     bitpix   - bits-per-pixel:  8  pixel values are unsigned bytes
                                16  pixel values are signed 2-byte integers
                                32  pixel values are signed 4-byte integers
                               -32  pixel values are 4-byte floating points
                               -64  pixel values are 8-byte floating points
     naxis    - number of axis
     axis(k)  - number of pixel along k-th axis
     bscale   - pixelValue = BZERO+BSCALE*fileValue
     bzero    - pixelValue = BZERO+BSCALE*fileValue
     bunit    - brightness unit
     datamax  - maximum data value in the file
     datamin  - minimum data value in the file
     object   - image name
     date     - date of file creation (dd/mm/yy)
     date_obs - date of data acquisition (dd/mm/yy)
     origin   - institution
     instrume - data acquisition instrument
     telescop - data acquisition telescope
     observer - observer name/identification
     history  - newline separated history lines
     comment  - newline separated comment lines
     epoch    - epoch of coordinate system (year)
     crval(k) - coord = CRVAL+(pixel-CRPIX)*CDELT
     crpix(k) - coord = CRVAL+(pixel-CRPIX)*CDELT
     cdelt(k) - coord = CRVAL+(pixel-CRPIX)*CDELT
     ctype(k) - type of physical coordinate
     crota(k) - rotation angle of axis No. #

  SEE ALSO: fits, fitsMakeOldHeader. */
struct FitsHeader {
  int    bitpix, naxis, axis(9);
  double bscale, bzero, datamax, datamin, epoch,
    crval(9), crpix(9), cdelt(9), crota(9);
  string bunit, object, date, date_obs, origin, instrume, telescop, observer,
    history, comment, ctype(9);
}

local fitsOldHeaderMembers;
local fitsOldHeaderKeywords;
func fitsMakeOldHeader(fh)
/* DOCUMENT fitsMakeOldHeader(fh)
     Convert header information in FITS handle FH into the obsolete FitsHeader
     structure.

   SEE ALSO: fits, FitsHeader. */
{
  hdr = FitsHeader();
  n = numberof(fitsOldHeaderMembers);
  for (i=1 ; i<=n ; ++i) {
    if (! is_void((value = fits_get(fh, fitsOldHeaderKeywords(i))))) {
      get_member(hdr, fitsOldHeaderMembers(i)) = value;
    }
  }
  nil = string(0);
  for (i=1 ; i<=hdr.naxis ; ++i) {
    hdr.axis(i)  = fits_get(fh, swrite(format="NAXIS%d", i), default=0);
    hdr.crval(i) = fits_get(fh, swrite(format="CRVAL%d", i), default=0.0);
    hdr.crpix(i) = fits_get(fh, swrite(format="CRPIX%d", i), default=0.0);
    hdr.cdelt(i) = fits_get(fh, swrite(format="CDELT%d", i), default=0.0);
    hdr.ctype(i) = fits_get(fh, swrite(format="CTYPE%d", i), default=nil);
    hdr.crota(i) = fits_get(fh, swrite(format="CROTA%d", i), default=0.0);
  }
  if (! is_void((value = fits_get(fh, "HISTORY"))))
    hdr.history = _fits_strjoin(value);
  if (! is_void((value = fits_get(fh, "COMMENT"))))
    hdr.comment = _fits_strjoin(value);
  return hdr;
}
fitsOldHeaderMembers = ["bitpix","naxis","bscale","bzero","bunit",
                        "datamax","datamin","object","date","date_obs",
                        "origin","instrume","telescop","observer","epoch"];
fitsOldHeaderKeywords = fits_toupper(fitsOldHeaderMembers);


func _fits_strjoin(s)
{
  if ((n = numberof(s)) < 1) return;
  r = s(1);
  for (i=2;i<=n;++i) r += "\n" + s(i);
  return r;
}
func _fits_strsplit(s)
{
  i = 0;
  r = array(string);
  while (s) {
    s = strtok(s, "\n");
    if (++i > numberof(r)) grow, r, array(string, numberof(r));
    r(i) = s(1);
    s = s(2);
  }
  if (i == numberof(r)) return r;
  return r(1:i);
}

/*---------------------------------------------------------------------------*/

/* Function fits_cards_test */

/*
 *   Function added by Niels J. Westergaard  2009-03-02
 *   to be able to test if an extension exists e.g.
 *        fh = fits_goto_hdu( fh, hdu )
 *        if( fits_cards_test( fh ) {
 *                ... extension seems to exist (based on the existence of cards)
 *        } else {
 *                ... extension seems not to exist (based on the lack of cards)
 *        }
 *
 */

func fits_cards_test( fh )
/* DOCUMENT res = fits_cards_test( fh )

    returns 1 is cards are found, else zero
*/
{
   if( typeof(_car(fh,1)) == "string" ) {
      return 1;
   } else return 0;

}
%FILE% kombinationer.i
extern kombinationerdoc;
/* DOCUMENT kombinationer

    permu
    nkombi
    kombi
    kombigrupper
    ticnext
*/

/* Function permu */

func permu( a, i )
/* DOCUMENT b = permu( a, i )
   returns the i'th permutation of array 'a'
*/
{
   n = numberof(a);
   //+ write,format="permu(a,i) i = %i\na = ", i;
   //+ for(l=1;l<n;l++) write,format="%i,", a(l);
   //+ write,format="%i\n",a(n);
   fn = facul(n);
   if( i < 1 || i > fn ) error,"##1## PERM error";
   if( n == 1 ) return a;
   if( n == 2 ) {
      if( i > 2 ) error,"##2## PERM error";
      return i==1 ? a : a([2,1]);
   }
   fnm1 = facul(n-1);
   j = (i-1)/fnm1;
   k = i - j*fnm1;
   j++;
   b = a(j);
   c = rem_elem( a, j );
   grow, b, permu(c,k);
   return b;
}

/* Function nkombi */

func nkombi( m, n )
/* DOCUMENT nk = nkombi( m, n )

   returns number of combinations when 'm' elements
   are chosen between 'n' elements.
*/
{
   if( m > n ) error,"Bad input to 'nkombi': m > n";
   if( m == n ) return 1;
   if( m+1 == n ) return long(n);
   return facul(n,m+1)/facul(n-m);
}

/* Function kombi */

func kombi( m, arr, i )
/* DOCUMENT res = kombi( m, arr, i )

   returns the i'th set of 'm' elements
   out of array 'arr'.

*/
{
   n = numberof(arr);
   //+ write,format="kombi M1 m = %i, n = %i, i = %i\n", m, n, i;
   // determine first element
   if( i == 1 ) return arr(1:m);
   if( m == 1 ) return arr(i);
   index = 1;
   nn = n - 1;
   mm = m - 1;
   while( index < n - m + 1 ) {
      nk = nkombi(mm,nn);
      if( i <= nk ) {
         a = arr(index);
         grow,a,kombi(mm,arr(index+1:0),i);
         return a;
      }
      index++;
      i -= nk;
      nn--;
   }
   return arr(n-m+1:0);
}

/* Function kombigrupper */

func kombigrupper( arr, n, &nkomg )
/* DOCUMENT res = kombigrupper( arr, n, >nkomg )

   returns 'permutation' number 'n' of 'arr' when
   some of the elements of 'arr' are identical.
   The returned variable 'nkomg' is the number of
   these group permutations.

*/
{
   narr = numberof(arr);
   // *** sort to prepare locating the groups
   arr = arr(sort(arr));
   res = arr*0;
   u = uniq(arr);
   grow,u,numberof(arr)+1;
   // *** get number of elements in each group
   nu = u(dif);
   n_grupper = numberof(nu); 
   idx = indgen(narr);

   nkomg = facul(narr);
   for(i=1;i<=n_grupper;i++) nkomg /= facul(nu(i));
   //+ write,format="nkomg = %i\n", nkomg;
   nkg = nkomg;

   if( n > nkomg ) error, "Requested number too large (max "+itoa(nkomg)+")";

   for( i = 1; i <= n_grupper; i++ ) {
      // choose positions for group 'i' members
      nk = nkombi(nu(i),numberof(idx));
      nn = (n-1)%nk + 1;
      n = (n-1)/nk + 1;
      //+ write,format="i = %i, nk = %i, nn = %i\n", i, nk, nn;
      p = kombi(nu(i),idx,nn);
      res(p) = arr(u(i));
      w = whereany(idx,p);
      idx = rem_elem(idx,w);
      nkg /= nk;
   }

   return res;

}

/* Function ticnext */

func ticnext( &arr, lims, pos )
/* DOCUMENT ticnext, >arr, lims[,pos]

   Updates 'arr' to the next instance.
   To be stopped when numberof(a) == sum(a)
   i.e. all one.
*/
{
   if( is_void(pos) ) pos = 1;
   narr = numberof(arr);
   arr(pos)++;
   if( arr(pos) > lims(pos) ) {
      arr(pos) = 1;
      pos++;
      if( pos > narr ) return;
      ticnext, arr, lims, pos;
   }
   return;
}
%FILE% kwds_setmcm.i
/* Function kwds_setmcm */

func kwds_setmcm( keyword, long_string, comment )
/* DOCUMENT kwds_setmcm, keyword, long_string, comment

    Use kwds_set several times to split up 'long_string'.
    Use 'keyword' as it is for the first part, and then
    truncate to 6 letters (if necessary) and count from
    01 thru 99.

*/
{
   if( typeof(long_string) != "string" ) error,"Called with non-string 2. argument";

   lenk = strlen(keyword);
   lenl = strlen(long_string);
   if( lenl < 30 ) { // No real use for this function
      kwds_set, keyword, long_string, comment;
      return;
   }

   keyw6 = strpart(keyword,1:6);
   count = 0;

   while( lenl > 0 ) {
      body = strpart( long_string, 1:60 );
      long_string = strpart( long_string, 61: );
      lenl = strlen(long_string);
      cont = lenl == 0 ? "" : " &";
      if( count == 0 ) {
         kwds_set, keyword, body+cont;
      } else {
         kwds_set, keyw6+itoa(count,2), body+cont;
      }
      count++;
   }
   if( strlen(comment) ) kwds_set, keyw6+itoa(count,2), "COMMENT", comment;
}
%FILE% kwds_std.i
func kwds_std( instr= )
/* DOCUMENT kwds_std, instr=

    Include standard keywords as expressed in 'kwds_incl.txt' (must be
    present in the current directory) that has a grammar like the
    file needed for 'fmodhead'.

    The keyword 'instr' will overwrite the INSTRUME value given in this
    file.
*/
{
   if( !file_test("kwds_incl.txt") ) {
      write,"Action not possible since kwds_incl.txt is missing.";
      return;
   }
   lines = rdfile("kwds_incl.txt");
   nlines = numberof(lines);

   for( i = 1; i <= nlines; i++ ) {
      // locate keyword
      p = strpos( lines(i), "=" );
      if( p ) { // a '=' is present
         kwd = strlowcase(strtrim(strpart(lines(i),1:p-1)));
         // locate the comment string
         q = strpos( lines(i), "/", p+1 );
         if( q ) {
            com = strtrim(strpart(lines(i),q+1:0));
         } else {
            q = strlen(lines(i))+1;
            com = [];
         }
         if( kwd == "date" ) {
            value = ndate(3);
         } else {
            vstr = strtrim(strpart(lines(i),p+1:q-1));
            // string or number?
            r = strpos(vstr,"'");
            if( r ) {
               rr = strpos(vstr,"'",r+1);
               if( !rr ) {
                  write,"Missing quote in line: "+lines(i);
                  return;
               }
               value = strtrim(strpart(vstr,r+1:rr-1));
            } else { // no quotes are present, interpret as string if not a valid number
               if( is_number(vstr) ) { // do we have a number?
                  if( is_fnumber(vstr) ) { // do we have a floating point number?
                     value = atof(vstr);
                  } else {
                     value = atoi(vstr);
                  }
               } else { // not a number, returned as a string in spite of missing quotes
                  value = vstr;
               }
            }
         }
      } else { // no '=' sign found, must be comment or history
         lin = strtrim(lines(i));
         q = strpos(lin," ");
         kwd = strpart(lin, 1:q-1);
         if( kwd == "comment" || kwd == "history" ) {
            value = strtrim(strpart(lin,q+1:0));
            com = [];
         } else {
            write,"Illegal keyword in line: "+lines(i);
            return;
         }
      }

      kwds_set, kwd, value, com;
      if( structof(instr) == string ) kwds_set, "instrume", instr, "Name of instrument";

   }
}
%FILE% larnum.i
extern larnum;
/* DOCUMENT ************************************
    Large Numbers as integers represented in long array with
    'LARNUM_size' ordinary elements followed by the sign.

      _adjust( kk )
      _div( aii, ajj, >rem ) // aii >= 0 && ajj > 0
      _ln_gt( ii, jj ) // ii >= 0 && jj >= 0
      _sub( ii, jj ) // ii >= jj >= 0
      add( ii, jj )
      any2ln( arg )
      dble2ln( x )
      div( ii, jj, &rem ) // res*jj + rem = ii
      ln2dble( ii )
      ln2str( ii )
      ln_eq( ii, jj )
      ln_is_prime( n )
      ln_ge( ii, jj )
      ln_gt( ii, jj )
      ln_next_prime( n )
      ln_prime_factors, n
      lnabs( ii )
      lnchs( ii )
      lnodd( ii )  // not a multiple of 2
      ln5odd( ii ) // not a multiple of 5
      ln3odd( ii ) // not a multiple of 3
      ln7odd( ii ) // not a multiple of 7
      ln11odd( ii ) // not a multiple of 11
      ln13odd( ii ) // not a multiple of 13
      lnpow( m, e )
      lnsqrt( number, >rem ) // res^2 + rem = number
      mul( ii, jj )
      pp, i    // simulates the i++ operator
      prln( ii )
      setln( i1, .., sgn= )
      str2ln( str )
      sub( ii, jj )

   2008-12-21/NJW

   NB! Find out how to make sure that
    (0,0,0,0,0,1) == (0,0,0,0,0,-1)

***************************************/
#include "basic.i"
#include "idlx.i"
#include "string.i"

if( sizeof(long) < 8 ) {  // this is probably a 32 bit machine
   LARNUM_size = 10;
   B = 10000;
   NDIGITS = 4;
   FMTSTR = "%04i";
   R7 = [1,4,2,1,4,2,1,4,2,1];
   R11 = [1,1,1,1,1,1,1,1,1,1];
   R13 = [1,3,9,1,3,9,1,3,9,1];
   //+ write,format="Started 32 bit version, length = %i\n", LARNUM_size;
} else {   //      this is a 64 bit or higher machine
   LARNUM_size = 5;
   B = 1000000000;
   NDIGITS = 9;
   FMTSTR = "%09i";
   R7 = [1,6,1,6,1];
   R11 = [1,10,1,10,1];
   R13 = [1,12,1,12,1];
   //+ write,format="Started 64+ bit version, length = %i\n", LARNUM_size;
}
dB = double(B);
LNMAX = array(B-1,LARNUM_size+1);
LNMAX(0) = 1;
LNZERO = array(0,LARNUM_size+1);
LNZERO(0) = 1;
LNUNIT = LNZERO;
LNUNIT(1) = 1;
LNTWO = LNZERO;
LNTWO(1) = 2;

func str2ln( str )
{
   if( !is_number( str ) ) error,"STR2LN got invalid string";
   if( !is_digit( strpart(str, 2:0) ) ) error,"STR2LN got non-integer";
   d1 = strpart(str,1:1);
   if( is_digit(d1) ) {
      sgn = 1;
      body = str;
   } else {
      if( d1 == "+" ) {
         sgn = 1;
         body = strpart(str,2:0);
      } else {
         sgn = -1;
         body = strpart(str,2:0);
      }
   }
   res = LNZERO;
   res(0) = sgn;
   len = strlen(body);
   k = 1;
   while( len > NDIGITS ) {
      res(k++) = atoi(strpart(body,len-NDIGITS+1:len));
      body = strpart(body,1:len-NDIGITS);
      len -= NDIGITS;
   }
   // add last bit - if not zero
   if( len ) res(k) = atoi(body);

   return res;
}

func any2ln( arg )
{
   n = numberof(arg);
   if( n != 1 && n != LARNUM_size+1 ) error,"ANY2LN: Illegal dimension of argument";
   t = typeof(arg);
   if( n == 1 ) {
      if( t == "string" ) {
         return str2ln( arg );
      } else if( t == "double" || t == "float" ) {
         return dble2ln( double(arg) );
      } else if( t == "long" || t == "int" ) {
         return setln( arg );
      } else error,"ANY2LN: Illegal type of argument";
   } else {
      if( t == "long" ) {
         return _adjust( arg );
      } else error,"ANY2LN: Array has illegal type";
   }
}
     
func setln( i1, .., sgn= )
{
   res = array( long, LARNUM_size+1 );
   res(0) = 1; // defaults to positive
   if( !is_void(sgn) ) {
      if( sgn >= 0 ) res(0) = 1;
      if( sgn <  0 ) res(0) = -1;
   }
   i = 1;
   res(1) = abs(i1);
   while( more_args() ) {
      i++;
      res(i) = abs(next_arg());
   }
   return _adjust(res);
}

func lnchs( ii )
{
   res = ii;
   res(0) = -ii(0);
   return res;
}

func _adjust( kk, allow= )
{
   res = kk;
   // adjust all but the last array element
   for( i = 1; i < LARNUM_size; i++ ) {
      d = res(i) / B;
      r = res(i) % B;
      res(i+1) += d;
      res(i) = r;
   }
   // check that last array element has not grown too large
   //   except when keyword 'allow' has been set
   if( allow ) {
      res(LARNUM_size) %= B;
   } else {
      if( res(LARNUM_size) >= B ) error,"_adjust encountered too large number";
   }
   // make sure that sign element is 1 or -1
   if( allof(res(1:-1)==0) ) { // zero abs value
      res(0) = 1;
   } else {
      res(0) = res(0) >= 0 ? 1 : -1;
   }
   return res;
}

func lnabs( ii )
{
   res = ii;
   if( ii(0) < 0 ) res(0) = 1;
   return res;
}

func add( ii, jj )
{
   if( is_scalar(ii) ) {
      iii = setln(abs(ii));
      iii(0) = ii >= 0 ? 1 : -1;
   } else iii = ii;
   if( is_scalar(jj) ) {
      jjj = setln(abs(jj));
      jjj(0) = jj >= 0 ? 1 : -1;
   } else jjj = jj;
   sgnii = iii(0);
   sgnjj = jjj(0);

   if( sgnii > 0 ) {     // ii > 0

      if( sgnjj > 0 ) {
         //+ write,"add case ii > 0 and jj > 0";
         res = iii + jjj;
         return _adjust(res);
      } else { // jj < 0
         //+ write,"add case ii > 0 and jj < 0";
         ajj = lnabs( jjj );
         if( ln_ge( iii, ajj ) ) {
            //+ write,"add subcase ii > ajj";
            res = _sub( iii, ajj );
         } else {
            //+ write,"add subcase ajj > ii";
            res = _sub( ajj, iii );
            res(0) = -1;
         }
         return res;
      }

   } else { // ii < 0

      aii = lnabs( iii );

      if( sgnjj > 0 ) {
         //+ write,"add case ii < 0 and jj > 0";
         if( ln_ge( jjj, aii ) ) {
            //+ write,"add subcase jj > aii";
            res = _sub( jjj, aii );
         } else {
            //+ write,"add subcase aii > jj";
            res = _sub( aii, jjj );
            res(0) = -1;
         }
         return res;

      } else { // jj < 0

         //+ write,"add case ii < 0 and jj < 0";
         ajj = lnabs(jjj);
         res = aii + ajj;
         res(0) = -1;
         return _adjust(res);
      }

   }
   error,"ADD: should never come here";
}

func sub( ii, jj )
{
   iii = is_scalar(ii) ? setln(ii) : ii;
   jjj = is_scalar(jj) ? setln(jj) : jj;
   jjj(0) = -jjj(0); // change sign and add
   return add( iii, jjj );
}

func _sub( ii, jj ) // ii >= jj >= 0
{

   if( ii(0) != 1 || jj(0) != 1 ) error,"_sub got negative number";
   if( ln_gt(jj,ii) ) error,"_sub jj > ii";

   jj_compl = LNMAX - jj;
   res = ii + jj_compl;
   res(1)++;
   res(0) = 1;
   return _adjust( res, allow=1 );
}

func mul( ii, jj )
{
   if( is_scalar(ii) ) {
      iii = setln(abs(ii));
      iii(0) = ii >= 0 ? 1 : -1;
   } else iii = ii;
   if( is_scalar(jj) ) {
      jjj = setln(abs(jj));
      jjj(0) = jj >= 0 ? 1 : -1;
   } else jjj = jj;

   kk = array(long, LARNUM_size+1 );
   for( k = 1; k <= LARNUM_size; k++ ) {
      s = 0;
      kmax = k+1;
      for( i = 1; i < kmax; i++ ) {
         j = kmax - i;
         s += iii(i) * jjj(j);
      }
      kk(k) = s;
   }
   kk(0) = iii(0)*jjj(0);
   return _adjust( kk );
}

func prln( file, ii )
{
   if( typeof(file) == "text_stream" ) {
      f = 1;
   } else {
      f = 0;
      ii = file;
   }
   sgn = ii(0) >= 0 ? "+" : "-";
   if(f)write,file,format="%s", sgn;
   if(!f)write,format="%s", sgn;
   first = 1;
   j = LARNUM_size;
   while( ii(j) == 0 && j > 0 ) j--; // find first non-zero element
   if( j == 0 ) write,format="%i",0;
   for( i = j; i >= 1; i-- ) {
      if( first ) {
         if(!f)write,format="%i", ii(i);
         if(f)write,file,format="%i", ii(i);
         first = 0;
      } else {
         if(!f)write,format=FMTSTR, ii(i);
         if(f)write,file,format=FMTSTR, ii(i);
      }
   }
   if(!f)write,format="%s\n","";
   if(f)write,file,format="%s\n","";
}

func ln2str( ii, nos= )
{
   sgn = ii(0) >= 0 ? "+" : "-";
   if(nos) sgn="";
   res = sgn;
   first = 1;
   j = LARNUM_size;
   while( ii(j) == 0 && j > 0 ) j--; // find first non-zero element
   if( j == 0 ) return sgn+"0";
   for( i = j; i >= 1; i-- ) {
      if( first ) {
         res = res + swrite(format="%i", ii(j));
         first = 0;
      } else {
         res = res + swrite(format=FMTSTR, ii(i));
      }
   }
   return res;
}

func ln2dble( ii )
{
   s = double(ii(LARNUM_size));
   for( i = LARNUM_size-1; i >= 1; i-- ) {
      s = ii(i) + dB*s;
   }
   return s*ii(LARNUM_size+1);
}

func ln_eq( ii, jj )
{
   return allof( ii == jj );
}

func ln_gt( ii, jj )
{
   sgnii = ii(0);
   sgnjj = jj(0);

   if( sgnii > 0 ) { // ii > 0

      if( sgnjj > 0 ) {
         return _ln_gt( ii, jj );
      } else { // jj < 0
         return 1;
      }

   } else { // ii < 0

      if( sgnjj > 0 ) {
         return 0;
      } else { // jj < 0
         return _ln_gt( jj, ii );
      }

   }

}

func _ln_gt( ii, jj ) // ii >= 0 && jj >= 0
      // or compare absolute values
{
   for( i = LARNUM_size; i >= 1; i-- ) {
      if( ii(i) > jj(i) ) return 1;
      if( ii(i) < jj(i) ) return 0;
   }
   return 0;
}

func ln_ge( ii, jj )
{
   if( allof( ii == jj ) ) return 1;
   return ln_gt( ii, jj );
}

func div( ii, jj, &rem )
/* DOCUMENT res = div( ii, jj, >rem )

   returns res = ii/jj with sign sgn(ii)*sgn(jj) and remainder
   'rem' so that res * jj + rem = ii
*/
{
   if( is_scalar(ii) ) {
      iii = setln(abs(ii));
      iii(0) = ii >= 0 ? 1 : -1;
   } else iii = ii;
   if( is_scalar(jj) ) {
      jjj = setln(abs(jj));
      jjj(0) = jj >= 0 ? 1 : -1;
   } else jjj = jj;
   sgnii = iii(0);
   sgnjj = jjj(0);
   sgnres = sgnii * sgnjj;
   aii = lnabs(iii);
   ajj = lnabs(jjj);

   if( ln_eq( aii, ajj ) ) {
      rem = setln(0);
      return setln(1,sgn=sgnres);
   }
   if( ln_gt( ajj, aii ) ) {
      rem = aii;
      return setln(0);
   }

   quotient = _div( aii, ajj, rem );
   if( anyof(quotient(1:-1)) ) quotient(0) = sgnres;
   return quotient;
}

func dble2ln( x )
{
   res = array(long, LARNUM_size+1 );

   if( x < 0.0 ) {
      res(0) = -1;
      x = -x; // continue with absolute value
   } else res(0) = 1;

   if( x < 0.5 ) return res;
   if( x < 1.5 ) {
      res(1) = 1;
      return res;
   }

   i = 0;
   do {
      d = x / dB;
      if( d < dB ) {
         ld = long(d);
         rem = x - ld * dB;
      } else {
         ld = d;
         rem = 0.0;
      }
      res(++i) = rem;
      x = double(ld);
   } while( ld > 0 && i < LARNUM_size );

   return res;
}

func ln_prime_factors( number )
{
   local rem;

   number = any2ln( number );

   limit = lnsqrt( number );
   j = setln(2);
   while( ln_ge( limit, j ) ) {
      q = div( number, j, rem );
      if( noneof(rem(1:-1)) ) {
         number = div( number , j );
         prln, j;
         ln_prime_factors, number;
         return;
      }
      j = add( j, LNUNIT );
   }
   prln, number;
}

func lnodd( number )
{
   return number(1)%2;
}

func ln5odd( number )
{
   return number(1)%5 ? 1 : 0;
}

func ln3odd( number )
{
   return sum(number(1:-1))%3 ? 1 : 0;
}

func ln7odd( number )
{
   return sum(number(1:-1)*R7)%7 ? 1 : 0;
}

func ln11odd( number )
{
   return sum(number(1:-1)*R11)%11 ? 1 : 0;
}

func ln13odd( number )
{
   return sum(number(1:-1)*R13)%13 ? 1 : 0;
}

func lnsqrt( number, &rem )
{
   if( noneof(number-LNZERO) ) return number;
   if( noneof(number-LNUNIT) ) return number;

   // first guess for sqrt(number)
   lnx = dble2ln(sqrt(ln2dble(number)));
   lnx2 = mul(lnx,lnx);
   lnxt2 = mul(lnx,LNTWO);
   lnxp1 = add(lnx,LNUNIT);
   nmx2 = sub(number,lnx2);
   // start iteration when number >= (x+1)^2 or x^2 > number
   //                      x is too small        x is too large
   while( ln_ge( number, mul(lnxp1,lnxp1)) || ln_gt( lnx2, number) ) {
      // first approximation to adjustment
      eps = div( nmx2, lnxt2);
      // we cannot accept eps == zero since lnx MUST be adjusted
      // see if 1 or -1 applies
      if( noneof(eps(1:-1)) ) {
         eps = LNUNIT;
         if( ln_gt( lnx2, number ) ) eps = lnchs( eps );
      }
      lnx = add( lnx, eps );
      lnx2 = mul(lnx,lnx);
      lnxt2 = mul(lnx,LNTWO);
      lnxp1 = add(lnx,LNUNIT);
      nmx2 = sub(number,lnx2);
   }
   rem = nmx2;
   return lnx;
}

func ln_is_prime( number, limit= )
{
   local rem;

   number = any2ln( number );

   // if number <= 2 then it is a prime
   if( ln_ge( LNTWO, number ) ) return 1;
   // test for the smallest primes
   if( ln_eq( number, setln(3) ) ) return 1;
   if( ln_eq( number, setln(5) ) ) return 1;
   if( ln_eq( number, setln(7) ) ) return 1;
   if( ln_eq( number, setln(11) ) ) return 1;
   if( ln_eq( number, setln(13) ) ) return 1;

   // test for the smallest prime divisors
   if(  !lnodd(number) ) return 0;
   if(  !ln5odd(number) ) return 0;
   if(  !ln3odd(number) ) return 0;
   if(  !ln7odd(number) ) return 0;
   if(  !ln11odd(number) ) return 0;
   if(  !ln13odd(number) ) return 0;

   if( typeof(limit) == "string" ) limit = str2ln(limit);
   //+ xnumber = ln2dble( number );
   //+ limit = dble2ln(sqrt(xnumber));
   qlimit = lnsqrt( number );
   if( is_void(limit) ) limit = qlimit;
   if( ln_gt( limit, qlimit ) ) limit = qlimit;
   j = setln(17);
   while( ln_ge( limit, j) ) {
      q = div( number, j, rem );
      if(  noneof(rem(1:-1)) ) return 0;
      j = add( j, LNTWO );
      while( !ln5odd(number) || !ln3odd(number) \
          || !ln7odd(number) || !ln11odd(number) \
          || !ln13odd(number) ) j = add(j, LNTWO);
   }
   return 1;
}

func ln_next_prime( number )
{
   local rem;
   number = any2ln( number );

   n = number;
   if( lnodd(n) ) {  // number is odd
      n = add(n,LNTWO); // add 2
   } else {
      n = add(n,LNUNIT); // add 1 to make odd
   }
   while( !ln_is_prime(n) ) n = add(n, LNTWO);
   return n;
}

func _div( aii, ajj, &rem )
{
   if( ln_gt( ajj, aii ) ) {
      rem = aii;
      return LNZERO;
   }
   if( ln_eq( aii, ajj ) ) {
      rem = LNZERO;
      return LNUNIT;
   }
   if( ln_eq( LNUNIT, ajj ) ) {
      rem = LNZERO;
      return aii;
   }
   iii = aii;
   jjj = ajj;
   dhat = dble2ln(ln2dble(iii)/ln2dble(jjj));
   //+ while( jjj*dhat > iii ) {
   m = mul(jjj,dhat);
   while( ln_gt( m, iii ) ) {
      //+ del = (jjj*dhat - iii)/jjj + 1;
      del = add( _div( sub(m, iii), jjj), LNUNIT );
      dhat = sub( dhat, del);
      m = mul(jjj,dhat);
   }

   m = mul( jjj, add(dhat, LNUNIT) );
   //+ while( jjj*(dhat+1) <= iii ) {
   while( ln_ge( iii, m ) ) {
      //+ del = (iii - jjj*(dhat+1))/jjj + 1;
      del = add( _div( sub( iii, m), jjj ), LNUNIT);
      dhat = add(dhat, del);
      m = mul( jjj, add(dhat, LNUNIT) );
   }

   rem = sub( iii, mul(dhat, jjj));
   return dhat;
}
//---------------------------------------------------
/* Prime search on distributed processors

   Externals: N_PROC
              HOST

*/
HOST = get_env("HOST");
if( HOST == "maxwell" || HOST == "tesla" ) {
   N_PROC = 24;
} else if( HOST == "gauss" || HOST == "node2" ) {
   N_PROC = 8;
} else {
   N_PROC = 2;
}

func ps_next_prime( number, mach= )
{

   n = number;
   if( lnodd(n) ) {  // number is odd
      n = add(n,LNTWO);
   } else {
      n = add(n,LNUNIT);
   }
   while( !ps_is_prime_mm(n,10) ) n = add(n, LNTWO);
   return n;
}

func ps_is_prime( p_in, test= )
/* DOCUMENT res = ps_is_prime( p_in, test= )

   Tests for 'p_in' being a prime. 'p_in' may be array or string
   representation.

*/
{
   local rem;
   extern N_PROC;

   if( typeof(p_in) == "string" ) {
      //+ write,"Mark 1";
      pstr = p_in;
      p = str2ln( p_in );
   } else {
      //+ write,"Mark 2";
      pstr = ln2str( p_in );
      p = p_in;
   }
   write,format="PS_IS_PRIME: testing %s\n", pstr;
   if( !lnodd(p) ) return 0; // even numbers are rejected at once
   if( !ln5odd(p) ) return 0; // multiples of 5 are rejected at once
   if( !ln3odd(p) ) return 0; // multiples of 3 are rejected at once
   if( !ln7odd(p) ) return 0; // multiples of 7 are rejected at once
   if( !ln11odd(p) ) return 0; // multiples of 11 are rejected at once
   if( !ln13odd(p) ) return 0; // multiples of 13 are rejected at once
   q = lnsqrt( p, rem );
   if( noneof(rem(1:-1)) ) return 0;
   if( !lnodd(q) ) q = sub(q,LNUNIT); // make q odd

   // clean up: remove previous flag files
   //+ write,"Cleaning up";
   if( open("stop.flag","r",1) ) remove, "stop.flag";
   for( i = 1; i <= N_PROC; i++ ) {
      s = swrite(format="_%02i.flag", i);
      if( open("ok"+HOST+s,"r",1) ) remove, "ok"+HOST+s;
   }

   d = div( q, N_PROC );
   if( ln_gt( setln(3), d ) ) d = sub( d, LNTWO );
   ps = setln(7);
   for( i = 1; i <= N_PROC; i++ ) {
      pe = add( ps, d );
      if( ln_gt( pe, q ) ) pe = q;
      if( i == N_PROC && ln_gt( q, pe ) ) pe = q;
      if( !lnodd( pe ) ) pe = add( pe, LNUNIT );
      if( test ) {
         write,format="%3i from %s to %s\n", i, ln2str(ps), ln2str(pe);
      } else {
         s = swrite(format="%02i", i);
         f = open("ymac"+HOST+"_"+s+".i","w");
         //+ write,f,format="#include \"idlx.i\"%s\n","";
         write,f,format="#include \"larnum.i\"%s\n","";
         write,f,format="ps_child,%i,\"%s\",\"%s\",\"%s\";\n", i, pstr, ln2str(ps), ln2str(pe);
         write,f,format="quit%s","\n";
         close, f;
         system,"yorick -batch ymac"+HOST+"_"+s+".i &";
      }
      ps = add( pe, LNTWO );
   }
   if( test ) return [];
   // continue until all processes have flagged the result
   // or a stop has occurred
   kount = 0;
   while( ++kount < 72000 ) {
      n_ok = 0;
      if( open("stop.flag","r",1) ) return 0;
      for( i = 1; i <= N_PROC; i++ ) {
         s = swrite(format="%02i", i);
         if( open("ok"+HOST+"_"+s+".flag","r",1) ) n_ok++;
      }
      if( n_ok == N_PROC ) return 1;
      pause,1000;
   }
   write," --> ps_is_prime ended with undetermined result <--";
   return [];
}



func ps_child( n, pstr, psstr, pestr )
/* DOCUMENT res = ps_child( n, pstr, psstr, pestr )

     Test if pstr can be a prime from psstr to pestr
     'n' is the process identification number
     2009-01-12/NJW
*/
{
   local rem;

   p = str2ln( pstr );
   ps = str2ln( psstr );
   pe = str2ln( pestr );
   oknam = "ok"+HOST+swrite(format="_%03i.flag", n);

   kount = 1;
   t = ps;

   while( ln_ge( pe, t ) ) {
      // if any other child process has signalled stop then stop
      if( (++kount)%5 == 0 ) {
         if( ps_stop() ) return 0;
      }
      q = div( p, t, rem );
      if( noneof(rem(1:-1)) ) { // NOT a prime
         f = open("stop.flag","a");
         write,f,format="Working on %s\n", pstr;
         write,f,format="Divisor: %s\nfound by %s in process #%i\n", ln2str(t), HOST, n;
         write,format="Divisor: %s\nfound by %s in process #%i\n", ln2str(t), HOST, n;
         close, f;
         return 0;
      }
      t = add( t, LNTWO );
      while( !ln5odd(t) || !ln3odd(t) || !ln7odd(t) || \
             !ln11odd(t) || !ln13odd(t) ) {
         t = add( t, LNTWO );
      } // avoid multiples of 5, 3, 7, 11, and 13
   }

   write_slist, oknam, [ndate(3),pstr,psstr,pestr];
   return 1;
}

func ps_stop( void )
/* DOCUMENT res = ps_stop( void )
    returns 1 if a stop flag file 'stop.flag' exists in PWD else 0
*/
{
   return open("stop.flag","r",1) ? 1 : 0;
}

func lnpow( n, m )
{
   if( is_scalar(m) ) {
      me = setln(m);
   } else {
      me = m;
   }
   if( noneof(me(1:-1)) ) return LNUNIT;

   if( is_scalar(n) ) {
      nn = setln(n);
   } else {
      nn = n;
   }
   i = LNUNIT;
   while( ln_gt( me, i ) ) {
      nn = mul(nn,n);
      i = add(i, LNUNIT);
   }
//+   for( i = LNUNIT; ln_gt( me, i ); pp, i ) nn = mul(nn,n);
   return nn;
}

func pp( i )
{
   i() = add(i, LNUNIT)();
}

func logsiz( p, expo )
{
   if( is_void(expo) ) {
      return log(ln2dble(p));
   } else {
      return ln2dble(expo) * log(ln2dble(p));
   }
}
%FILE% larnum_xl.i
extern larnum;
/* DOCUMENT ************************************
    Large Numbers as integers represented in long array with
    'LARNUM_size' ordinary elements followed by the sign.

      _adjust( kk )
      _div( aii, ajj, >rem ) // aii >= 0 && ajj > 0
      _ln_gt( ii, jj ) // ii >= 0 && jj >= 0
      _sub( ii, jj ) // ii >= jj >= 0
      add( ii, jj )
      any2ln( arg )
      dble2ln( x )
      div( ii, jj, &rem ) // res*jj + rem = ii
      ln2dble( ii )
      ln2str( ii )
      ln_eq( ii, jj )
      ln_is_prime( n )
      ln_ge( ii, jj )
      ln_gt( ii, jj )
      ln_next_prime( n )
      ln_prime_factors, n
      lnabs( ii )
      lnchs( ii )
      lnodd( ii )  // not a multiple of 2
      ln5odd( ii ) // not a multiple of 5
      ln3odd( ii ) // not a multiple of 3
      ln7odd( ii ) // not a multiple of 7
      ln11odd( ii ) // not a multiple of 11
      ln13odd( ii ) // not a multiple of 13
      lnpow( m, e )
      lnsqrt( number, >rem ) // res^2 + rem = number
      mul( ii, jj )
      pp, i    // simulates the i++ operator
      prln( ii )
      setln( i1, .., sgn= )
      str2ln( str )
      sub( ii, jj )

   2008-12-21/NJW

   NB! Find out how to make sure that
    (0,0,0,0,0,1) == (0,0,0,0,0,-1)

***************************************/
#include "basic.i"
#include "idlx.i"
#include "string.i"

if( is_void(Ncifre) ) Ncifre = 200;

if( sizeof(long) < 8 ) {  // this is probably a 32 bit machine
   B = 10000;
   NDIGITS = 4;
   LARNUM_size = Ncifre/NDIGITS;
   FMTSTR = "%04i";
//--
   R7patt = [1,4,2]; R7 = [];
   n = (LARNUM_size-1)/numberof(R7patt) + 1;
   for(i=1;i<=n;i++) grow,R7,R7patt;
   R7 = R7(1:LARNUM_size);
//--
   R11patt = [1]; R11 = [];
   n = (LARNUM_size-1)/numberof(R11patt) + 1;
   for(i=1;i<=n;i++) grow,R11,R11patt;
   R11 = R11(1:LARNUM_size);
//--
   R13patt = [1,3,9]; R13 = [];
   n = (LARNUM_size-1)/numberof(R13patt) + 1;
   for(i=1;i<=n;i++) grow,R13,R13patt;
   R13 = R13(1:LARNUM_size);
//--
   write,format="Started 32 bit version, NDIGITS = %i, length = %i\n", NDIGITS, LARNUM_size;
} else {   //      this is a 64 bit or higher machine
   B = 1000000000;
   NDIGITS = 9;
   LARNUM_size = Ncifre/NDIGITS;
   FMTSTR = "%09i";
//--
   R7patt = [1,6]; R7 = [];
   n = (LARNUM_size-1)/numberof(R7patt) + 1;
   for(i=1;i<=n;i++) grow,R7,R7patt;
   R7 = R7(1:LARNUM_size);
//--
   R11patt = [1,6]; R11 = [];
   n = (LARNUM_size-1)/numberof(R11patt) + 1;
   for(i=1;i<=n;i++) grow,R11,R11patt;
   R11 = R11(1:LARNUM_size);
//--
   R13patt = [1,12]; R13 = [];
   n = (LARNUM_size-1)/numberof(R13patt) + 1;
   for(i=1;i<=n;i++) grow,R13,R13patt;
   R13 = R13(1:LARNUM_size);
   write,format="Started 64+ bit version, NDIGITS = %i, length = %i\n", NDIGITS, LARNUM_size;
}
dB = double(B);
LNMAX = array(B-1,LARNUM_size+1);
LNMAX(0) = 1;
LNZERO = array(0,LARNUM_size+1);
LNZERO(0) = 1;
LNUNIT = LNZERO;
LNUNIT(1) = 1;
LNTWO = LNZERO;
LNTWO(1) = 2;
HHm = HHd = 0;
write,"Set HHm to 1 to get debugging output for 'mul'";
write,"Set HHd to 1 to get debugging output for '_divx'";

func str2ln( str )
{
   if( !is_number( str ) ) error,"STR2LN got invalid string";
   if( !is_digit( strpart(str, 2:0) ) ) error,"STR2LN got non-integer";
   d1 = strpart(str,1:1);
   if( is_digit(d1) ) {
      sgn = 1;
      body = str;
   } else {
      if( d1 == "+" ) {
         sgn = 1;
         body = strpart(str,2:0);
      } else {
         sgn = -1;
         body = strpart(str,2:0);
      }
   }
   res = LNZERO;
   res(0) = sgn;
   len = strlen(body);
   k = 1;
   while( len > NDIGITS ) {
      res(k++) = atoi(strpart(body,len-NDIGITS+1:len));
      body = strpart(body,1:len-NDIGITS);
      len -= NDIGITS;
   }
   // add last bit - if not zero
   if( len ) res(k) = atoi(body);

   return res;
}

func any2ln( arg )
{
   n = numberof(arg);
   if( n != 1 && n != LARNUM_size+1 ) error,"ANY2LN: Illegal dimension of argument";
   t = typeof(arg);
   if( n == 1 ) {
      if( t == "string" ) {
         return str2ln( arg );
      } else if( t == "double" || t == "float" ) {
         return dble2ln( double(arg) );
      } else if( t == "long" || t == "int" ) {
         return setln( arg );
      } else error,"ANY2LN: Illegal type of argument";
   } else {
      if( t == "long" ) {
         return _adjust( arg );
      } else error,"ANY2LN: Array has illegal type";
   }
}
     
func setln( i1, .., sgn= )
{
   res = array( long, LARNUM_size+1 );
   res(0) = 1; // defaults to positive
   if( !is_void(sgn) ) {
      if( sgn >= 0 ) res(0) = 1;
      if( sgn <  0 ) res(0) = -1;
   }
   i = 1;
   res(1) = abs(i1);
   while( more_args() ) {
      i++;
      res(i) = abs(next_arg());
   }
   return _adjust(res);
}

func lnchs( ii )
{
   res = ii;
   res(0) = -ii(0);
   return res;
}

func _adjust( kk, allow= )
{
   res = kk;
   // adjust all but the last array element
   for( i = 1; i < LARNUM_size; i++ ) {
      d = res(i) / B;
      r = res(i) % B;
      res(i+1) += d;
      res(i) = r;
   }
   // check that last array element has not grown too large
   //   except when keyword 'allow' has been set
   if( allow ) {
      res(LARNUM_size) %= B;
   } else {
      if( res(LARNUM_size) >= B ) error,"_adjust encountered too large number";
   }
   // make sure that sign element is 1 or -1
   if( allof(res(1:-1)==0) ) { // zero abs value
      res(0) = 1;
   } else {
      res(0) = res(0) >= 0 ? 1 : -1;
   }
   return res;
}

func lnabs( ii )
{
   res = ii;
   if( ii(0) < 0 ) res(0) = 1;
   return res;
}

func add( ii, jj )
{
   if( is_scalar(ii) ) {
      iii = setln(abs(ii));
      iii(0) = ii >= 0 ? 1 : -1;
   } else iii = ii;
   if( is_scalar(jj) ) {
      jjj = setln(abs(jj));
      jjj(0) = jj >= 0 ? 1 : -1;
   } else jjj = jj;
   sgnii = iii(0);
   sgnjj = jjj(0);

   if( sgnii > 0 ) {     // ii > 0

      if( sgnjj > 0 ) {
         //+ write,"add case ii > 0 and jj > 0";
         res = iii + jjj;
         return _adjust(res);
      } else { // jj < 0
         //+ write,"add case ii > 0 and jj < 0";
         ajj = lnabs( jjj );
         if( ln_ge( iii, ajj ) ) {
            //+ write,"add subcase ii > ajj";
            res = _sub( iii, ajj );
         } else {
            //+ write,"add subcase ajj > ii";
            res = _sub( ajj, iii );
            res(0) = -1;
         }
         return res;
      }

   } else { // ii < 0

      aii = lnabs( iii );

      if( sgnjj > 0 ) {
         //+ write,"add case ii < 0 and jj > 0";
         if( ln_ge( jjj, aii ) ) {
            //+ write,"add subcase jj > aii";
            res = _sub( jjj, aii );
         } else {
            //+ write,"add subcase aii > jj";
            res = _sub( aii, jjj );
            res(0) = -1;
         }
         return res;

      } else { // jj < 0

         //+ write,"add case ii < 0 and jj < 0";
         ajj = lnabs(jjj);
         res = aii + ajj;
         res(0) = -1;
         return _adjust(res);
      }

   }
   error,"ADD: should never come here";
}

func sub( ii, jj )
{
   iii = is_scalar(ii) ? setln(ii) : ii;
   jjj = is_scalar(jj) ? setln(jj) : jj;
   jjj(0) = -jjj(0); // change sign and add
   return add( iii, jjj );
}

func _sub( ii, jj ) // ii >= jj >= 0
{

   if( ii(0) != 1 || jj(0) != 1 ) error,"_sub got negative number";
   if( ln_gt(jj,ii) ) error,"_sub jj > ii";

   jj_compl = LNMAX - jj;
   res = ii + jj_compl;
   res(1)++;
   res(0) = 1;
   return _adjust( res, allow=1 );
}

func mul( ii, jj )
{
   if( is_scalar(ii) ) {
      iii = setln(abs(ii));
      iii(0) = ii >= 0 ? 1 : -1;
   } else iii = ii;
   if( is_scalar(jj) ) {
      jjj = setln(abs(jj));
      jjj(0) = jj >= 0 ? 1 : -1;
   } else jjj = jj;

   kk = array(long, LARNUM_size+1 );
   for( k = 1; k <= LARNUM_size; k++ ) {
      if(HHm)write,format="mul report a k = %i\n", k;
      s = 0;
      s_overshoot = 0;
      kmax = k+1;
// NB changes of 2010-03-12
      for( i = 1; i < kmax; i++ ) {
         j = kmax - i;
         s += iii(i) * jjj(j);
         if(HHm)write,format="   mul report b: i = %i, s = %i\n", i, s;
         if(HHm)write,format="       iii(%i) = %i, jjj(%i) = %i\n",
                  i, iii(i), j, jjj(j);
         if( s >= B ) {
            n = s/B;
            r = s%B;
            s = r;
            s_overshoot += n;
            if(HHm)write,format="      mul report c: s = %i, s_over = %i\n", s, s_overshoot;
         }
      }
      kk(k) += s;
      if( s_overshoot ) {
         if( k == LARNUM_size ) error,"Overshoot in 'mul'";
         kk(k+1) += s_overshoot;
      }
   }
   kk(0) = iii(0)*jjj(0);
   return _adjust( kk );
}

func prln( file, ii )
{
   if( typeof(file) == "text_stream" ) {
      f = 1;
   } else {
      f = 0;
      ii = file;
   }
   sgn = ii(0) >= 0 ? "+" : "-";
   if(f)write,file,format="%s", sgn;
   if(!f)write,format="%s", sgn;
   first = 1;
   j = LARNUM_size;
   while( ii(j) == 0 && j > 0 ) j--; // find first non-zero element
   if( j == 0 ) write,format="%i",0;
   for( i = j; i >= 1; i-- ) {
      if( first ) {
         if(!f)write,format="%i", ii(i);
         if(f)write,file,format="%i", ii(i);
         first = 0;
      } else {
         if(!f)write,format=FMTSTR, ii(i);
         if(f)write,file,format=FMTSTR, ii(i);
      }
   }
   if(!f)write,format="%s\n","";
   if(f)write,file,format="%s\n","";
}

func ln2str( ii, nos= )
{
   sgn = ii(0) >= 0 ? "+" : "-";
   if(nos) sgn="";
   res = sgn;
   first = 1;
   j = LARNUM_size;
   while( ii(j) == 0 && j > 0 ) j--; // find first non-zero element
   if( j == 0 ) return sgn+"0";
   for( i = j; i >= 1; i-- ) {
      if( first ) {
         res = res + swrite(format="%i", ii(j));
         first = 0;
      } else {
         res = res + swrite(format=FMTSTR, ii(i));
      }
   }
   return res;
}

func ln2dble( ii )
{
   s = double(ii(LARNUM_size));
   for( i = LARNUM_size-1; i >= 1; i-- ) {
      s = ii(i) + dB*s;
   }
   return s*ii(LARNUM_size+1);
}

func ln_eq( ii, jj )
{
   return allof( ii == jj );
}

func ln_gt( ii, jj )
{
   sgnii = ii(0);
   sgnjj = jj(0);

   if( sgnii > 0 ) { // ii > 0

      if( sgnjj > 0 ) {
         return _ln_gt( ii, jj );
      } else { // jj < 0
         return 1;
      }

   } else { // ii < 0

      if( sgnjj > 0 ) {
         return 0;
      } else { // jj < 0
         return _ln_gt( jj, ii );
      }

   }

}

func _ln_gt( ii, jj ) // ii >= 0 && jj >= 0
      // or compare absolute values
{
   for( i = LARNUM_size; i >= 1; i-- ) {
      if( ii(i) > jj(i) ) return 1;
      if( ii(i) < jj(i) ) return 0;
   }
   return 0;
}

func ln_ge( ii, jj )
{
   if( allof( ii == jj ) ) return 1;
   return ln_gt( ii, jj );
}

func div( ii, jj, &rem )
/* DOCUMENT res = div( ii, jj, >rem )

   returns res = ii/jj with sign sgn(ii)*sgn(jj) and remainder
   'rem' so that res * jj + rem = ii
*/
{
   if( is_scalar(ii) ) {
      iii = setln(abs(ii));
      iii(0) = ii >= 0 ? 1 : -1;
   } else iii = ii;
   if( is_scalar(jj) ) {
      jjj = setln(abs(jj));
      jjj(0) = jj >= 0 ? 1 : -1;
   } else jjj = jj;
   sgnii = iii(0);
   sgnjj = jjj(0);
   sgnres = sgnii * sgnjj;
   aii = lnabs(iii);
   ajj = lnabs(jjj);

   if( ln_eq( aii, ajj ) ) {
      rem = setln(0);
      return setln(1,sgn=sgnres);
   }
   if( ln_gt( ajj, aii ) ) {
      rem = aii;
      return setln(0);
   }

   quotient = _div( aii, ajj, rem );
   if( anyof(quotient(1:-1)) ) quotient(0) = sgnres;
   return quotient;
}

func dble2ln( x )
{
   res = array(long, LARNUM_size+1 );

   if( x < 0.0 ) {
      res(0) = -1;
      x = -x; // continue with absolute value
   } else res(0) = 1;

   if( x < 0.5 ) return res;
   if( x < 1.5 ) {
      res(1) = 1;
      return res;
   }

   i = 0;
   do {
      d = x / dB;
      if( d < dB ) {
         ld = long(d);
         rem = x - ld * dB;
      } else {
         ld = d;
         rem = 0.0;
      }
      res(++i) = rem;
      x = double(ld);
   } while( ld > 0 && i < LARNUM_size );

   return res;
}

func ln_prime_factors( number )
{
   local rem;

   number = any2ln( number );

   limit = lnsqrt( number );
   j = setln(2);
   while( ln_ge( limit, j ) ) {
      q = div( number, j, rem );
      if( noneof(rem(1:-1)) ) {
         number = div( number , j );
         prln, j;
         ln_prime_factors, number;
         return;
      }
      j = add( j, LNUNIT );
   }
   prln, number;
}

func lnodd( number )
{
   return number(1)%2;
}

func ln5odd( number )
{
   return number(1)%5 ? 1 : 0;
}

func ln3odd( number )
{
   return sum(number(1:-1))%3 ? 1 : 0;
}

func ln7odd( number )
{
   return sum(number(1:-1)*R7)%7 ? 1 : 0;
}

func ln11odd( number )
{
   return sum(number(1:-1)*R11)%11 ? 1 : 0;
}

func ln13odd( number )
{
   return sum(number(1:-1)*R13)%13 ? 1 : 0;
}

func lnsqrt( number, &rem )
{
   if( noneof(number-LNZERO) ) return number;
   if( noneof(number-LNUNIT) ) return number;

   // first guess for sqrt(number)
   lnx = dble2ln(sqrt(ln2dble(number)));
   lnx2 = mul(lnx,lnx);
   lnxt2 = mul(lnx,LNTWO);
   lnxp1 = add(lnx,LNUNIT);
   nmx2 = sub(number,lnx2);
   // start iteration when number >= (x+1)^2 or x^2 > number
   //                      x is too small        x is too large
   while( ln_ge( number, mul(lnxp1,lnxp1)) || ln_gt( lnx2, number) ) {
      // first approximation to adjustment
      eps = div( nmx2, lnxt2);
      // we cannot accept eps == zero since lnx MUST be adjusted
      // see if 1 or -1 applies
      if( noneof(eps(1:-1)) ) {
         eps = LNUNIT;
         if( ln_gt( lnx2, number ) ) eps = lnchs( eps );
      }
      lnx = add( lnx, eps );
      lnx2 = mul(lnx,lnx);
      lnxt2 = mul(lnx,LNTWO);
      lnxp1 = add(lnx,LNUNIT);
      nmx2 = sub(number,lnx2);
   }
   rem = nmx2;
   return lnx;
}

func ln_is_prime( number, limit= )
{
   local rem;

   number = any2ln( number );

   // if number <= 2 then it is a prime
   if( ln_ge( LNTWO, number ) ) return 1;
   // test for the smallest primes
   if( ln_eq( number, setln(3) ) ) return 1;
   if( ln_eq( number, setln(5) ) ) return 1;
   if( ln_eq( number, setln(7) ) ) return 1;
   if( ln_eq( number, setln(11) ) ) return 1;
   if( ln_eq( number, setln(13) ) ) return 1;

   // test for the smallest prime divisors
   if(  !lnodd(number) ) return 0;
   if(  !ln5odd(number) ) return 0;
   if(  !ln3odd(number) ) return 0;
   if(  !ln7odd(number) ) return 0;
   if(  !ln11odd(number) ) return 0;
   if(  !ln13odd(number) ) return 0;

   if( typeof(limit) == "string" ) limit = str2ln(limit);
   //+ xnumber = ln2dble( number );
   //+ limit = dble2ln(sqrt(xnumber));
   qlimit = lnsqrt( number );
   if( is_void(limit) ) limit = qlimit;
   if( ln_gt( limit, qlimit ) ) limit = qlimit;
   j = setln(17);
   while( ln_ge( limit, j) ) {
      q = div( number, j, rem );
      if(  noneof(rem(1:-1)) ) return 0;
      j = add( j, LNTWO );
      while( !ln5odd(number) || !ln3odd(number) \
          || !ln7odd(number) || !ln11odd(number) \
          || !ln13odd(number) ) j = add(j, LNTWO);
   }
   return 1;
}

func ln_next_prime( number )
{
   local rem;
   number = any2ln( number );

   n = number;
   if( lnodd(n) ) {  // number is odd
      n = add(n,LNTWO); // add 2
   } else {
      n = add(n,LNUNIT); // add 1 to make odd
   }
   while( !ln_is_prime(n) ) n = add(n, LNTWO);
   return n;
}

func _divsn( aii, ajj, &rem )
// divide by a shortnumber
{
   if( numberof(ajj) != 1 || typeof(ajj) != "long" ) error, "_divsn input type error 1";
   if( numberof(aii) != LARNUM_size+1 || typeof(aii) != "long" ) \
                         error, "_divsn input type error 2";

   iii = aii;
   kk = LNZERO;
   for( i = LARNUM_size; i > 0; i-- ) {
      q = iii(i) / ajj;
      r = iii(i) % ajj;
      kk(i) += q;
      if(i>1) iii(i-1) += r*B;
   }
   rem = LNZERO;
   rem(1) = r;
   return kk;
}

func numdig( x )
{
   res = 1;
   c = 10;
   while( x >= c ) {
      res++;
      c *= 10;
   }
   return res;
}

func _divx( aii, ajj, &rem )
{
   if( ln_gt( ajj, aii ) ) {
      rem = aii;
      return LNZERO;
   }
   if( ln_eq( aii, ajj ) ) {
      rem = LNZERO;
      return LNUNIT;
   }
   if( ln_eq( LNUNIT, ajj ) ) {
      rem = LNZERO;
      return aii;
   }
   iii = aii;
   jjj = ajj;

   // we know that iii > jjj
   // find largest index with non-zero value
   wi = where(iii(1:-1))(0);
   wj = where(jjj(1:-1))(0);
   if(HHd)write,format="_divx report a: wi = %i, wj = %i\n", wi,wj;
   if(HHd)write,format="        (1)     iii(%i) = %i, jjj(%i) = %i\n", \
                          wi,iii(wi),wj,jjj(wj);
   if( jjj(wj) > iii(wi) ) { // adjust
      iii(wi-1) += B*iii(wi);
      iii(wi) = 0;
      wi--;
   }
   if(HHd)write,format="        (2)     iii(%i) = %i, jjj(%i) = %i\n", \
                          wi,iii(wi),wj,jjj(wj);
   kk = array(long,LARNUM_size+1); kk(0) = 1;

   // first (wild) guess:
   wk = wi - wj + 1;
   kk(wk) = iii(wi)/jjj(wj);
   if(HHd)prln,kk;

   // return to original representation of 'iii'
   iii = _adjust( iii );

   m = mul( kk, jjj );

   if( ln_eq( m, iii ) ) {
      // we're done!
      rem = LNZERO;
      return kk;
   }
   if( ln_gt( m, iii ) ) { // kk is too large
      kkm = kk;
      do {
         wkm = where(kkm(1:-1))(0);
         kkm(wkm) -= 10^(numdig(kkm(wkm))-1);
         kkm = _adjust(kkm);
         mm = mul( kkm, jjj );
      } while( ln_ge( mm, iii ) );

      // now kk is too large and kkm is too small
      // swap the numbers so that 'kk' becomes the smaller number
      x = kkm;
      kkm = kk;
      kk = x;
   } else {                // kk is too small
      kkm = kk;
      do {
         wkm = where(kkm(1:-1))(0);
         kkm(wkm) += 10^(numdig(kkm(wkm))-1);
         kkm = _adjust(kkm);
         mm = mul( kkm, jjj );
      } while( ln_gt( iii, mm ) );
   }
   kkm = _adjust(kkm);

   // now kkm is too large and kk is too small

   do {

      kks = add(kk,kkm);
      kks = _divsn( kks, 2, rem );

      if( ln_gt( mul( kks, jjj ), iii ) ) {
         // kks is too large so readjust the upper limit:
         kkm = kks;
      } else {
         // kks is too small so readjust the lower limit:
         kk = kks;
      }

      adif = sub( kkm, kk );
      if(HHd)write,format="kk=%s  kks=%s  kkm=%s adif=%s\n", \
            ln2str(kk),ln2str(kks),ln2str(kkm), ln2str(adif);

   } while( ln_gt( adif, LNUNIT ) );

   rem = sub( iii, mul(kk,jjj) );
   return kk;

}

func _divy( aii, ajj, &rem )
{
   if( ln_gt( ajj, aii ) ) {
      rem = aii;
      return LNZERO;
   }
   if( ln_eq( aii, ajj ) ) {
      rem = LNZERO;
      return LNUNIT;
   }
   if( ln_eq( LNUNIT, ajj ) ) {
      rem = LNZERO;
      return aii;
   }
   iii = aii;
   jjj = ajj;

   // we know that iii > jjj
   // find largest index with non-zero value
   wi = where(iii(1:-1))(0);
   wj = where(jjj(1:-1))(0);
   if(HHd)write,format="_divy report a: wi = %i, wj = %i\n", wi,wj;
   if(HHd)write,format="        (1)     iii(%i) = %i, jjj(%i) = %i\n", \
                          wi,iii(wi),wj,jjj(wj);

   qhi = _divsn( iii, jjj(wj) );
   qhi(1:-1) = shift(qhi(1:-1),wj-1);
   qhi(1-wj:-1) = 0;

   qlo = _divsn( iii, jjj(wj)+1 );
   qlo(1:-1) = shift(qlo(1:-1),wj-1);
   qlo(1-wj:-1) = 0;

   if(HHd)write,format="qlo*j=%s, iii=%s, qhi*j=%s\n", \
       ln2str(mul(qlo,jjj)), ln2str(iii), ln2str(mul(qhi,jjj));

   // now qhi is too large and qlo is too small

   do {

      kks = add(qlo,qhi);
      kks = _divsn( kks, 2, rem );

      if( ln_gt( mul( kks, jjj ), iii ) ) {
         // kks is too large so readjust the upper limit:
         qhi = kks;
      } else {
         // kks is too small so readjust the lower limit:
         qlo = kks;
      }

      adif = sub( qhi, qlo );
      if(HHd)write,format="qlo=%s  kks=%s  qhi=%s adif=%s\n", \
            ln2str(qlo),ln2str(kks),ln2str(qhi), ln2str(adif);

   } while( ln_gt( adif, LNUNIT ) );

   rem = sub( iii, mul(qlo,jjj) );
   return qlo;

}

func _div( aii, ajj, &rem )
{
   if( ln_gt( ajj, aii ) ) {
      rem = aii;
      return LNZERO;
   }
   if( ln_eq( aii, ajj ) ) {
      rem = LNZERO;
      return LNUNIT;
   }
   if( ln_eq( LNUNIT, ajj ) ) {
      rem = LNZERO;
      return aii;
   }
   iii = aii;
   jjj = ajj;
   dhat = dble2ln(ln2dble(iii)/ln2dble(jjj));
   //+ while( jjj*dhat > iii ) {
   m = mul(jjj,dhat);
   while( ln_gt( m, iii ) ) {
      //+ del = (jjj*dhat - iii)/jjj + 1;
      del = add( _div( sub(m, iii), jjj), LNUNIT );
      dhat = sub( dhat, del);
      m = mul(jjj,dhat);
   }

   m = mul( jjj, add(dhat, LNUNIT) );
   //+ while( jjj*(dhat+1) <= iii ) {
   while( ln_ge( iii, m ) ) {
      //+ del = (iii - jjj*(dhat+1))/jjj + 1;
      del = add( _div( sub( iii, m), jjj ), LNUNIT);
      dhat = add(dhat, del);
      m = mul( jjj, add(dhat, LNUNIT) );
   }

   rem = sub( iii, mul(dhat, jjj));
   return dhat;
}
//---------------------------------------------------
/* Prime search on distributed processors

   Externals: N_PROC
              HOST

*/
HOST = get_env("HOST");
if( HOST == "maxwell" || HOST == "tesla" ) {
   N_PROC = 24;
} else if( HOST == "gauss" || HOST == "node2" ) {
   N_PROC = 8;
} else {
   N_PROC = 2;
}

func ps_next_prime( number, mach= )
{

   n = number;
   if( lnodd(n) ) {  // number is odd
      n = add(n,LNTWO);
   } else {
      n = add(n,LNUNIT);
   }
   while( !ps_is_prime_mm(n,10) ) n = add(n, LNTWO);
   return n;
}

func ps_is_prime( p_in, test= )
/* DOCUMENT res = ps_is_prime( p_in, test= )

   Tests for 'p_in' being a prime. 'p_in' may be array or string
   representation.

*/
{
   local rem;
   extern N_PROC;

   if( typeof(p_in) == "string" ) {
      //+ write,"Mark 1";
      pstr = p_in;
      p = str2ln( p_in );
   } else {
      //+ write,"Mark 2";
      pstr = ln2str( p_in );
      p = p_in;
   }
   write,format="PS_IS_PRIME: testing %s\n", pstr;
   if( !lnodd(p) ) return 0; // even numbers are rejected at once
   if( !ln5odd(p) ) return 0; // multiples of 5 are rejected at once
   if( !ln3odd(p) ) return 0; // multiples of 3 are rejected at once
   if( !ln7odd(p) ) return 0; // multiples of 7 are rejected at once
   if( !ln11odd(p) ) return 0; // multiples of 11 are rejected at once
   if( !ln13odd(p) ) return 0; // multiples of 13 are rejected at once
   q = lnsqrt( p, rem );
   if( noneof(rem(1:-1)) ) return 0;
   if( !lnodd(q) ) q = sub(q,LNUNIT); // make q odd

   // clean up: remove previous flag files
   //+ write,"Cleaning up";
   if( open("stop.flag","r",1) ) remove, "stop.flag";
   for( i = 1; i <= N_PROC; i++ ) {
      s = swrite(format="_%02i.flag", i);
      if( open("ok"+HOST+s,"r",1) ) remove, "ok"+HOST+s;
   }

   d = div( q, N_PROC );
   if( ln_gt( setln(3), d ) ) d = sub( d, LNTWO );
   ps = setln(7);
   for( i = 1; i <= N_PROC; i++ ) {
      pe = add( ps, d );
      if( ln_gt( pe, q ) ) pe = q;
      if( i == N_PROC && ln_gt( q, pe ) ) pe = q;
      if( !lnodd( pe ) ) pe = add( pe, LNUNIT );
      if( test ) {
         write,format="%3i from %s to %s\n", i, ln2str(ps), ln2str(pe);
      } else {
         s = swrite(format="%02i", i);
         f = open("ymac"+HOST+"_"+s+".i","w");
         //+ write,f,format="#include \"idlx.i\"%s\n","";
         write,f,format="#include \"larnum.i\"%s\n","";
         write,f,format="ps_child,%i,\"%s\",\"%s\",\"%s\";\n", i, pstr, ln2str(ps), ln2str(pe);
         write,f,format="quit%s","\n";
         close, f;
         system,"yorick -batch ymac"+HOST+"_"+s+".i &";
      }
      ps = add( pe, LNTWO );
   }
   if( test ) return [];
   // continue until all processes have flagged the result
   // or a stop has occurred
   kount = 0;
   while( ++kount < 72000 ) {
      n_ok = 0;
      if( open("stop.flag","r",1) ) return 0;
      for( i = 1; i <= N_PROC; i++ ) {
         s = swrite(format="%02i", i);
         if( open("ok"+HOST+"_"+s+".flag","r",1) ) n_ok++;
      }
      if( n_ok == N_PROC ) return 1;
      pause,1000;
   }
   write," --> ps_is_prime ended with undetermined result <--";
   return [];
}



func ps_child( n, pstr, psstr, pestr )
/* DOCUMENT res = ps_child( n, pstr, psstr, pestr )

     Test if pstr can be a prime from psstr to pestr
     'n' is the process identification number
     2009-01-12/NJW
*/
{
   local rem;

   p = str2ln( pstr );
   ps = str2ln( psstr );
   pe = str2ln( pestr );
   oknam = "ok"+HOST+swrite(format="_%03i.flag", n);

   kount = 1;
   t = ps;

   while( ln_ge( pe, t ) ) {
      // if any other child process has signalled stop then stop
      if( (++kount)%5 == 0 ) {
         if( ps_stop() ) return 0;
      }
      q = div( p, t, rem );
      if( noneof(rem(1:-1)) ) { // NOT a prime
         f = open("stop.flag","a");
         write,f,format="Working on %s\n", pstr;
         write,f,format="Divisor: %s\nfound by %s in process #%i\n", ln2str(t), HOST, n;
         write,format="Divisor: %s\nfound by %s in process #%i\n", ln2str(t), HOST, n;
         close, f;
         return 0;
      }
      t = add( t, LNTWO );
      while( !ln5odd(t) || !ln3odd(t) || !ln7odd(t) || \
             !ln11odd(t) || !ln13odd(t) ) {
         t = add( t, LNTWO );
      } // avoid multiples of 5, 3, 7, 11, and 13
   }

   write_slist, oknam, [ndate(3),pstr,psstr,pestr];
   return 1;
}

func ps_stop( void )
/* DOCUMENT res = ps_stop( void )
    returns 1 if a stop flag file 'stop.flag' exists in PWD else 0
*/
{
   return open("stop.flag","r",1) ? 1 : 0;
}

func lnpow( n, m )
{
   if( is_scalar(m) ) {
      me = setln(m);
   } else {
      me = m;
   }
   if( noneof(me(1:-1)) ) return LNUNIT;

   if( is_scalar(n) ) {
      nn = setln(n);
   } else {
      nn = n;
   }
   i = LNUNIT;
   while( ln_gt( me, i ) ) {
      nn = mul(nn,n);
      i = add(i, LNUNIT);
   }
//+   for( i = LNUNIT; ln_gt( me, i ); pp, i ) nn = mul(nn,n);
   return nn;
}

func pp( i )
{
   i() = add(i, LNUNIT)();
}

func logsiz( p, expo )
{
   if( is_void(expo) ) {
      return log(ln2dble(p));
   } else {
      return ln2dble(expo) * log(ln2dble(p));
   }
}
%FILE% letter_count.i
func letter_count( filename )
{
   stream = open("asdf","w");
   text = rdfile(filename);
   ntext = numberof(text);
   nlet = array(long,26);
   for( i = 1; i <= ntext; i++ ) {
      c = *pointer(text(i));
      wlc = where( c >= 97 & c <= 122 );
      wuc = where( c >= 65 & c <= 90 );
      if( numberof(wuc) ) {
         c(wuc) += 32;
         if( numberof(wlc) ) {
            grow, wlc, wuc;
         } else wlc = wuc;
      }
      nwlc = numberof(wlc);
      for( j = 1; j <= nwlc; j++ ) nlet(c(wlc(j))-96)++;
   }
   for( i = 1; i <= 26; i++ ) {
      write,format="%c %6i\n", i+96, nlet(i);
      write,stream,format="%6i,\n", i+96, nlet(i)/10;
   }
   close, stream;
}
%FILE% levmar.i
/*
   Several people have asked about non-linear fitting routines.
   Here is my own rough cut at such a routine.  See also lmfit.i
   by Eric Thiebaut.  Obviously I have some reservations about
   whether mine actually works; if it really is broken and you
   fix it, let me know.  I thought it worthwhile to include both
   my very stripped down interface and Eric's very complicated one
   here; probably something intermediate (perhaps with hook functions
   to optionally provide some of the more recondite bells and whistles)
   would be optimal.
   -- Dave Munro
 */

func levmar(x, y, y_and_dyda, a, weight=)
/* DOCUMENT a= levmar(y, x, y_and_dyda, a0)

***WARNING****
I think this function is broken.  It works in the au_refl_coeffs
routine because it bails out after zero or one iterations, basically
leaving the (very good) initial guess unchanged.
***WARNING****

     Perform a non-linear least squares fit to data vectors (X,Y)
     using the Levenberg-Marquardt method.
     Y_AND_DYDA must be defined as:
          func Y_AND_DYDA (a, x, &dyda)
     returning both the function value y(x) and derivative dyda(x).
     The input vector a is the list of parameters to be minimized;
     A0 is the initial guess for these parameters.  If a vector x
     is passed to this function, it must return an equal length y,
     and a numberof(a)-by-numberof(x) array of dyda.

     If the weight= keyword is present, it should be a list of
     sigma values for the Y data.
 */
{
  local dyda;
  dkl= array(0., numberof(a), numberof(a));
  dkl(1:numberof(dkl):numberof(a)+1)= 1.0;
  sig2= 1.0/(is_void(weight)? array(1.,numberof(y)) : weight*weight);
  lambda= 0.001;

  for (i=0 ; i<1000 ; ++i) {
    dya= y - y_and_dyda(a, x, dyda);
    chi2= sum(sig2*dya*dya);
    akl= sig2(-,)*dyda;
    bk= akl(,+)*dya(+);
    akl= (akl(,+)*dyda(,+));

    for (;;) {
      da= LUsolve(akl*(1.+lambda*dkl),bk);
      dya= y - y_and_dyda(a+da, x, dyda);
      chi2t= sum(sig2*dya*dya);
      if (chi2t < chi2) break;
      /* step failed, try again */
      lambda*= 10.;
    }

    /* step succeeded, take it */
    a+= da;

    /* check for convergence */
    if (abs(chi2t-chi2)<0.1 || abs(chi2t-chi2)<1.e-3*chi2t) break;
    lambda*= 0.1;
  }
  if (i>=1000) error, "failed to converge after 1000 iterations";

  return a;
}
%FILE% list2lst.i
/* Function list2lst */

func list2lst( swid_list )
/* DOCUMENT lst = list2lst( swid_list )

*/
{
   n = numberof(swid_list);
   lst_list = array(string,n);
   for( i = 1; i <= n; i++ ) {
      lst_list(i) = "./scw/"+strpart(swid_list(i),1:4)+"/"+swid_list(i)+".001/swg.fits[1]";
   }
   return lst_list;
}
%FILE% list_isdc_cons_pointings.i
/* Function list_isdc_cons_pointings */

func list_isdc_cons_pointings( rev, datadir=, outdir=, chat= )
/* DOCUMENT list_isdc_cons_pointings, rev, datadir=, outdir=, chat=

    2002-11-20/NJW

    2003-04-10/NJW Updated with JMX1 & 2 modes
    2003-04-22/NJW Updated by removing keyword "data"
    2003-05-27/NJW Updated to produce both files at once
                   and directly in /r2/jemx/pointings
    2003-08-06/NJW Updated with keywords to define input directory
                   and/or output directory
    2006-01-26/NJW Updated with keyword "chat" for( debugging output
    2006-10-04/NJW Translated to Yorick and adapted to ISDC/arc (swg.fits)
    2008-01-13/NJW Skipped writing the 'd' file

*/
{
   require, "jfits.i";
   require, "mfits.i";
   require, "idlx.i";
   require, "jemx.i";

   revstr = swrite(format="%4.4i", toint(rev) );

   // Define default directory for( input data

   datapath = "/isdc/arc/rev_2/scw/"+revstr;
   if( numberof(datadir) ) datapath = rem_slash(datadir);

   if( ! file_test( datapath ) ) {
      write,format="No such directory: %s\n", datapath;
      return;
   }
   datapath = app_slash( datapath );

   if( chat ) {
      write,"----------------------------------------";
      write,format="Searching in: %s\n",datapath;
   }

   mode_arr = ["F","H","R","T","S","*"];
   ra_scx_prev = 0.0;
   dec_scx_prev = 0.0;
   first = 1;
   prev_empty = 0;

   // Define default directory for output data

   outpath = "/unsaved_data/jemx/westerga/";

   if( numberof(outdir) ) outpath = app_slash(outdir);


   // Save current directory

   //curdir = getenv("PWD")
   curdir = get_cwd();

   cd,datapath;

   dir_list = file_search( revstr+"*", datapath );
   ndir_list = numberof( dir_list );
   if( ndir_list == 0 ) {
      write,"No data directories found";
      return;
   }

   swgfile_list = [];
   for( idir = 1; idir <= ndir_list; idir++ ) {
      if( file_test( dir_list(idir)+"/swg.fits") ) {
         grow, swgfile_list, dir_list(idir)+"/swg.fits";
      }
   }

   nswgfile_list = numberof(swgfile_list);

   if( chat ) {
      write,format="%i swg.fits files have been found\n", nswgfile_list;
   }
   if( nswgfile_list == 0 ) {
      write,"No swg.fits files found";
      return;
   }


   outname_p = outpath + "pointings_"+revstr+"p.dat";

   if( chat ) {
      write,format="The output is directed to: %s\n", outname_p;
   }

   // Remove files if( they exist already

   if( file_test(outname_p) ) system,"/bin/rm "+outname_p;

   // First part: produce the list of all pointings, slews, and others

   lun_p = open(outname_p,"w");

   // Short header in output file

   write,lun_p,format="%s       List of pointings with CONS ISDC JEMX swg.fits data\n","//";
   write,lun_p,format="%s\n","//";
   write,lun_p,format="%s  Extracted with /home/isdc_guest/westerga/yorick/list_isdc_cons_pointings.i\n","//";
   write,lun_p,format="//     %s\n", ndate(3);
   write,lun_p,format="%s\n","//";
   write,lun_p,format="%s  SWID          RA      DEC    POSANGLE      UT first        IJD     TELAPSE MODE12\n","//";
   write,lun_p,format="%s              (deg)    (deg)    (deg)          pack         (day)     (s)\n","//";
   write,lun_p,format="%s\n","//";




//  sort the list to get chronology right

   swgfile_list = swgfile_list(sort(swgfile_list));

   write_slist,"/home/isdc_guest/westerga/yorick/swgfile_list_orig.txt", swgfile_list;

//  Clean away lower version numbers for identical SWIDs

   pick_swid_str, swgfile_list, swid_aux;
   w = array(0, nswgfile_list);
   for( i = 1; i < nswgfile_list; i++ ) {
      if( swid_aux(i) != swid_aux(i+1) ) w(i) = 1;
   }
   w = where(w);
   swgfile_list = swgfile_list(w);
   nswgfile_list = numberof(w);
   if( chat ) {
      write,format="%i swg.fits files have been kept with highest version\n", nswgfile_list;
   }


//  Loop through list to extract the pointing information

   for( i = 1; i <= nswgfile_list; i++ ) {
      swgfile = swgfile_list(i);
      pick_swid_str, swgfile, swid;
      swid = swid(1);
      hdr = headfits(swgfile+"+1", nocheck=1);
      ra_scx = fits_get(hdr,"RA_SCX");
      dec_scx = fits_get(hdr,"DEC_SCX");
      posangle = fits_get(hdr,"POSANGLE");
      ertfirst = fits_get(hdr,"ERTFIRST");
      ijd = dattim2ijd( ertfirst );
      tstart = fits_get(hdr,"TSTART");
      tstop  = fits_get(hdr,"TSTOP");
      telapse  = fits_get(hdr,"TELAPSE");
      jmx1mode = fits_get(hdr,"JMX1MODE");
      index1 = jmx1mode - 41;
      if( index1  <  0 || index1  >  4 ) index1 = 5;
      jmx2mode = fits_get(hdr,"JMX2MODE");
      index2 = jmx2mode - 41;
      if( index2  <  0 || index2  >  4 ) index2 = 5;
      if( ! first ) {
         dist = arcdist(ra_scx, dec_scx, ra_scx_prev, dec_scx_prev);
         if( dist  >  3.0 ) {
            if( ! prev_empty ) {
               write,lun_p,format="%s\n","";
               prev_empty = 1
            }
         }
      }
      first = 0;
      ra_scx_prev = ra_scx;
      dec_scx_prev = dec_scx;
      if( strpart(swid,12:12)  ==  "0" ) {
         write,lun_p, \
             format="%12s%10.4f%9.4f%9.3f%21s%10.4f%7.0f  %1s  %1s\n", \
             swid,ra_scx,dec_scx,posangle,ertfirst,ijd,telapse, \
             mode_arr(index1+1), mode_arr(index2+1);
         prev_empty = 0;
      }
   }

   close,lun_p;

   // cd to original directory

   cd, curdir;

   // Change write permission to include group

   system,"chmod 664 "+outname_p;

}
%FILE% list_pointings.i
/* Function list_pointings */

func list_pointings( rev, datadir=, outdir=, icons=, ucons=, inrt=, unrt=, mktt=, \
              fit=, pnt=, chat= )
/* DOCUMENT list_pointings, rev, datadir=, outdir=, icons=, ucons=, inrt=,
              unrt=, mktt=, fit=, pnt=, chat=

    Produce the ASCII pointing files:  pointings_RRRRp.dat
                                _or_    pointings_RRRR.fits

    Arguments: rev:   Revolution number
    Keywords:  datadir: Path to where the swg.fits files should be found,
                        e.g. /jemx/arc/rev_3/scw/0888 (overrides the standard
                        directory for icons,ucons,inrt,unrt keywords)
               outdir:  Where to place the ASCII pointing files
                          If not set then: ISDC: /unsaved_data/jemx/westerga
                                           DTU: /r6/jemx/pointings
               icons:   If set, then assume directory names as at ISDC
                        The consolidated data for the revolution will be scanned
                          In this case the file name extension will be 'icons'
               inrt :   If set, then assume directory names as at ISDC
                        The near real time data for the revolution will be scanned
                          In this case the file name extension will be 'inrt'
               ucons:   If set, then assume directory names as at DTU(uhuru)
                        The consolidated data for the revolution will be scanned
                          In this case the file name extension will be 'ucons'
               unrt (default) :   If set, then assume directory names as at DTU(uhuru)
                        The near real time data for the revolution will be scanned
                          In this case the file name extension will be 'dat'
               mktt     Make timetable : swid_timetable_RRRR.fits. Will be output
                        in same directory as the pointing files.
               fit      output in FITS format
               pnt      select only pointings (SWID terminating with 0)
               chat:    If set to one or higher, then extra screen output is shown

    2002-11-20/NJW
    2006-10-04/NJW Translated to Yorick and adapted to ISDC/arc (swg.fits)
    2007-04-18/NJW Test for ISDC or DTU and more info in header
    2011-11-01/NJW Adding 'pnt' keyword

*/
{

   VERSION = "2.4"; // 2011-11-01/NJW

   require, "kfits.i";
   require, "mfits.i";
   require, "idlx.i";
   require, "jemx.i";

   local swid_aux, swids, swid;

   if( is_void(mktt) ) mktt = 0;

   if( is_void(icons) ) icons = 0;
   if( is_void(ucons) ) ucons = 0;
   if( is_void(inrt) ) inrt = 0;
   if( is_void(unrt) ) unrt = 0;
   if( is_void(chat) ) chat = 0;
   if( is_void(fit) ) fit = 0;
   if( icons+ucons+inrt+unrt == 0 ) unrt = 1;
   if( icons+ucons+inrt+unrt != 1 ) {
      write,"Inconsistent keyword settings, exit!";
      return;
   }

   revstr = swrite(format="%4.4i", toint(rev) );
   tt_name = "swid_timetable_"+revstr+".fits";
   ft_name = "pointings_"+revstr+".fits";

   // Running on ISDC(1) or DTU(0) ?

   user = get_env("USER");
   if( chat > 4 ) {
      write,format="##3## user: %s\n", user;
   }
   if( user == "njw" ) {
      on_isdcsys = 0;
      if( ucons+unrt == 0 ) {
         write,"You asked for ISDC data on UHURU-system, exit!";
         return;
      }
   } else if( user == "westerga" ) {
      on_isdcsys = 1;
      if( ucons+unrt == 1 ) {
         write,"You asked for UHURU(DTU) data on ISDC-system, exit!";
         return;
      }
   } else {
      write,format="Bad user env variable: %s, exit!\n", user;
      return;
   }

   // Define default directory for input data

   if( icons ) {
      datapath = "/isdc/arc/rev_3/scw/"+revstr;
      exten = "icons";
   }
   if( ucons ) {
      datapath = "/jemx/arc/rev_3/scw/"+revstr;
      exten = "ucons";
   }
   if( inrt ) {
      datapath = "/isdc/pvphase/nrt/ops_1/scw/"+revstr;
      exten = "inrt";
   }
   if( unrt ) {
      datapath = "/r6/jemx/sci_data/pvphase/nrt/ops_1/scw/"+revstr;
      exten = "dat";
   }
   if( numberof(datadir) ) datapath = rem_slash(datadir);
   if( chat > 1 ) {
      write,format="##4## datapath: %s\n", datapath;
   }

   if( ! file_test( datapath ) ) {
      write,format="No such directory: %s\n", datapath;
      return;
   }
   datapath = app_slash( datapath );

   if( chat > 0 ) {
      write,"----------------------------------------";
      write,format="Searching in: %s\n",datapath;
   }

   mode_arr = ["F","H","R","T","S","*"];
   bool = ["N","Y"];
   sysstr = ["NSI/DTU","ISDC"];
   ra_scx_prev = 0.0;
   dec_scx_prev = 0.0;
   first = 1;
   prev_empty = 0;

   // Define default directory for output data

   if( on_isdcsys ) {
      outpath = "/unsaved_data/jemx/westerga/";
   } else {
      outpath = "/r6/jemx/pointings/";
   }

   if( numberof(outdir) ) outpath = app_slash(fullpath(outdir));


   // Save current directory

   curdir = get_cwd();

   c = strpart(outpath,1:1);
   if( c != "/" ) {
      if( outpath == "./" ) {
         outpath = curdir;
      } else {
         outpath = curdir+outpath;
      }
   }

   cd,datapath;

   dir_list = file_search( revstr+"*", dir=1 );
   ndir_list = numberof( dir_list );
   if( ndir_list == 0 ) {
      write,"No data directories found";
      return;
   }
   if( pnt ) {
      pick_swid_str, dir_list, swids;
      w = where( strpart(swids, 0:0) == "0" );
      if( numberof(w) == 0 ) {
         write,"No pointing swids found";
         return;
      }
      dir_list = dir_list(w);
      ndir_list = numberof( dir_list );
   }

   jmx1typ_arr = [];
   jmx2typ_arr = [];
   jmx1ev_list = [];
   jmx2ev_list = [];
   swgfile_list = [];
   for( idir = 1; idir <= ndir_list; idir++ ) {
      if( file_test( dir_list(idir)+"/swg.fits",nz=1) ) {
         grow, swgfile_list, dir_list(idir)+"/swg.fits";

         if( inrt+unrt ) { // skip reading event files for NRT data
            grow, jmx1typ_arr,"*";
            grow, jmx1ev_list, 0;
            grow, jmx2typ_arr,"*";
            grow, jmx2ev_list, 0;

         } else {                    // Using CONS data

            if( chat > 4 ) write,"##5## Testing for JMX1 event files";
            if( chat > 4 ) write,"##6## Using CONS data";
            evfile = gz_proxy_file(dir_list(idir)+"/jmx1_events.fits", \
                                          dir=outpath,silent=1);
            erase = ( evfile != dir_list(idir)+"/jmx1_events.fits" );
            if( chat > 4 ) write,format="##7## evfile: %s\n", evfile;
            if( file_test(evfile) ) {
              /*
               *  Decide if content is FULL or REST data
               */
               if( chat > 4 ) write,"##8## Mark";
               fh = headfits( evfile+"[JMX1-FULL-ALL]" );
               if( !is_void(fh) ) {
                  type = "FULL";
                  num_events = fxpar( fh, "naxis2" );
                  if( chat > 4 ) write,format="Data type: %s, %i events\n", \
                                 type, num_events;
               } else {
                  if( chat > 4 ) write,"##9## Mark";
                  fh = headfits( evfile+"[JMX1-REST-ALL]" );
                  if( !is_void(fh) ) {
                     type = "REST";
                     num_events = fxpar( fh, "naxis2" );
                     if( chat > 4 ) write,format="Data type: %s, %i events\n", \
                                 type, num_events;
                  } else {  // signal problem, neither FULL nor REST
                     write,format="Neither FULL nor REST events in %s\n", \
                           dir_list(idir);
                     type = "*";
                     num_events = 1;
                  }
               }
               grow, jmx1typ_arr, strpart(type, 1:1 );
               grow, jmx1ev_list, num_events;
               if( erase && numberof(evfile) ) { // Delete the gz proxy file
                  if( chat > 0 ) write,"Deleting "+evfile;
                  remove, evfile;
               }
            } else {
               grow, jmx1ev_list, 0;
               grow, jmx1typ_arr, "*";
            }
            if( chat > 4 ) write,"##10## Testing for JMX2 event files";
            evfile = gz_proxy_file(dir_list(idir)+"/jmx2_events.fits", \
                                                     dir=outpath,silent=1);
            if( file_test(evfile) ) {
               if( chat > 4 ) write,"##11## Mark";
               fh = headfits( evfile+"[JMX2-FULL-ALL]" );
               if( !is_void(fh) ) {
                  type = "FULL";
                  num_events = fxpar( fh, "naxis2" );
                  if( chat > 4 ) write,format="Data type: %s, %i events\n", \
                                 type, num_events;
               } else {
                  if( chat > 4 ) write,"##12## Mark";
                  fh = headfits( evfile+"[JMX2-REST-ALL]" );
                  if( !is_void(fh) ) {
                     type = "REST";
                     num_events = fxpar( fh, "naxis2" );
                     if( chat > 4 ) write,format="Data type: %s, %i events\n", \
                                 type, num_events;
                  } else {  // signal problem, neither FULL nor REST
                     write,format="Neither FULL nor REST events in %s\n", \
                           dir_list(idir);
                     type = "*";
                     num_events = 1;
                  }
               }
               grow, jmx2typ_arr, strpart(type, 1:1 );
               grow, jmx2ev_list, num_events;
               if( erase && numberof(evfile) ) { // Delete the gz proxy file
                  if( chat > 0 ) write,"Deleting "+evfile;
                  remove, evfile;
               }
            } else {
               if( chat > 4 ) write,"##13## Mark";
               grow, jmx2ev_list, 0;
               grow, jmx2typ_arr, "*";
            }
         }
      } else {
         if( chat > 4 ) {
         write,format="##14## %s does not exist\n", dir_list(idir)+"/swg.fits";
         }
      }
   }

   nswgfile_list = numberof(swgfile_list);

   // Sanity check

   err_flag = 0;
   if( numberof(jmx1typ_arr) != nswgfile_list ) {
      write,format="Error: jmx1typ_arr (%i) diff. nswg (%i)", \
                        numberof(jmx1typ_arr), nswgfile_list;
      err_flag = 1;
   }
   //  -- this check can be elaborated ...

   if( chat > 0 ) {
      write,format="%i swg.fits files have been found\n", nswgfile_list;
   }
   if( nswgfile_list == 0 ) {
      write,"No swg.fits files found";
      return;
   }


   if( fit ) {
      outname = outpath+ft_name;
   } else {
      outname = outpath + "pointings_"+revstr+"p."+exten;
   }

   if( chat > 0 ) {
      write,format="The output is directed to: %s\n", outname;
   }

   // Remove file if it exists already

   if( chat > 4 ) write,"##15## Mark";
   if( file_test(outname) ) remove, outname;

   // First part: produce the list of all pointings, slews, and others

   if( fit ) {

      if( chat > 4 ) write,"##16## Mark";
      kwds_init;
      if( icons ) systr = "ISDC consolidated";
      if( ucons ) systr = "DTU consolidated";
      if( inrt ) systr = "ISDC near real time";
      if( unrt ) systr = "DTU near real time";
      kwds_set, "DATATYPE", systr, "Type of input data";
      kwds_set, "INSTRUME", "JEMX","Instrument";
      kwds_set, "TELESCOP", "INTEGRAL","Mission";
      kwds_set, "ORIGIN", "list_pointings.i-"+VERSION,"Yorick function";
      kwds_set, "REVOL", rev,"Revolution number";
      kwds_set, "DATE", ndate(3), "Time of file creation";
      kwds_set, "RESPONSI", "N.J. Westergaard", "Responsible for this file";


   } else {  //  Prepare ASCII output

      if( chat > 4 ) write,"##17## Mark";
      lun_p = open(outname,"w");

      // Short header in output file

      formstr1a = "%s  SWID          RA      DEC    POSANGLE      UT first";
      formstr1b = "        IJD     TELAPSE MODE12 ARC. ANLS.\n";
      formstr1c = "        IJD     TELAPSE MODE12\n";
      formstr2a = "%s              (deg)    (deg)    (deg)          pack  ";
      formstr2b = "       (day)     (s)           EVTS. LVL.\n";
      formstr2c = "       (day)     (s)\n";

      write,lun_p,format="%s       List of pointings with JEMX swg.fits data\n","//";
      write,lun_p,format="%s\n","//";
      write,lun_p,format="//  Extracted %s with /r9/njw/yorick/list_pointings.i-%s\n", \
                          ndate(3), VERSION;
      write,lun_p,format="// from %s directory: %s\n", sysstr(on_isdcsys+1), datapath;
      write,lun_p,format="%s\n","//";
      if( ucons || icons ) {
         write,lun_p,format=formstr1a+formstr1b,"//";
         write,lun_p,format=formstr2a+formstr2b,"//";
      } else {
         write,lun_p,format=formstr1a+formstr1c,"//";
         write,lun_p,format=formstr2a+formstr2c,"//";
      }
      write,lun_p,format="%s\n","//";

   }




//  sort the list to get chronology right

   if( chat > 4 ) write,"##18## Mark";
   is = sort(swgfile_list);
   swgfile_list = swgfile_list(is);
   jmx1ev_list = jmx1ev_list(is);
   jmx2ev_list = jmx2ev_list(is);

//  Clean away lower version numbers for identical SWIDs

   pick_swid_str, swgfile_list, swid_aux;
   w = array(0, nswgfile_list);
   for( i = 1; i < nswgfile_list; i++ ) {
      if( swid_aux(i) != swid_aux(i+1) ) w(i) = 1;
   }
   w(0) = 1; // Last one should always be included
   w = where(w);
   swgfile_list = swgfile_list(w);
   jmx1ev_list = jmx1ev_list(w);
   jmx2ev_list = jmx2ev_list(w);
   nswgfile_list = numberof(w);
   if( chat > 0 ) {
      write,format="%i swg.fits files have been kept with highest version\n", nswgfile_list;
   }


//  Loop through list to extract the pointing information

   swid_arr = array(string,nswgfile_list);
   tstart_arr = array(double, nswgfile_list);
   tstop_arr = array(double, nswgfile_list);
   ra_scx_arr = array(double, nswgfile_list);
   dec_scx_arr = array(double, nswgfile_list);
   ra_scz_arr = array(double, nswgfile_list);
   dec_scz_arr = array(double, nswgfile_list);
   posangle_arr = array(double, nswgfile_list);
   ertfirst_arr = array(string, nswgfile_list);
   telapse_arr = array(double, nswgfile_list);
   exposure_j1_arr = array(-1.0, nswgfile_list);
   exposure_j2_arr = array(-1.0, nswgfile_list);
   gain_j1_arr = array(-1.0, nswgfile_list);
   gain_j2_arr = array(-1.0, nswgfile_list);
   jmx1mode_arr = array(string, nswgfile_list);
   jmx2mode_arr = array(string, nswgfile_list);
   shd_j1_arr = array(999, nswgfile_list);
   shd_j2_arr = array(999, nswgfile_list);
   iros_j1_arr = array(999, nswgfile_list);
   iros_j2_arr = array(999, nswgfile_list);
   bti_j1_arr = array("N", nswgfile_list);
   bti_j2_arr = array("N", nswgfile_list);

   for( i = 1; i <= nswgfile_list; i++ ) {
      swgfile = swgfile_list(i);
      pick_swid_str, swgfile, swid;
      swid = swid(1);
      swid_arr(i) = swid;
      hdr = headfits(swgfile+"+1",nocheck=1);
      ra_scx = fits_get(hdr,"RA_SCX");
      dec_scx = fits_get(hdr,"DEC_SCX");
      ra_scz = fits_get(hdr,"RA_SCZ");
      dec_scz = fits_get(hdr,"DEC_SCZ");
      posangle = fits_get(hdr,"POSANGLE");
      ertfirst = fits_get(hdr,"ERTFIRST");
      ijd = dattim2ijd( ertfirst );
      tstart = fits_get(hdr,"TSTART");
      tstop  = fits_get(hdr,"TSTOP");

      ra_scx_arr(i) = ra_scx;
      dec_scx_arr(i) = dec_scx;
      ra_scz_arr(i) = ra_scz;
      dec_scz_arr(i) = dec_scz;
      posangle_arr(i) = posangle;
      tstop_arr(i) = tstop;
      tstart_arr(i) = tstart;
      ertfirst_arr(i) = ertfirst;

      bti_j1_arr(i) = bti_struck( 1, tstart, tstop );
      bti_j2_arr(i) = bti_struck( 2, tstart, tstop );

      telapse  = fits_get(hdr,"TELAPSE");
      telapse_arr(i) = telapse;
      jmx1mode = fits_get(hdr,"JMX1MODE");
      index1 = jmx1mode - 41;
      if( index1  <  0 || index1  >  4 ) index1 = 5;
      jmx2mode = fits_get(hdr,"JMX2MODE");
      index2 = jmx2mode - 41;
      if( index2  <  0 || index2  >  4 ) index2 = 5;
      jmx1mode_arr(i) = mode_arr(index1+1);
      jmx2mode_arr(i) = mode_arr(index2+1);

      if( ! fit && ! first ) {
         dist = arcdist(ra_scx, dec_scx, ra_scx_prev, dec_scx_prev);
         if( dist  >  3.0 ) {
            if( ! prev_empty ) {
               write,lun_p,format="%s\n","";
               prev_empty = 1
            }
         }
      }
      first = 0;
      ra_scx_prev = ra_scx;
      dec_scx_prev = dec_scx;
      if( ! fit && strpart(swid,12:12)  ==  "0" ) {
         if( ucons || icons ) {
            write,lun_p, \
               format="%12s%10.4f%9.4f%9.3f%21s%10.4f%7.0f  %1s  %1s  %1s %1s  ? ?\n", \
               swid,ra_scx,dec_scx,posangle,ertfirst,ijd,telapse, \
               mode_arr(index1+1), mode_arr(index2+1), bool(anyof(jmx1ev_list(i))+1), \
               bool(anyof(jmx2ev_list(i))+1);
         } else {
            write,lun_p, \
               format="%12s%10.4f%9.4f%9.3f%21s%10.4f%7.0f  %1s  %1s\n", \
               swid,ra_scx,dec_scx,posangle,ertfirst,ijd,telapse, \
               mode_arr(index1+1), mode_arr(index2+1);
         }
         prev_empty = 0;
      }
   }

   if( fit ) {

      wrmfitscols, outname, "SWID", swid_arr, "TSTART", tstart_arr, \
          "TSTOP", tstop_arr, "RA_SCX", ra_scx_arr, "DEC_SCX", dec_scx_arr, \
          "RA_SCZ", ra_scz_arr, "DEC_SCZ", dec_scz_arr, \
          "POSANGLE", posangle_arr, \
          "TELAPSE", telapse_arr, \
          "EXPOSURE_J1", exposure_j1_arr, \
          "EXPOSURE_J2", exposure_j2_arr, \
          "GAIN_J1", gain_j1_arr, \
          "GAIN_J2", gain_j2_arr, \
          "MODE_J1", jmx1mode_arr, \
          "MODE_J2", jmx2mode_arr, \
          "EVTS_J1", jmx1ev_list, \
          "EVTS_J2", jmx2ev_list, \
          "SHD_J1", shd_j1_arr, \
          "SHD_J2", shd_j2_arr, \
          "IROS_J1", iros_j1_arr, \
          "IROS_J2", iros_j2_arr, \
          "BTI_J1", bti_j1_arr, \
          "BTI_J2", bti_j2_arr, \
          clobber=1;

   } else {
      close,lun_p;
   }
   write,"Has produced "+outname;

   // Write the FITS time table file if requested

   if( mktt ) {
      kwds_init;
      if( icons ) systr = "ISDC consolidated";
      if( ucons ) systr = "DTU consolidated";
      if( inrt ) systr = "ISDC near real time";
      if( unrt ) systr = "DTU near real time";
      kwds_set, "DATATYPE", systr, "Type of input data";
      kwds_set, "INSTRUME", "JEMX","Instrument";
      kwds_set, "TELESCOP", "INTEGRAL","Mission";
      kwds_set, "REVOL", rev,"Revolution number";
      kwds_set, "DATE", ndate(3), "Time of file creation";
      kwds_set, "RESPONSI", "N.J. Westergaard", "Responsible for this file";
      wrmfitscols, outpath+tt_name, "SWID", swid_arr, "TSTART", tstart_arr, \
          "TSTOP", tstop_arr, "RA_SCX", ra_scx_arr, "DEC_SCX", dec_scx_arr, \
          "RA_SCZ", ra_scz_arr, "DEC_SCZ", dec_scz_arr, \
          "POSANGLE", posangle_arr, clobber=1;
      write,"Has produced "+outpath+tt_name;
   }

   // cd to original directory

   cd, curdir;

   // Change write permission to include group

   system,"chmod 664 "+outname;

}
%FILE% list_var.i
func list_var( filename, rc= )
/* DOCUMENT list_var, filename, rc=

   Will list all the words appearing only once in the file,
   presumably a Yorick source code.

   Setting the 'rc' keyword will cause a comment removal by both
   c_rm_comment and cpp_rm_comment prior to variable search.

*/
{
   std_words = ["func","if","abs","sin","cos", "where","pi","double","int","long", \
                "float","for","local","char","grow","extern","error","tan", \
                "return","interp","sqrt","sort","file_test","clobber", \
                "is_void","open","close","itoa","fullpath","indgen","headfits", \
                "sflux","get_exten_no","fxpar","strupcase","rdfitscol","numberof", \
                "while","else","ndate","read","format","max","spanl","span","array", \
                "random","random_n"];
   if( rc ) {
      system,"c_rm_comment "+filename;
      filename += "nc";
      system,"cpp_rm_comment "+filename;
      filename += "pp";
   }
   words = [];
   stream = open( filename, "r" );
   while( (line = rdline(stream)) ) {
      line = str_erase_between_symbols( line, "\"" );
      grow, words, str_get_words(line);
   }
   close, stream;

   words = words(sort(words));
   words = filter_done( std_words, words );

   u = uniq( words );
   grow,u,numberof(words)+1;
   uu = u(dif);
   z = where( uu == 1 );
   singletons = words(u(z));

   write,format="  --------   Single words   -----------%s","\n";
   arrange_words_in_columns, singletons, 3, max(strlen(singletons))+2;

   return words;
}
%FILE% list_var_c.i
func list_var_c( filename, locallist= )
/* DOCUMENT list_var_c, filename, locallist=
     or     singletons = list_var_c( filename, locallist= )

   Will list all the words appearing only once in the file.
   The value of the keyword 'locallist' will be obtained from
   the parameter file 'list_var_c.par' if not given.
   The value "none" will skip reading.

   2011-05-04/NJW

*/
{
   std_words = ["FILE","if","abs","sin","double","int","long", \
                "float","for","char","tan", \
                "return","sqrt"];

   llist = [];
   if( is_void(locallist) ) locallist = get_par("list_var_c.par","locallist");
   if( locallist != "none" ) llist = rdfile(locallist);

   words = [];
   stream = open( filename, "r" );
   while( (line = rdline(stream)) ) {
      line = str_erase_between_symbols( line, "\"" );
      grow, words, str_get_words(line);
   }
   close, stream;

   words = words(sort(words));
   words = filter_done( std_words, words );
   if( !is_void(llist) ) words = filter_done( llist, words );

   u = uniq( words );
   grow,u,numberof(words)+1;
   uu = u(dif);
   z = where( uu == 1 );
   singletons = words(u(z));

   write,format="  --------   Single words   -----------%s","\n";
   arrange_words_in_columns, singletons, 3, max(strlen(singletons))+2;

   return singletons;
}
%FILE% lmfit_outres.i
func lmfit_outres( r, file, nocor= )
/* DOCUMENT lmfit_outres, r, file, nocor=

   Prints the fit details from a run of 'lmfit':

   > r = lmfit( funk, x, y, w, ... );

   If 'file' is a string then it will write to a file of that name
                and close it at return.
   If 'file' is a stream it will write to that.
   If 'file' is void it will write to the terminal.

   Keyword  nocor : Skip the print of the correlation array
*/
{
   f = typeof(file) == "string" ? 1 : 0;
   if( f ) file = open(file, "w");

   write,file,format="// Details of lmfit %s:\n","fitting";
   write,file,format="// Num of funk evaluations   : %10i\n", r.neval;
   write,file,format="// Num of iterations         : %10i\n", r.niter;
   write,file,format="// Num of fitted parameters  : %10i\n", r.nfit;
   write,file,format="// Num of degrees of freedom : %10i\n", r.nfree;
   write,file,format="// Num of MontCarl simul.s   : %10i\n", r.monte_carlo;
   write,file,format="// First Chi2 value          : %17.6f\n", r.chi2_first;
   write,file,format="// Last Chi2 value           : %17.6f\n", r.chi2_last;
   write,file,format="// Chi2 improvement factor   : %17.6f\n", r.conv;
   write,file,format="// Sigma (sqrt(red.chi2))    : %17.6f\n", r.sigma;
   write,file,format="// Lambda                    : %17.6f\n", r.lambda;
   sdev = *r.stdev;
   nsdev = numberof(sdev);
   for( i = 1; i <= nsdev; i++ ) {
      write,file,format="// St.dev. of param #%2i     : %17.6f\n", i, sdev(i);
   }

   if( !nocor ) {

      corarr = *r.correl;
      write,file,format="// Correlation array %s\n",":";
      nsecs = (nsdev-1)/4 + 1;
      for( isec = 1; isec <= nsecs; isec++ ) {
         j1 = 1 + (isec-1)*4;
         j2 = j1 + 3;
         if( j2 > nsdev ) j2 = nsdev;
         write,file,format="// --%s","---";
         for( j = j1; j <= j2; j++ ) write,file,format="---- %2i ----", j;
         write,file,"";
         for( i = 1; i <= nsdev; i++ ) {
            write,file,format="// %2i ", i;
            for( j = j1; j <= j2; j++ ) {
               write,file,format="%12.5f", corarr(i,j);
            }
            write,file,"";
         }
      }

   }

   if(f) close, file;
}
%FILE% lvdt.i
extern lvdtdoc;
/* DOCUMENT ***************************************
 *           LVDT data analysis package           *
 *                                                *
 *     lvdt2fits                                  *
 *     show_layer                                 *
 *     get_slope_distri                           *
 *     mk_lvdt_cube                               *
 **************************************************
*/

/* Function lvdt2fits */

func lvdt2fits( layer_number, sect )
/* DOCUMENT lvdt2fits, layer_number, sect

    Take the FITS files for in current directory (output from IDL procedure
    'conv2fits') belonging to a single layer (use sect as "L" or "U"
    to separate between lower of upper optic section) and combine to
    a single slice that can go directly into a cube for MT_RAYOR.
*/
{
   dirname = get_cwd();
   pos = strpos( dirname, "FM" );
   fmstr = strpart( dirname, pos:pos+2 );
   list = file_search(fmstr+"_"+itoa(layer_number)+sect+"*.fits");
   if( numberof(list) == 0 ) {
      write,"No files with name "+fmstr+"_"+itoa(layer_number)+sect+"*.fits were found";
      return;
   }

   nzres = 201; // number of z values in output array
   nazres = 157; // number of azimuth values in output array
     // this number has been selected since span(0,360,157) has an element = 150 deg
     // precisely, the amount that the NuSTAR theta scale is rotated relative to MT_RAYOR

   nlist = numberof(list);
   resarr = array(float(-99.),nazres,nzres); // slice
   infarr = array(float(0.),401,51); // slice for info
   azim = span(0,2*pi,nazres);
   azim_info = span(0,2*pi,401);
   if( sect == "L" ) {
      zarr = span(-454.,-229.,nzres);
      zarr_info = span(-454.,-229.,51);
   } else {
      zarr = span(-225.,0.,nzres);
      zarr_info = span(-225.,0.,51);
   }

  /*
   *    Loop over the individual files for this layer and optic section
   *      Each file contains three extensions: 1) bintable with theta values,
   *      2) bintable with z values, and 3) image with dr values
   */
   for( l = 1; l <= nlist; l++ ) {
      theta = rdfitscol(list(l)+"+1","theta");
      // look out for the strange value of 17.4358 and remove
      wrem = where(near(theta,17.4358,.1));
      nwrem = numberof(wrem);
      if( nwrem == numberof(theta) ) {
         write,"NB problem with theta in l = "+itoa(l);
         continue;
      }
      if( nwrem ) theta = rem_elem(theta,wrem);
      // expects increasing angles, if not, then reverse
      rev = 0;
      if( avg(theta(dif)) < 0.0 ) {
         rev = 1;
         theta = theta(0:1:-1);
      }
      theta_info = span(theta(1),theta(0),500);
      z = rdfitscol(list(l)+"+2","z");
      dr = readfits(list(l)+"+3");

      // if one or more theta values have been removed due to 'strangeness'
      // then the corresponding dr values must be removed as well

      if( nwrem ) {
         drt = transpose(dr);
         drt = rem_elem(drt,wrem);
         dr = transpose(drt);
      }
      wnan = wherenan(dr);
      if( numberof(wnan) ) dr(wnan) = 0.0;

      // take a break to fill in the infarr

      ntheta_info = numberof(theta_info);
      nz = numberof(z);
      for( i = 1; i <= ntheta_info; i++ ) {
         //+ i0 = where( min(abs(azim_info-theta_info(i))) == abs(azim_info-theta_info(i)))(1);
         i0 = abs(azim_info-theta_info(i))(mnx);
         for( j = 1; j <= nz; j++ ) {
            //+ j0 = where( min(abs(zarr_info-z(j))) == abs(zarr_info-z(j)))(1);
            j0 = abs(zarr_info-z(j))(mnx);
            infarr(i0,j0) = 1.;
         }
      }

      // now continue the 'real' processing

      dmsdr = dimsof(dr);
      if( dmsdr(2) != numberof(theta) ) error,"ntheta for "+list(l);
      if( dmsdr(3) != numberof(z) ) error,"nz for "+list(l);
      if(rev) dr = dr(0:1:-1,); // reverse the theta-direction

      //  Loop over the azimuth angles for the output array
      //  skip those that are not covered by the current mirror

      for( i = 1; i <= nazres; i++ ) {
         a = azim(i);
         if( a < theta(1)-0.5*(theta(dif)(1)) ) continue;
         if( a > theta(0)+0.5*(theta(dif)(0)) ) continue;

         //  Walk along the z-line

         for( j = 1; j <= nzres; j++ ) {
            za = zarr(j);
            resarr(i,j) = interp2( dr, theta, z, a, za );
         }
      }

   }

   // Fill in remaining -99 values
   // work in the azimuth (i.e. x-) direction
   for( j = 1; j <= nzres; j++ ) {
      resarr(,j) = arr_fill_in( resarr(,j) );
   }

   // ascertain that azimuth zero and 2pi get identical values

   avgval = 0.5*(resarr(1,) + resarr(0,));
   resarr(1,) = avgval;
   resarr(0,) = avgval;

   fh = writefits(fmstr+"_layerx_"+itoa(layer_number)+sect+".fits", resarr,clobber=1,cont=1);
   writefits,fh,infarr;
   disp,resarr,title="Layer "+itoa(layer_number),Ucut=0.03,Lcut=-0.03;
   pause,2000;
   write,fmstr+"_layerx_"+itoa(layer_number)+sect+".fits has been written ...";

}

/* Function show_layer */

func show_layer
/* DOCUMENT show_layer

    Interactive function to show LVDT layer plots with
    additional distributions.
      Commands:   x  to exit
                  h to toggle hardcopy
                  U or L to change sector
                  layer_number to redefine the start point
                  <RTRN> next layer
*/
{
   local h, xh, p, q, yfit;

   // Determine the NuSTAR unit (FM0, FM1, or FM2)
   ss = fullpath("a");
   sss = strsplit(ss,"/");
   unit = "none";
   if( anyof(sss == "FM0") ) unit = "FM0";
   if( anyof(sss == "FM1") ) unit = "FM1";
   if( anyof(sss == "FM2") ) unit = "FM2";
   if( unit == "none" ) error,"Called in wrong directory";

   nzres = 201;
   nazres = 157;
   hc = 0; // start with no hard-copy
   // define axes for the image value histogram on the x-axis
   // and the slope histogram on the y-axis
   xax = span(-0.03,0.03,nazres);
   yax = span(-60,60,nzres);
   z = span(-112.5,112.5,nzres);
   s = ""; // string for command
   ia = 1; // flag for interactive mode
   lay = 1; // layer number
   sect = "L";
   while( s != "x" ) { // Continue until an 'x' is encountered
      // ask for command if in interactive mode
      if( ia ) {
         write,"Going to show "+unit+" layer "+itoa(lay)+", sector "+sect;
         s = rdline(prompt="Change? :  L|U|#|h|i|x ... ");
         if( s == "L" || s == "U" ) { // set sector
            sect = s;
         } else if( is_digit(s) ) { // set layer number
            lay = atoi(s);
         } else if( s == "h" ) { // toggle hardcopy
            hc = 1 - hc;
         } else if( s == "i" ) { // skip interaction and run series
            ia = 0;
            lay = 1;
         }
      }
      // set the input file name and the plot file name
      file = unit+"_layer_"+itoa(lay)+sect+".fits";
      psfile = "ps/"+unit+"_layer_"+itoa(lay)+sect+".ps";
      if( file_test(file) ) {
         dol = file+"+1";
         m = readfits(dol);
         // display in a fixed interval -0.02 -- 0.02
         disp,m,xax=xax,yax=yax,Ucut=0.02,Lcut=-0.02,cb=10, \
             title=unit+" layer "+itoa(lay)+sect, \
             xtitle="Azimuth and DR [mm]", \
             ytitle="Z and surface slope [arcsec]";
         // make histogram of image values
         histos,m,h,xh,bmin=-0.03,bmax=0.03,binsize=0.06/150;
         // choose color for inserted histogram plots
         color = avg(m(20:130,10:150)) > 0.01 ? "black" : "white";
         // map 'h' from 0 - 4000 to the y-axis scale: -60 - 60
         linscale, 0, 4000, -60, 60, p, q;
         // the following 'out of limit' happens only when there are
         // strange values in the data
         w = where(h > 4000);
         if( numberof(w) ) h(w) = 4000.;
         oplot,xh,h*p+q,ps=10,color=color;
         // make the slope values and the histogram
         slope = m(,dif)/(z(dif))(-,); // in radians
         slope *= 206265; // in arcsec
         histos,slope,h,xh,bmin=-60.,bmax=60.,binsize=120./200;
         // map 'h' from 0 - 3000 to the x-axis scale: -0.03 - 0.03
         linscale, 0, 3000, -0.03, 0.03, p, q;
         // the following 'out of limit' happens only when there are
         // strange values in the data
         w = where(h > 3000);
         if( numberof(w) ) h(w) = 3000.;
         oplot,h*p+q,xh,ps=10,color=color;
         // prepare the gauss fit
         esti = autoesti( xh, h );
         cfit = gaussfit( xh, h, esti, yfit );
         oplot,yfit*p+q,xh,color="red";
         xyouts,0.2,0.8,swrite(format="FWHM %4.1f arcsec",cfit(3)*2.3548),device=1,color=color;
         if( hc ) zps,noc=1,outfile=psfile;
      } else {
         write,"Not found: "+file;
      }
      if( ++lay > 133 ) {
         lay = 1;
         ia = 1; // back to interactive mode
      }
   }
}

/* Function get_slope_distri */

func get_slope_distri( unit_number, sect )
/* DOCUMENT distri = get_slope_distri( unit_number, sect )

    Sets up the external variable 'X' and returns
    the distribution.

*/
{
   extern X;
   blim = 0.0025;
   size = blim/200;
   first = 1;

   unit = "FM"+itoa(unit_number);

   lisall = file_search(unit+"_*"+sect+"*.fits");
   lislay = file_search(unit+"_layer*"+sect+".fits");
   liscub = file_search(unit+"_lvdt_cube*"+sect+".fits");
   lista = filter_done(lislay,lisall);
   list  = filter_done(liscub,lista);

   nlist = numberof(list);
   write,itoa(nlist)+" "+sect+" files are found.";
   for( i=1; i<=nlist; i++ ) {
      for( i = 1; i <= nlist; i++ ) {
         write,list(i);
         z = rdfitscol(list(i)+"+2","z");
         dr = readfits(list(i)+"+3");
         w = wherenan(dr);
         if( numberof(w) ) dr(w) = 0.0;
         slopes = dr(,dif)/(z(-,dif));
         histos,slopes,h,x,bmin=-blim,bmax=blim,binsize=size;
         //+ plot,x,h,ps=10,title=esc_underscore(list(i));
         X = x;
         //+ pause,2000;
         if( first ) {
            hsum = h;
            first = 0;
         } else {
            hsum += h;
         }
      }
   }
   write,"X array in external X ...";
   return hsum;
}

/* Function mk_lvdt_cube */

func mk_lvdt_cube( unit_number, sect )
/* DOCUMENT mk_lvdt_cube, unit_number, sect

    Assemble the individual layer FITS files to a data cube
    Remember that a change of sign is required since a decrease of
    radius is represented by a positive value in the MT_RAYOR code.
*/
{
   unit = "FM"+itoa(unit_number);

   fill = array(int,133);
   first = 1;
   for( layer = 1; layer <= 133; layer++ ) {
      fname = unit+"_layerx_"+itoa(layer)+sect+".fits";
      if( !file_test(fname) ) {
         write,"Missing "+fname+", skip and continue ...";
         continue;
      }
      map = readfits(fname+"+1");
      if( first ) {
         // create the cube
         dms = dimsof(map);
         // The number of azimuth values must be 157 to match up with 150 deg
         //  (see function 'lvdt2fits')
         if( dms(2) != 157 ) error,"Illegal map dimension";
         cube = array(float,dms(2),dms(3),133);
         first = 0;
      }
      if( anyof( map >  0.2 ) ) map(where(map >  0.2)) =  0.2;
      if( anyof( map < -0.2 ) ) map(where(map < -0.2)) = -0.2;
      cube(,,layer) = map;
      fill(layer) = 1;
   }

   // Then fill in the missing layers from the neighbors

   w = where(fill == 0);
   nw = numberof(w);
   while( nw > 0 ) {
      i = w(1);
      // identify closest fill == 1 position
      m = where(fill == 1);
      //+ q = where(abs(m-i) == min(abs(m-i)));
      q = abs(m-i)(mnx);
      cube(,,i) = cube(,,m(q));
      fill(i) = 1;
      w = where(fill == 0);
      nw = numberof(w);
   }

  /*
   *  The rotation by 150 deg happens here
   */
   cube = shift( cube, -66, 0, 0 );

   kwds_init;
   kwds_set,"EXTNAME",unit+"_LVDT_CUBE","Name of this extension";
   kwds_set,"DATE",ndate(2),"Date of creation";
   kwds_set,"MISSION","NuSTAR","Mission";
   kwds_set,"INSTRUME", unit, "Instrument";
   kwds_set,"COMMENT","LVDT data cube with sign inversion compared to DR values";
   kwds_set,"COMMENT","The data have been shiftet -66 (rotating by 150 deg) to adapt";
   kwds_set,"COMMENT","to starting point of theta measurement in NuSTAR optic.";
  /*
   *  The sign inversion happens here:        v
   */
   writefits,unit+"_lvdt_cube_"+sect+".fits", -cube, clobber=1;

}
%FILE% manip_rebin.i
func manip_rebin( rebin, istart=, vstart= )
/* DOCUMENT newrebin = manip_rebin( rebin, istart=, vstart= )

*/
{
   i = istart;
   res = rebin;
   if( is_void(vstart) ) v = res(i);
   else { res(i) = v = vstart; }
   pile = 0;
   i++;
   while( i < numberof(res) && res(i) > 0 ) {
      // can I remove this one? If the 'pile' is larger, then yes
      while( i <= numberof(res) && pile > res(i) ) {
         //+ write,"Remove element #"+itoa(i)+" and reduce pile with "+itoa(res(i));
         pile -= res(i);
         res = rem_elem( res, i );
      }
      if( res(i) >= v ) {
         //+ write,"Upgrade v to "+itoa(res(i));
         v = res(i);
         i++;
         continue;
      }
      //+ write,"Increase pile with "+itoa(v - res(i));
      pile += v - res(i);
      res(i) = v;
      i++;
      //+ write,"at end - pile: "+itoa(pile)+", i: "+itoa(i);
   }

   write,"At exit - pile = "+itoa(pile);
   return res;

}
%FILE% map.i


func load_map ( ffn= ) {
/* DOCUMENT load_map(ffn=)

   Load a NOAA/USGS geographical coastline lat/lon map into the present 
   window.  This is useful if you want to project some GPS positions 
   onto a map easily.  Yorick lets you quickly and easily pan and zoom 
   on the map and your data.

   Get the maps from: http://crusty.er.usgs.gov/coast/getcoast.html
   Use the "mapgen" format option. After you download the map, remove 
   the first line (which is a comment beginning with a # sign).  This 
   function expects the map files to end with a .amap extension.  This 
   function uses sel_file to solicite a filename from the user.

   C. W. Wright wright@web-span.com  99-03-20

   See also:   sel_file

*/
extern map_path

if ( is_void( map_path )  ) {

// Set the following to where the maps are stored on your system.
  map_path = "/home/wright/maps"	
}

if ( is_void( ffn ) ) { 
  ffn = sel_file(ss="*.amap", path="/home/wright/maps/") (1);
}

f = open(ffn, "r" );
lsegs = 0
str = array(string,1);
lat = array(float, 1000)
lon = array(float, 1000)

 if (catch(0x02) ) { 
    close,f
    return;
  }

// load upto 100,000 line segments
for (i=0; i<100000; i++) {
 n = read(f,format="%f %f", lon,lat)
 if ( n == 0 ) {
   close,f
   write,i," line segments loaded"
   return; 
 }
 n = n/2
 lsegs++
 if ( lat(1) == 0 ) break;
 if ( (i % 1000) == 0  ) { 
   print,i
   redraw
 }
 plg,lat(1:n),lon(1:n),marks=0
 gridxy,1,1
}
 n=write(format="%d line segments read from %s\n", lsegs, fn)
 close,f
}
%FILE% mcomplex.i
extern mcomplexdoc;
/* DOCUMENT  mcomplex.i  Additional complex functions

    rhotheta  :  change to rho * exp(i theta) representation
    cubicroot :  Three cubic roots
    nthroot   :  N Nth roots
    cubic_eq  : Solves cubic equation

*/

/* Function rhotheta */

func rhotheta( z )
/* DOCUMENT res = rhotheta( z )

    Returns 2 element array [modulus, argument (theta angle)]
    of the complex number, z (works also for non-complex numbers)

    2008-03-29/NJW
*/
{
   rho = sqrt(double(z*conj(z)));
   theta = typeof(z) == "complex" ? atan( z.im, z.re ) : pi*(1-sign(z))/2;
   return [rho, theta];
}

/* Function cubicroot */

func cubicroot( z )
/* DOCUMENT roots = cubicroot( z )

   Returns the 3 cubic complex roots of a number

   2008-03-29/NJW
*/
{
   q = rhotheta( z );
   rho = q(1)^(1./3.);
   th1 = q(2)/3;
   th2 = th1 + (2*pi)/3;
   th3 = th2 + (2*pi)/3;
   res = array(complex,3);
   res(1).re = rho*cos(th1);
   res(1).im = rho*sin(th1);
   res(2).re = rho*cos(th2);
   res(2).im = rho*sin(th2);
   res(3).re = rho*cos(th3);
   res(3).im = rho*sin(th3);

   return res;

}

/* Function nthroot */

func nthroot( z, n )
/* DOCUMENT roots = nthroot( z, n )

   Returns the n nth complex roots of a number
   (z^(1./n))

   2008-03-29/NJW
*/
{
   q = rhotheta( z );
   rho = q(1)^(1./n);
   theta = q(2)/n;
   phi = (2*pi)/n;
   res = array(complex,n);
   for( i = 1; i <= n; i++ ) {
      res(i).re = rho*cos(theta);
      res(i).im = rho*sin(theta);
      theta += phi;
   }

   return res;

}

/* Function cubic_eq */

func cubic_eq( a, b, c, s= )
/* DOCUMENT x = cubic_eq( a, b, c, s= )

   Returns the three (two of them may be complex) roots to:
    x^3 + a*x^2 + b*x + c = 0
    s=1 : one solution (default)
    s=-1 : another solution

    2008-03-27/NJW
*/
{
   third = 1.0/3.0;
   if( is_void(s) ) s = 1;
   p = b - a^2/3;
   q = c + (2*a^3 - 9*a*b)/27;
   det = complex();
   det.re = q^2/4 + p^3/27;
   sqdet = sqrt(det);
   u1 = q/2 + s*sqdet;
   u = cubicroot(u1); // returns 3 roots
   //+ v = p/(3*u);
   return p/(3*u) - u - a/3;

}
%FILE% md5.i
/*
 * $Id: md5.i,v 1.1.1.1 2005/09/18 22:06:16 dhmunro Exp $
 * routines to compute MD5 checksums
 * entirely in interpreted code, so they are slow,
 *   on the order of a few seconds per megabyte
 * original C source from L. Peter Deutsch ghost@aladdin.com
 *   adapted by David H. Munro
 */
/* Copyright (c) 2005, The Regents of the University of California.
 * All rights reserved.
 * This file is part of yorick (http://yorick.sourceforge.net).
 * Read the accompanying LICENSE file for details.
 */

func md5sum(file, hex=)
/* DOCUMENT digest = md5sum(filename)
 *          digest = md5sum(filename, hex=1)
 *   compute MD5 digest of a file, an array of 16 char
 *   with the hex=1 keyword, returned digest is a string (in hex)
 *
 * SEE ALSO: md5
 */
{
  if (!is_stream(file)) file = open(file, "rb");
  nbyte = sizeof(file);
  // Following statement changed by NJW 2008-12-01
  //+ original version: if (!nbyte) return md5(md5());
  if (!nbyte) return md5(md5(),hex=hex);
  nchunk = 1000000;  /* process file in megabyte chunks */
  buf = array(char, min(nbyte,nchunk));
  for (state=[],n=0 ; n<nbyte ; n+=nchunk) {
    if (n+nchunk > nbyte) {
      nchunk = nbyte - n;
      if (sizeof(buf) > nchunk) buf = array(char, nchunk);
    }
    if (_read(file,n,buf) < nchunk)
      error, "i/o error reading file";
    state = md5(buf, state);
  }
  return md5(state, hex=hex);
}

func md5(data, state, hex=)
/* DOCUMENT state = md5(data)
 *          state = md5(data, state)
 *          digest = md5(state)
 *          digest = md5(state, hex=1)
 *   compute MD5 digest of data, an array of 16 char
 *   with the hex=1 keyword, returned digest is a string (in hex)
 *
 * SEE ALSO: md5sum
 */
{
  local count, digest;
  type = structof(data);
  if (is_void(state)) {
    if (type == pointer) {
      /* no more data, return MD5 digest */
      count = *data(1);                /* makes a copy of count */
      _md5_increment, count, sizeof(*data(3));  /* add pending */
      /* number of additional bytes to reach 56 mod 64 */
      nbyte = ((55-(count(1)>>3))&63) + 1;
      pad = grow(array(char, nbyte), _md5_number(count));
      pad(1) = '\x80';
      state = md5(pad, data);
      return _md5_hex(_md5_number(*state(2)), hex=hex);
    }

    /* create a new state, this is first call for this digest */
    state = [&[0, 0],
             &[0x67452301, ~0x10325476, ~0x67452301, 0x10325476],
             &[]];
    if (is_void(data)) return state;
  }

  if (type != char) error, "md5 requires char input data";

  data = grow(*state(3), data(*));   /* prepend any leftover data */
  nbyte = sizeof(data);
  next = nbyte & 63;
  state(3) = next? &data(1-next:0) : &[];
  nbyte -= next;

  if (nbyte) {
    eq_nocopy, count, *state(1);
    _md5_increment, count, nbyte;

    nword = nbyte>>6;
    tmp = array(char, 4, 16, nword);
    tmp(*) = data(1:-next);
    tmp = long(tmp);
    data = tmp(1,,) | (tmp(2,,)<<8) | (tmp(3,,)<<16) | (tmp(4,,)<<24);
    tmp = [];

    eq_nocopy, digest, *state(2);
    a0 = digest(1);
    b0 = digest(2);
    c0 = digest(3);
    d0 = digest(4);

    for (i=1 ; i<=nword ; ++i) {
      x = data(_md5_order,i) + _md5_t;
      a = a0;
      b = b0;
      c = c0;
      d = d0;
      /* round 1 */
      a = a + ((b & c) | ((~b) & d)) + x(1);
      a = ((a << 7) | ((a >> 25)&0x0000007f)) + b;
      d = d + ((a & b) | ((~a) & c)) + x(2);
      d = ((d << 12) | ((d >> 20)&0x00000fff)) + a;
      c = c + ((d & a) | ((~d) & b)) + x(3);
      c = ((c << 17) | ((c >> 15)&0x0001ffff)) + d;
      b = b + ((c & d) | ((~c) & a)) + x(4);
      b = ((b << 22) | ((b >> 10)&0x003fffff)) + c;
      a = a + ((b & c) | ((~b) & d)) + x(5);
      a = ((a << 7) | ((a >> 25)&0x0000007f)) + b;
      d = d + ((a & b) | ((~a) & c)) + x(6);
      d = ((d << 12) | ((d >> 20)&0x00000fff)) + a;
      c = c + ((d & a) | ((~d) & b)) + x(7);
      c = ((c << 17) | ((c >> 15)&0x0001ffff)) + d;
      b = b + ((c & d) | ((~c) & a)) + x(8);
      b = ((b << 22) | ((b >> 10)&0x003fffff)) + c;
      a = a + ((b & c) | ((~b) & d)) + x(9);
      a = ((a << 7) | ((a >> 25)&0x0000007f)) + b;
      d = d + ((a & b) | ((~a) & c)) + x(10);
      d = ((d << 12) | ((d >> 20)&0x00000fff)) + a;
      c = c + ((d & a) | ((~d) & b)) + x(11);
      c = ((c << 17) | ((c >> 15)&0x0001ffff)) + d;
      b = b + ((c & d) | ((~c) & a)) + x(12);
      b = ((b << 22) | ((b >> 10)&0x003fffff)) + c;
      a = a + ((b & c) | ((~b) & d)) + x(13);
      a = ((a << 7) | ((a >> 25)&0x0000007f)) + b;
      d = d + ((a & b) | ((~a) & c)) + x(14);
      d = ((d << 12) | ((d >> 20)&0x00000fff)) + a;
      c = c + ((d & a) | ((~d) & b)) + x(15);
      c = ((c << 17) | ((c >> 15)&0x0001ffff)) + d;
      b = b + ((c & d) | ((~c) & a)) + x(16);
      b = ((b << 22) | ((b >> 10)&0x003fffff)) + c;
      /* round 2 */
      a = a + ((b & d) | ((~d) & c)) + x(17);
      a = ((a << 5) | ((a >> 27)&0x0000001f)) + b;
      d = d + ((a & c) | ((~c) & b)) + x(18);
      d = ((d << 9) | ((d >> 23)&0x000001ff)) + a;
      c = c + ((d & b) | ((~b) & a)) + x(19);
      c = ((c << 14) | ((c >> 18)&0x00003fff)) + d;
      b = b + ((c & a) | ((~a) & d)) + x(20);
      b = ((b << 20) | ((b >> 12)&0x000fffff)) + c;
      a = a + ((b & d) | ((~d) & c)) + x(21);
      a = ((a << 5) | ((a >> 27)&0x0000001f)) + b;
      d = d + ((a & c) | ((~c) & b)) + x(22);
      d = ((d << 9) | ((d >> 23)&0x000001ff)) + a;
      c = c + ((d & b) | ((~b) & a)) + x(23);
      c = ((c << 14) | ((c >> 18)&0x00003fff)) + d;
      b = b + ((c & a) | ((~a) & d)) + x(24);
      b = ((b << 20) | ((b >> 12)&0x000fffff)) + c;
      a = a + ((b & d) | ((~d) & c)) + x(25);
      a = ((a << 5) | ((a >> 27)&0x0000001f)) + b;
      d = d + ((a & c) | ((~c) & b)) + x(26);
      d = ((d << 9) | ((d >> 23)&0x000001ff)) + a;
      c = c + ((d & b) | ((~b) & a)) + x(27);
      c = ((c << 14) | ((c >> 18)&0x00003fff)) + d;
      b = b + ((c & a) | ((~a) & d)) + x(28);
      b = ((b << 20) | ((b >> 12)&0x000fffff)) + c;
      a = a + ((b & d) | ((~d) & c)) + x(29);
      a = ((a << 5) | ((a >> 27)&0x0000001f)) + b;
      d = d + ((a & c) | ((~c) & b)) + x(30);
      d = ((d << 9) | ((d >> 23)&0x000001ff)) + a;
      c = c + ((d & b) | ((~b) & a)) + x(31);
      c = ((c << 14) | ((c >> 18)&0x00003fff)) + d;
      b = b + ((c & a) | ((~a) & d)) + x(32);
      b = ((b << 20) | ((b >> 12)&0x000fffff)) + c;
      /* round 3 */
      a = a + (b ~ c ~ d) + x(33);
      a = ((a << 4) | ((a >> 28)&0x0000000f)) + b;
      d = d + (a ~ b ~ c) + x(34);
      d = ((d << 11) | ((d >> 21)&0x000007ff)) + a;
      c = c + (d ~ a ~ b) + x(35);
      c = ((c << 16) | ((c >> 16)&0x0000ffff)) + d;
      b = b + (c ~ d ~ a) + x(36);
      b = ((b << 23) | ((b >> 9)&0x007fffff)) + c;
      a = a + (b ~ c ~ d) + x(37);
      a = ((a << 4) | ((a >> 28)&0x0000000f)) + b;
      d = d + (a ~ b ~ c) + x(38);
      d = ((d << 11) | ((d >> 21)&0x000007ff)) + a;
      c = c + (d ~ a ~ b) + x(39);
      c = ((c << 16) | ((c >> 16)&0x0000ffff)) + d;
      b = b + (c ~ d ~ a) + x(40);
      b = ((b << 23) | ((b >> 9)&0x007fffff)) + c;
      a = a + (b ~ c ~ d) + x(41);
      a = ((a << 4) | ((a >> 28)&0x0000000f)) + b;
      d = d + (a ~ b ~ c) + x(42);
      d = ((d << 11) | ((d >> 21)&0x000007ff)) + a;
      c = c + (d ~ a ~ b) + x(43);
      c = ((c << 16) | ((c >> 16)&0x0000ffff)) + d;
      b = b + (c ~ d ~ a) + x(44);
      b = ((b << 23) | ((b >> 9)&0x007fffff)) + c;
      a = a + (b ~ c ~ d) + x(45);
      a = ((a << 4) | ((a >> 28)&0x0000000f)) + b;
      d = d + (a ~ b ~ c) + x(46);
      d = ((d << 11) | ((d >> 21)&0x000007ff)) + a;
      c = c + (d ~ a ~ b) + x(47);
      c = ((c << 16) | ((c >> 16)&0x0000ffff)) + d;
      b = b + (c ~ d ~ a) + x(48);
      b = ((b << 23) | ((b >> 9)&0x007fffff)) + c;
      /* round 4 */
      a = a + (c ~ ((~d) | b)) + x(49);
      a = ((a << 6) | ((a >> 26)&0x0000003f)) + b;
      d = d + (b ~ ((~c) | a)) + x(50);
      d = ((d << 10) | ((d >> 22)&0x000003ff)) + a;
      c = c + (a ~ ((~b) | d)) + x(51);
      c = ((c << 15) | ((c >> 17)&0x00007fff)) + d;
      b = b + (d ~ ((~a) | c)) + x(52);
      b = ((b << 21) | ((b >> 11)&0x001fffff)) + c;
      a = a + (c ~ ((~d) | b)) + x(53);
      a = ((a << 6) | ((a >> 26)&0x0000003f)) + b;
      d = d + (b ~ ((~c) | a)) + x(54);
      d = ((d << 10) | ((d >> 22)&0x000003ff)) + a;
      c = c + (a ~ ((~b) | d)) + x(55);
      c = ((c << 15) | ((c >> 17)&0x00007fff)) + d;
      b = b + (d ~ ((~a) | c)) + x(56);
      b = ((b << 21) | ((b >> 11)&0x001fffff)) + c;
      a = a + (c ~ ((~d) | b)) + x(57);
      a = ((a << 6) | ((a >> 26)&0x0000003f)) + b;
      d = d + (b ~ ((~c) | a)) + x(58);
      d = ((d << 10) | ((d >> 22)&0x000003ff)) + a;
      c = c + (a ~ ((~b) | d)) + x(59);
      c = ((c << 15) | ((c >> 17)&0x00007fff)) + d;
      b = b + (d ~ ((~a) | c)) + x(60);
      b = ((b << 21) | ((b >> 11)&0x001fffff)) + c;
      a = a + (c ~ ((~d) | b)) + x(61);
      a = ((a << 6) | ((a >> 26)&0x0000003f)) + b;
      d = d + (b ~ ((~c) | a)) + x(62);
      d = ((d << 10) | ((d >> 22)&0x000003ff)) + a;
      c = c + (a ~ ((~b) | d)) + x(63);
      c = ((c << 15) | ((c >> 17)&0x00007fff)) + d;
      b = b + (d ~ ((~a) | c)) + x(64);
      b = ((b << 21) | ((b >> 11)&0x001fffff)) + c;
      a0 += a;
      b0 += b;
      c0 += c;
      d0 += d;
    }

    digest(1) = a0;
    digest(2) = b0;
    digest(3) = c0;
    digest(4) = d0;
  }

  return state;
}

func _md5_increment(count, nbyte)
{
  /* add number of bits to count, with carry if overflows 32 bits */
  count(2) += nbyte >> 29;
  old = count(1);
  nlo = (nbyte << 3) & 0xffffffff;
  count(1) = new = (old + nlo) & 0xffffffff;
  if ((new&0x80000000)? (old & nlo & 0x80000000) : ((old | nlo)&0x80000000))
    count(1) += 1;
}

func _md5_number(w)
{
  return char( w(-,) >> [0,8,16,24] )(*);
}

_md5_order = [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,
              2,7,12,1,6,11,16,5,10,15,4,9,14,3,8,13,
              6,9,12,15,2,5,8,11,14,1,4,7,10,13,16,3,
              1,8,15,6,13,4,11,2,9,16,7,14,5,12,3,10];

_md5_t = [~0x28955b87, ~0x173848a9, 0x242070db, ~0x3e423111, ~0x0a83f050,
          0x4787c62a, ~0x57cfb9ec, ~0x02b96afe, 0x698098d8, ~0x74bb0850,
          ~0x0000a44e, ~0x76a32841, 0x6b901122, ~0x02678e6c, ~0x5986bc71,
          0x49b40821, ~0x09e1da9d, ~0x3fbf4cbf, 0x265e5a51, ~0x16493855,
          ~0x29d0efa2, 0x02441453, ~0x275e197e, ~0x182c0437, 0x21e1cde6,
          ~0x3cc8f829, ~0x0b2af278, 0x455a14ed, ~0x561c16fa, ~0x03105c07,
          0x676f02d9, ~0x72d5b375, ~0x0005c6bd, ~0x788e097e, 0x6d9d6122,
          ~0x021ac7f3, ~0x5b4115bb, 0x4bdecfa9, ~0x0944b49f, ~0x4140438f,
          0x289b7ec6, ~0x155ed805, ~0x2b10cf7a, 0x04881d05, ~0x262b2fc6,
          ~0x1924661a, 0x1fa27cf8, ~0x3b53a99a, ~0x0bd6ddbb, 0x432aff97,
          ~0x546bdc58, ~0x036c5fc6, 0x655b59c3, ~0x70f3336d, ~0x00100b82,
          ~0x7a7ba22e, 0x6fa87e4f, ~0x01d3191f, ~0x5cfebceb, 0x4e0811a1,
          ~0x08ac817d, ~0x42c50dca, 0x2ad7d2bb, ~0x14792c6e];

func md5_test
{
  test = ["", "a", "abc", "message digest", "abcdefghijklmnopqrstuvwxyz",
          "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789",
          "12345678901234567890123456789012345678901234567890123456789"+
          "012345678901234567890"];
  answ = ["d41d8cd98f00b204e9800998ecf8427e",
          "0cc175b9c0f1b6a831c399e269772661",
          "900150983cd24fb0d6963f7d28e17f72",
          "f96b697d7cb7938d525a2f31aaf161d0",
          "c3fcd3d76192e4007dfb496cca67e13b",
          "d174ab98d277d9f5a5611c2c9f419d9f",
          "57edf4a22be3c955ac49da2e2107b67a"];
  correct = [[0xd4,0x1d,0x8c,0xd9,0x8f,0x00,0xb2,0x04,
              0xe9,0x80,0x09,0x98,0xec,0xf8,0x42,0x7e],
             [0x0c,0xc1,0x75,0xb9,0xc0,0xf1,0xb6,0xa8,
              0x31,0xc3,0x99,0xe2,0x69,0x77,0x26,0x61],
             [0x90,0x01,0x50,0x98,0x3c,0xd2,0x4f,0xb0,
              0xd6,0x96,0x3f,0x7d,0x28,0xe1,0x7f,0x72],
             [0xf9,0x6b,0x69,0x7d,0x7c,0xb7,0x93,0x8d,
              0x52,0x5a,0x2f,0x31,0xaa,0xf1,0x61,0xd0],
             [0xc3,0xfc,0xd3,0xd7,0x61,0x92,0xe4,0x00,
              0x7d,0xfb,0x49,0x6c,0xca,0x67,0xe1,0x3b],
             [0xd1,0x74,0xab,0x98,0xd2,0x77,0xd9,0xf5,
              0xa5,0x61,0x1c,0x2c,0x9f,0x41,0x9d,0x9f],
             [0x57,0xed,0xf4,0xa2,0x2b,0xe3,0xc9,0x55,
              0xac,0x49,0xda,0x2e,0x21,0x07,0xb6,0x7a]];
  actual = array(char, 16, numberof(answ));
  for (i=1 ; i<=numberof(answ) ; ++i) {
    data = *pointer(test(i));
    actual(,i) = md5(md5(((numberof(data)>1)?data(1:-1):[])));
  }
  if (anyof(actual!=correct)) error, "md5 function flunked test";
}

func _md5_hex(digest, hex=)
{
  if (!hex) return digest;
  s = swrite(format="%02x",digest);
  s = s(1:16:2) + s(2:16:2);
  s = s(1:8:2) + s(2:8:2);
  s = s(1:4:2) + s(2:4:2);
  return s(1) + s(2);
}
%FILE% mem_storage.i
extern mem_storagedoc;
/* DOCUMENT  Package for data storage in memory

    e.g. when repeated data reading is performed
    Operates on 1D arrays of datatypes: int, long, float, double, string.

      mem_save    Saving an array
      mem_restore Restoring an array
      mem_reset   Erase allocated memory
      mem_info    Show info on memory contents

*/

/* Function mem_save */

func mem_save( data_id, arr, silent= )
/* DOCUMENT status = mem_save( data_id, arr, silent= )

   Saves the 1D array 'arr' to memory with the data identification
   name 'data_id'. It can be a filename plus a column id or a DOL etc.
   Accepted data types: int, long, float, double, string.

   Retrieval by function mem_restore.

   See also mem_reset, mem_restore, mem_info

   2007-01-08/NJW
*/
{
   extern Didimsav, Idximsav, Numimsav, Datimsav;
   extern Didjmsav, Idxjmsav, Numjmsav, Datjmsav;
   extern Didfmsav, Idxfmsav, Numfmsav, Datfmsav;
   extern Diddmsav, Idxdmsav, Numdmsav, Datdmsav;
   extern Didsmsav, Idxsmsav, Numsmsav, Datsmsav;

   if( is_void(silent) ) silent = 0;

   dms = dimsof( arr );
   if( dms(1) != 1 ) {
      write,"Array must be 1D - skip";
      return -2;
   }
   dtype = typeof( arr );

// Normal Integers

   if( dtype == "int" ) {
      w = where( Didimsav == data_id );
      if( numberof(w) >= 1 ) {
         if( !silent ) write,data_id+" (int) exists already - skip";
         return -1;
      }
      grow, Datimsav, arr;
      grow, Didimsav, data_id;
      if( is_void(Idximsav) ) {
         Idximsav = [1];
      } else {
         grow, Idximsav, Idximsav(0)+Numimsav(0);
      }
      grow, Numimsav, dms(2);
      return 0;

// Long Integers

   } else if( dtype == "long" ) {
      w = where( Didjmsav == data_id );
      if( numberof(w) >= 1 ) {
         if( !silent ) write,data_id+" (long) exists already - skip";
         return -1;
      }
      grow, Datjmsav, arr;
      grow, Didjmsav, data_id;
      if( is_void(Idxjmsav) ) {
         Idxjmsav = [1];
      } else {
         grow, Idxjmsav, Idxjmsav(0)+Numjmsav(0);
      }
      grow, Numjmsav, dms(2);
      return 0;

// Floating point

   } else if( dtype == "float" ) {
      w = where( Didfmsav == data_id );
      if( numberof(w) >= 1 ) {
         if( !silent ) write,data_id+" (float) exists already - skip";
         return -1;
      }
      grow, Datfmsav, arr;
      grow, Didfmsav, data_id;
      if( is_void(Idxfmsav) ) {
         Idxfmsav = [1];
      } else {
         grow, Idxfmsav, Idxfmsav(0)+Numfmsav(0);
      }
      grow, Numfmsav, dms(2);
      return 0;

// Double precision

   } else if( dtype == "double" ) {
      w = where( Diddmsav == data_id );
      if( numberof(w) >= 1 ) {
         if( !silent ) write,data_id+" (double) exists already - skip";
         return -1;
      }
      grow, Datdmsav, arr;
      grow, Diddmsav, data_id;
      if( is_void(Idxdmsav) ) {
         Idxdmsav = [1];
      } else {
         grow, Idxdmsav, Idxdmsav(0)+Numdmsav(0);
      }
      grow, Numdmsav, dms(2);
      return 0;

// Strings

   } else if( dtype == "string" ) {
      w = where( Didsmsav == data_id );
      if( numberof(w) >= 1 ) {
         if( !silent ) write,data_id+" (string) exists already - skip";
         return -1;
      }
      grow, Datsmsav, arr;
      grow, Didsmsav, data_id;
      if( is_void(Idxsmsav) ) {
         Idxsmsav = [1];
      } else {
         grow, Idxsmsav, Idxsmsav(0)+Numsmsav(0);
      }
      grow, Numsmsav, dms(2);
      return 0;


   } else {
      write,"Unsupported data type";
      return -3;
   }
}

/* Function mem_reset */

func mem_reset( void )
/* DOCUMENT status = mem_reset();
      or    mem_reset;

   Erases all the variables used for data storage in momory.

   See also mem_save, mem_restore, mem_info

   2007-01-08/NJW
*/
{
   extern Didimsav, Idximsav, Numimsav, Datimsav;
   extern Didjmsav, Idxjmsav, Numjmsav, Datjmsav;
   extern Didfmsav, Idxfmsav, Numfmsav, Datfmsav;
   extern Diddmsav, Idxdmsav, Numdmsav, Datdmsav;
   extern Didsmsav, Idxsmsav, Numsmsav, Datsmsav;
   Didimsav = []; Idximsav = []; Numimsav = []; Datimsav = [];
   Didjmsav = []; Idxjmsav = []; Numjmsav = []; Datjmsav = [];
   Didfmsav = []; Idxfmsav = []; Numfmsav = []; Datfmsav = [];
   Diddmsav = []; Idxdmsav = []; Numdmsav = []; Datdmsav = [];
   Didsmsav = []; Idxsmsav = []; Numsmsav = []; Datsmsav = [];
   return 0;
}

/* Function mem_restore */

func mem_restore( data_id, &arr )
/* DOCUMENT status = mem_restore( data_id, arr )

   Restores the 1D array 'arr' previously saved in memory under the
   name 'data_id' by the function 'mem_save'.
   Accepted data types: int, long, float, double, string.

   See also mem_reset, mem_save, mem_info

   2007-01-08/NJW
*/
{
   extern Didimsav, Idximsav, Numimsav, Datimsav;
   extern Didjmsav, Idxjmsav, Numjmsav, Datjmsav;
   extern Didfmsav, Idxfmsav, Numfmsav, Datfmsav;
   extern Diddmsav, Idxdmsav, Numdmsav, Datdmsav;
   extern Didsmsav, Idxsmsav, Numsmsav, Datsmsav;

   if( !is_void(Didimsav) ) {
      w = where( data_id == Didimsav );
      if( numberof(w) > 0 ) {
         i = w(0);
         arr = Datimsav(Idximsav(i):Idximsav(i)+Numimsav(i)-1);
         return 0;
      }
   }

   if( !is_void(Didjmsav) ) {
      w = where( data_id == Didjmsav );
      if( numberof(w) > 0 ) {
         i = w(0);
         arr = Datjmsav(Idxjmsav(i):Idxjmsav(i)+Numjmsav(i)-1);
         return 0;
      }
   }
   
   if( !is_void(Didfmsav) ) {
      w = where( data_id == Didfmsav );
      if( numberof(w) > 0 ) {
         i = w(0);
         arr = Datfmsav(Idxfmsav(i):Idxfmsav(i)+Numfmsav(i)-1);
         return 0;
      }
   }
   
   if( !is_void(Diddmsav) ) {
      w = where( data_id == Diddmsav );
      if( numberof(w) > 0 ) {
         i = w(0);
         arr = Datdmsav(Idxdmsav(i):Idxdmsav(i)+Numdmsav(i)-1);
         return 0;
      }
   }
   
   if( !is_void(Didsmsav) ) {
      w = where( data_id == Didsmsav );
      if( numberof(w) > 0 ) {
         i = w(0);
         arr = Datsmsav(Idxsmsav(i):Idxsmsav(i)+Numsmsav(i)-1);
         return 0;
      }
   }

   return -1;

}

/* Function mem_info */

func mem_info(a,chat=)
/* DOCUMENT mem_info,chat=

   Gives an overview of memory contents

   See also mem_save, mem_restore, mem_reset

   2007-01-08/NJW
*/
{

   extern Didimsav, Idximsav, Numimsav, Datimsav;
   extern Didjmsav, Idxjmsav, Numjmsav, Datjmsav;
   extern Didfmsav, Idxfmsav, Numfmsav, Datfmsav;
   extern Diddmsav, Idxdmsav, Numdmsav, Datdmsav;
   extern Didsmsav, Idxsmsav, Numsmsav, Datsmsav;

   if( is_void(chat) ) chat = 0;
   if( !is_void(Didimsav) ) {
      num = numberof(Didimsav);
      plu = num > 1 ? "s" : "";
      write,format="%i int item%s\n", num, plu;
      if( chat == 1 ) {
         for(i=1;i<=num;i++) {
            write,format="%i elements in %s\n", Numimsav(i), Didimsav(i);
         }
      }
      if( chat > 1 ) {
         n = chat > num ? num : chat;
         for(i=1;i<=n;i++) {
            write,format="%s(%i): ", Didimsav(i), Numimsav(i);
            m = chat > Numimsav(i) ? Numimsav(i) : chat;
            for(j=1;j<=m;j++) write,format="%i ", Datimsav(Idximsav(i)+j-1);
            write,"";
         }
      }
   }
   if( !is_void(Didjmsav) ) {
      num = numberof(Didjmsav);
      plu = num > 1 ? "s" : "";
      write,format="%i long item%s\n", num, plu;
      if( chat == 1 ) {
         for(i=1;i<=num;i++) {
            write,format="%i elements in %s\n", Numjmsav(i), Didjmsav(i);
         }
      }
      if( chat > 1 ) {
         n = chat > num ? num : chat;
         for(i=1;i<=n;i++) {
            write,format="%s(%i): ", Didjmsav(i), Numjmsav(i);
            m = chat > Numjmsav(i) ? Numjmsav(i) : chat;
            for(j=1;j<=m;j++) write,format="%i ", Datjmsav(Idxjmsav(i)+j-1);
            write,"";
         }
      }
   }
   if( !is_void(Didfmsav) ) {
      num = numberof(Didfmsav);
      plu = num > 1 ? "s" : "";
      write,format="%i float item%s\n", num, plu;
      if( chat == 1 ) {
         for(i=1;i<=num;i++) {
            write,format="%i elements in %s\n", Numfmsav(i), Didfmsav(i);
         }
      }
      if( chat > 1 ) {
         n = chat > num ? num : chat;
         for(i=1;i<=n;i++) {
            write,format="%s(%i): ", Didfmsav(i), Numfmsav(i);
            m = chat > Numfmsav(i) ? Numfmsav(i) : chat;
            for(j=1;j<=m;j++) write,format="%f ", Datfmsav(Idxfmsav(i)+j-1);
            write,"";
         }
      }
   }
   if( !is_void(Diddmsav) ) {
      num = numberof(Diddmsav);
      plu = num > 1 ? "s" : "";
      write,format="%i double item%s\n", num, plu;
      if( chat == 1 ) {
         for(i=1;i<=num;i++) {
            write,format="%i elements in %s\n", Numdmsav(i), Diddmsav(i);
         }
      }
      if( chat > 0 ) {
         n = chat > num ? num : chat;
         for(i=1;i<=n;i++) {
            write,format="%s(%i): ", Diddmsav(i), Numdmsav(i);
            m = chat > Numdmsav(i) ? Numdmsav(i) : chat;
            for(j=1;j<=m;j++) write,format="%f ", Datdmsav(Idxdmsav(i)+j-1);
            write,"";
         }
      }
   }
   if( !is_void(Didsmsav) ) {
      num = numberof(Didsmsav);
      plu = num > 1 ? "s" : "";
      write,format="%i string item%s\n", num, plu;
      if( chat == 1 ) {
         for(i=1;i<=num;i++) {
            write,format="%i elements in %s\n", Numsmsav(i), Didsmsav(i);
         }
      }
      if( chat > 0 ) {
         n = chat > num ? num : chat;
         for(i=1;i<=n;i++) {
            write,format="%s(%i): ", Didsmsav(i), Numsmsav(i);
            m = chat > Numsmsav(i) ? Numsmsav(i) : chat;
            for(j=1;j<=m;j++) write,format="%s ", Datsmsav(Idxsmsav(i)+j-1);
            write,"";
         }
      }
   }
}
%FILE% mepmodn.i
func memodn( m, e, n )
{
   local f, h, mi, r;

   if(CHAT) {
      write,format="memodn called with m = %s, e = %s, n = %s\n", \
           ln2str(m), ln2str(e), ln2str(n);
   }
   mw = m;
   ew = e;
   mi = LNUNIT;

   p = LNUNIT;
   logmax = logsiz( LNMAX ) * 0.3;
   if(CHAT) {
      write,format="n = %s, logsiz(LNMAX) = %.6f\n", ln2str(n), logmax;
   }
   while( ln_gt( ew, LNUNIT ) && logsiz(mw,ew) + logsiz(p) >= logmax ) {
      mepmodn, mw, ew, p, n, f, h, mi;
      if(CHAT) {
         write,format=" mw = %s, ew = %s, p = %s\n", ln2str(mw), \
             ln2str(ew), ln2str(p);
         write,format=" f = %s, h = %s, mi = %s\n", ln2str(f), \
             ln2str(h), ln2str(mi);
         write,format="logsiz old: %.6f, new: %.6f\n", logsiz(mw,ew)+logsiz(p), \
             logsiz(f,h)+logsiz(mi);
      }
      mw = f;
      ew = h;
      p = mi;
   }

   div, mul(lnpow(mw,ew),mi), n, r;
   return r;
}
      
func mepmodn( m, e, p, n , &f, &h, &mi )
{
   local i, r, s;

   if(CHAT) {
      write,format="mepmodn called with m = %s, e = %s, p = %s, n = %s\n", \
           ln2str(m), ln2str(e), ln2str(p), ln2str(n);
   }
   k = LNUNIT;
   mk = m;
   while( ln_gt( n, mk ) ) {
      mk = mul( mk, m );
      k = add(k, LNUNIT);
   }
   div, mk, n, f;
   h = div(e,k,i);
   mi = lnpow( m, i );
   div, mi, n, r;
   div, p, n, s;
   div, mul(r,s), n, mi;
   if(CHAT) {
      write,format="mp:  mk = %s, f = %s\n", \
        ln2str(mk), ln2str(f);
      write,format="mp:  k = %s, h = %s, i = %s\n", \
        ln2str(k), ln2str(h), ln2str(i);
      write,format="mp:  mi = %s, r = %s, s = %s\n", \
        ln2str(mi), ln2str(r), ln2str(s);
   }
}

/* Function lngcd */

func lngcd( a, b )
/* DOCUMENT gcd = lngcd( a, b )

    returns greatest common divisor into a and b evaluated by
    Euklid's algorithm
*/
{
   if( noneof(a-b) ) return a; // i.e. when a == b

   if( ln_gt( a, b ) ) {
      aa = a;
      bb = b;
   } else {
      aa = b; // swap to make aa > bb
      bb = a;
   }
   if( noneof(bb(1:-1)) ) return aa;

   write,format="LNGCD %s %s\n", ln2str(aa), ln2str(bb);
   local r;
   div, aa, bb, r;
   return lngcd( bb, r );
}

/* Function fermatf */

func fermatf( n )
/* DOCUMENT  res= fermatf( n )
     "Fermat factorisation"
     returns 1 is n is a prime and 0 otherwise
*/
{
   local r;

   if( !lnodd( n ) ) return 0;
   k = lnsqrt( n, r ); // n = k*k + r
   if( noneof(r(1:-1)) ) return 0; // is a square
   test = div(add(n,LNUNIT),LNTWO); // (n+1)/2
   while( 1 ) {
      k = add(k,LNUNIT);
      y2 = sub( mul(k,k), n );
      y = lnsqrt(y2, r);
      write,format="%s %s %s %s\n", ln2str(k), ln2str(y2), ln2str(y), ln2str(r);
      if( noneof(r(1:-1)) ) {
         if( noneof(test-k) ) return 1;
         return 0;
      }
   }
}
%FILE% mexican_hat.i
/* Function mexican_hat */

func mexican_hat( dim1, dim2, sigma_inner, sigma_outer, &mex_hat, k= )
/* DOCUMENT kernel = mexican_hat( dim1, dim2, sigma_inner, sigma_outer, >mex_hat, k= )

   Returns the FFT of the kernel, ready to use in e.g. 'fconvol'

   Arguments
      dim1 and dim2 are the dimensions of the image that is to be folded with
                    the Mexican Hat kernel
      sigma_inner   is the sigma of the inner, positive part of the hat
      sigma_outer   is the sigma of the outer, negative part of the hat
      mex_hat       returns the array with the kernel
   Keyword
      k             is the amplitude of the inner, positive part of the hat (defaults to 3.0)

   SEE ALSO: fkernel, fconvol

   2010-09-10/NJW, from mexican_hat_ps2 and peaksearch2
   2013-01-10/NJW  updated slightly
*/
{

   // Constructing the shape of the Mexican hat

   sigma_outer = double(sigma_outer);
   sigma_inner = double(sigma_inner);
   R = sigma_outer * 2.5;
   r = span(0.,R,100);
   if( is_void(k) ) k = 3.0;
   b = expo(R,sigma_inner);
   B = expo(R,sigma_outer);
   int_f = k*(sigma_inner^2 * hxexp(R/sigma_inner) - 0.5*R*R*b);
   int_g = sigma_outer^2 * hxexp(R/sigma_outer) - 0.5*R*R*B;
   K = int_f / int_g;

   dm = long(R)*2 + 1; // make it odd
   mex_hat = array(double,dm,dm);
   d = distances(dm,dm,(dm-1)/2+1,(dm-1)/2+1);
   w = where( d < R );
   mex_hat(w) = k*(expo(d(w),sigma_inner) - b) - K*(expo(d(w),sigma_outer) - B);

   return fkernel( mex_hat, dim1, dim2);

}
%FILE% mexican_hat_ps2.i
/* Function mexican_hat_ps2 */

func mexican_hat_ps2( a )
/* DOCUMENT mexican_hat_ps2

   sets up the external array Mex_hat that is used
   by e.g. peaksearch2 (reason for 'ps2' in name).

   2006-02-23/NJW
*/
{

   extern Mex_hat, Mex_fk511;

   require, "image.i";
   require, "romberg.i";
   require, "plot.i";
   require, "varfuncs.i";
   require, "idlx.i";
   require, "afits.i";
   require, "scom.i";
   require, "fconvol.i";
   
   // Constructing the shape of the Mexican hat
   
   r = span(0.,10.,100);
   k = 3.0;
   sig = 1.1; // Sigma of inner peak
   SIG = 4.0; // Sigma of 'rim'
   R = 10.0;
   b = expo(R,sig);
   B = expo(R,SIG);
   f = k*(expo(r,sig) - b);
   int_f = k*(sig*sig*hxexp(R/sig) - 0.5*R*R*b);
   int_g = SIG*SIG*hxexp(R/SIG) - 0.5*R*R*B;
   K = int_f / int_g;
   g = K*(expo(r,SIG) - B);
   
   Mex_hat = array(double,21,21);
   d = distances(21,21,11,11);
   w = where( d < R );
   Mex_hat(w) = k*(expo(d(w),sig) - b) - K*(expo(d(w),SIG) - B);
   
   Mex_fk511 = fkernel( hat, 511, 511);
   
}
%FILE% mfigures.i
func mfigures( list_of_figure_files, angle=, npp=, capt= )
/* DOCUMENT mfigures, list_of_figure_files, angle=, npp=, capt=

    sets up a latex file in /r4/njw/Htex/mfigures

    angle  :  0, 90, 180, or 270
    npp    :  number per page
    capt   :  string array with captions, must match the 'list_of_figure_files'
             (this keyword may only work with npp=1)
*/
{
   if( is_void(npp) ) npp = 4;
   if( is_void(angle) ) angle = 0;

   n = numberof( list_of_figure_files );
   nblocks = (n-1)/npp + 1;
   if( !is_void(capt) ) {
      if( numberof(capt) != n ) {
         write,"Skip captions since their number doesn't match";
         capt = [];
      }
   }

   pre = rdfile("/r4/njw/Htex/mfigures/beginfigure.txt");
   post = rdfile("/r4/njw/Htex/mfigures/endfigure.txt");

   f = open("/r4/njw/Htex/mfigures/figs.tex","w");
   write,f,format="%% this is figs.tex as created by %s\n","mfigures.i";
   write,f,format="%% on %s\n",ndate(3);
   close,f;

   idx = 0;
   for( ib = 1; ib <= nblocks; ib++ ) {
      write_slist,"/r4/njw/Htex/mfigures/figs.tex",pre,app=1;
      lines = [];
      for( k = 1; k <= npp; k++ ) {
         idx++;
         if( idx > n ) break;
         line1 = "\\epsfig{figure="+fullpath(list_of_figure_files(idx));
         line2 = ",angle="+itoa(angle)+",width=\\figwidth}";
         line = line1+line2;
         grow, lines, line;
         if( !is_void(capt) ) grow, lines, "\\caption{"+capt(idx)+"}";
      }
      write_slist,"/r4/njw/Htex/mfigures/figs.tex",lines,app=1;
      write_slist,"/r4/njw/Htex/mfigures/figs.tex",post,app=1;

      if( ib%4 == 0 ) write_slist,"/r4/njw/Htex/mfigures/figs.tex","\\clearpage",app=1;
   }
   write,"Now 'figs.tex' has been prepared in /r4/njw/Htex/mfigures";
   write,"where you can run latex on 'mfigures'.";
}
%FILE% mfits.i
/* Function mfitsdoc */

extern mfitsdoc;
/* DOCUMENT mfits ***************************************

   A set of funtions to facilitate the FITS interface with
   same names as the IDL private functions

   Note that the counting of the HDUs has origin in 1 for the
   Yorick functions but 0 for IDL like functions

   2006-02-07/NJW, latest update 2012-09-12/NJW

      admfitscols       Add rows to multiple FITS binary table
      _fits_var_length_info  Retrieve lengths and positions of
                             variable length records
      fits_binsplit     Split a binary table into several files
      fits_bintable_peek  Extract value(s) from single table bin
      fits_bintable_poke  Update content of binary FITS table
      fits_btdes        Unpack FITS binary table description
      fits_ch_keyw      Change keyword value in place
      fits_coldump      Nice printing of column data
      fits_colnum       Return column number for given column name
      fits_copy_keys    Copy non-FITS specific keywords
      fits_info_col     Display the column information
      fits_numcols      Get number of columns in binary table
      fselect           An emulation of the corresponding ftool
      fstrselect        fselect based on the 'strmatch' function
      fxpar             Get keyword value
      get_crd           Get coordinate definitions from header
      get_exten_no      Get filename and extension number from DOL
      get_wcs           Get WCS in a struct 's_Coords' from a FITS header
      gz_proxy_file     Define uncompressed file for reading
      headfits          Get FITS header for DOL
      im2skyfits        Save a 2D array as a sky image in a FITS file with WCS info.
      kwds_del          Delete a keyword from  KW-memory
      kwds_init         Erase all keywords from KW-memory
      kwds_put          Update FITS header with keywords from KW-memory
      kwds_set          Define a keyword in KW-memory
      kwds_setlongstr   Define a keyword with a long string in a sequence in KW-memory
      listhead          Display all header keywords
      nfits_extens      Get number of highest extension
      pixsize           Find pixel sizes in image extension
      put_wcs           Update keywords with WCS information
      rdfitsbin         Return pointers to complete FITS binary table
      rdfitscol         Return a column from binary FITS table
      readfits          Returns an array from FITS IMAGE extension
      simple_peak       Finds number of counts around position (RA, Dec)
      skypos_fits       Finds celestial sky position from FITS header
      ttypes            Prints all column names in binary table
      wrfitsbin         Write binary table when pointer array is given
      writefits         Write FITS IMAGE extension
      wrmfitscols       Write multiple FITS binary table columns

      Version 1.1 as of 2012-09-27

***************************************************************
*/

//  Call randomize function because 'ranstr' is used
//  both in fits_ch_keyw and fits_bintable_poke

randomize;
write,"Function 'randomize' has been called from 'mfits.i'";

/* Function listhead */

func listhead( fh )
/* DOCUMENT listhead, fh
   or       list = listhead( fh )

   makes a list of all FITS header cards

   SEE ALSO:  fits_info

   2008-04-04/NJW
*/
{
   local cards; eq_nocopy, cards, _car(fh,1);

   if( am_subroutine() ) {
      for(i=1; i<=numberof(cards); i++) {
         write,cards(i);
      }
   } else {
      return cards;
   }
}

/* Function nfits_extens */

func nfits_extens( filename )
/* DOCUMENT number = nfits_extens( filename )

   Returns the number of last extension in the file.

   2006-02-07/NJW

*/
{
   local fh, list;
   fh = fits_open( filename );
   list = fits_list(fh);
   fits_close, fh;
   return numberof(list)-1;
}


/* Function fxpar */

func fxpar( fh, keyname, count= )
/* DOCUMENT value = fxpar( fh, keyname )

   For reading a keyword value from a FITS header

   2006-02-07/NJW

*/
{
   return fits_get( fh, keyname );
}


/* Function writefits */

func writefits( filename_or_fh, data_array, cont=, clobber=, xax=, yax=, zax= )
/* DOCUMENT writefits, filename_or_fh, data_array, cont=, clobber=, xax=, yax=, zax=

   For writing an array as an IMAGE extension in FITS.
   If the first argument is a string scalar then it is assumed to be a filename
   and if it exists beforehand then the 'clobber' keyword must be set to overwrite
   it. Else it will be created.
   If the first argument is a file handle, then it is assumed to be an open file
   and the extension will be appended to the file. There is no way to append
   an extension to a file that has been closed.

   Called as a functon with keyword 'cont' set : returns the filehandle and leaves
   the file open in order to allow for more extensions to be added.

   Keywords xax, yax, and zax: arrays with coordinates
                first and last elements are used

   2006-02-10/NJW

*/
{

   if( typeof(filename_or_fh) == "string" ) {
      filename = filename_or_fh;
      fh = [];
   } else if( typeof(filename_or_fh) == "list" ) {
      fh = filename_or_fh;
      filename = "";
   } else {
      write,"writefits: invalid first argument";
      return [];
   }
   if( is_void(fh) ) {

      if( file_test( filename ) ) {
         if( is_void(clobber) ) {
            write,format="writefits: %s exists already, no action!\n", filename;
            return;
         } else {
            remove, filename;
         }
      }
   }

   if( is_void(fh) ) {
      handle = fits_create( filename );
      fits_set, handle,"EXTEND",'T',"There may be extensions";
      fits_write_header, handle;
   } else handle = fh;
   fits_new_hdu, handle, "IMAGE";
   fits_set, handle, "BITPIX", fits_bitpix_of(data_array),"Datatype";
   sz = dimsof(data_array);
   fits_set_dims, handle, sz;
   if( numberof(xax) && sz(1) >= 1 ) {
      fits_set, handle, "CRPIX1", 1, "Reference pixel for axis 1";
      fits_set, handle, "CRVAL1", double(xax(1)), "Reference coordinate for axis 1";
      fits_set, handle, "CDELT1", (xax(0)-xax(1))/double(sz(2)), "Pixel size unit for axis 1";
   }
   if( numberof(yax) && sz(1) >= 2 ) {
      fits_set, handle, "CRPIX2", 1, "Reference pixel for axis 2";
      fits_set, handle, "CRVAL2", double(yax(1)), "Reference coordinate for axis 2";
      fits_set, handle, "CDELT2", (yax(0)-yax(1))/double(sz(3)), "Pixel size unit for axis 2";
   }
   if( numberof(zax) && sz(1) >= 3 ) {
      fits_set, handle, "CRPIX3", 1, "Reference pixel for axis 3";
      fits_set, handle, "CRVAL3", double(zax(1)), "Reference coordinate for axis 3";
      fits_set, handle, "CDELT3", (zax(0)-zax(1))/double(sz(4)), "Pixel size unit for axis 3";
   }

   kwds_put, handle;

   fits_write_header, handle;
   fits_write_array, handle, data_array;

   if( cont ) {
      return handle;
   } else {
      fits_close, handle;
      return [];
   }

}

/* Function readfits */

func readfits( dol, skiptest= )
/* DOCUMENT image = readfits( dol, skiptest= )

   For reading an array from an IMAGE extension in FITS
   The argumenent 'dol' is the filename combined with
   extension designation such as:
    fitsfile.fits+12, fitsfile.fits[3], fitsfile.fits[EARTHMAP]
   Note that extension number counting starts with 0 for the
   primary header (unlike original yorick fits functions, where
   counting begins with 1 (one)).

   Keyword  skiptest:  Causes skipping the file existence test

   2006-02-10/NJW

*/
{

   local filename, extno;

   get_exten_no, dol, filename, extno;
   if( !skiptest ) {
      if( !file_test(filename) ) {
         write,"READFITS: Cannot find "+filename;
         return [];
      }
   }
   fh = fits_open( filename );
   fits_goto_hdu, fh, extno+1;
   image = fits_read_array(fh);
   fits_close, fh;
   return image;

}

/* Function headfits */

func headfits( dol, nocheck= )
/* DOCUMENT hdr = headfits( dol, nocheck= )

   For reading a HDU header from a FITS extension
   Keyword nocheck to avoid checking for extension number
   exists in file [this has caused problems in certain
   swg.fits files].

   2006-02-03/NJW
   2007-04-19/NJW, Added nocheck keyword

*/
{

   local filename, extno;

   get_exten_no, dol, filename, extno;
   if( !file_test(filename) ) {
      write,"HEADFITS: File is not found: "+filename;
      return [];
   }
   if( extno < 0 ) {
      write,"HEADFITS: Extension is not found"+dol;
      return [];
   }
   fh = fits_open(filename);
   if( nocheck ) {
      num_exts = extno+1;
   } else {
      num_exts = numberof(fits_list(fh));
   }
   if( extno < num_exts ) {
      fh = fits_goto_hdu( fh, extno+1);
   } else {
      write,"Extension number too large";
      fits_close, fh;
      return [];
   }
   fits_close, fh;
   return fh;
}

/* Function rdfitscol */

func rdfitscol( dol, col_iden, silent=, ci= )
/* DOCUMENT coldata = rdfitscol( dol, col_iden, silent=, ci= )

   For reading a column from a binary table FITS
   extension. The column identifier 'col_iden' can
   be the column number or the name of the column
   (case insensitive) except if keyword 'ci' (case insist) is
   set.

   2006-02-03/NJW
   2006-11-15/NJW Updated to handle vector columns as in IDL:
                  array n x m produces m rows where each bin
                  contains n values
   2008-10-12/NJW Value returned is corrected for TZERO

*/
{

   local fitsname, extno;
   chat = is_void(silent);

   get_exten_no, dol, fitsname, extno;
   if( extno > 0 ) {
      fh = fits_open( fitsname );
      fits_goto_hdu, fh, extno+1;
      naxis2 = fxpar( fh, "NAXIS2");
      if( naxis2 == 0 ) {
         if( chat ) write,format="RDFITSCOL: No rows in table %s\n",dol;
         return [];
      }
      if( "string" == typeof(col_iden) ) {
         col_iden = strtrim(col_iden);
         if(!ci) col_iden = strupcase(col_iden);
         k = 1;
         colnum = 0;
         keynam = "TTYPE"+swrite(format="%i",k);
         while( colname = fits_get(fh, keynam) ) {
            if( colname == col_iden ) {
               colnum = k;
               break;
            }
            keynam = "TTYPE"+swrite(format="%i",++k);
         }
         if( !colnum ) {
            if( chat ) write,"RDFITSCOL: Column "+col_iden+" was not found";
            return [];
         }
      } else {
         colnum = col_iden;
      }
   } else {
      if( chat ) write,"RDFITSCOL: Invalid extension number";
      return [];
   }

   p = fits_read_bintable(fh, select=colnum);
   tzero = fxpar( fh, swrite(format="TZERO%i", colnum));
   if( is_void(tzero) ) tzero = 0;
   fits_close, fh;
   // return *p(colnum);
   dms = dimsof(*p);
   if( structof(*p) == string ) {
      return dms(1) == 2 ? transpose(*p) : *p ;
   } else {
      return dms(1) == 2 ? transpose(*p) + tzero : *p + tzero;
   }

}

/* Function get_exten_no */

func get_exten_no( fits_name_extno_in, &fits_name, &extno, tub=, nores=, casein= )
/* DOCUMENT get_exten_no, filename_extno, >filename, >extno[, tub=][, nores=][, casein=]

   For getting the filename and extension number from a DOL
   such as asdf.fits[12], asdf.fits+13, asdf.fits[EXTNAME],
   or asdf.fits[EXTNAME,EXTVER,XTENSION]

   Keyword "tub"  implies that {} are used in stead of []
   Keyword "nores" implies that if the DOL has the format ...[EXTNAME]
      then no attempt will be made to open the file to dig out the 'extno'
      Instead the inner string will be returned in 'extno'
   Keyword "casein" to force case insensitive

   2006-02-03/NJW

*/
{

   fits_name_extno = strtrim( fits_name_extno_in );

   len = strlen(fits_name_extno);
   pos = len;
   str_exten_no = "";
   extno = -1; // make sure it is always defined
   begchar = is_void(tub) ? "[" : "{";
   endchar = is_void(tub) ? "]" : "}";

   last = strpart(fits_name_extno, pos:);

   if( last == endchar || is_digit(last) ) { /* Still possible */

      if( last == endchar ) {

          /* Expects   [123] or [EXTNAME] */
          /* look for [ or x character */
          p = strpos(fits_name_extno,begchar,0,rev=1);
          if( p < 1 ) {
             extno = 0;
             fits_name = fits_name_extno;
             str_exten = "";
          } else {
             str_exten = strpart(fits_name_extno,p+1:pos-1);
             fits_name = strpart(fits_name_extno,:p-1);
             if( is_digit(str_exten) ) {
                extno = toint(str_exten);
             } else {
                extno = -1;
                if( is_void(nores) ) {
                   nlastext = nfits_extens(fits_name);
                   // check for EXTNAME,EXTVER,XTENSION convention
                   // force comma convention
                   str_exten = strstrrepl( str_exten, ":", ",");
                   if( casein ) str_exten = strupcase( str_exten );
                   tok = strsplit( str_exten,",");
                   ntok = numberof(tok);
                   if( ntok >= 2 ) {
                      in_extver = toint(tok(2));
                      str_exten = tok(1);
                   } else { // EXTVER is absent - set to 1
                      in_extver = 1;
                      // str_exten can be carried over, no delimiters are found
                   }
                   for( i = 0; i <= nlastext; ++i ) {
                      hdr = headfits(fits_name+"+"+itoa(i));
                      extname = fxpar(hdr,"EXTNAME");
                      if( casein ) extname = strupcase( extname );
                      extver = fxpar(hdr,"EXTVER");
                      if( !numberof(extver) ) extver = 1;
                      if( numberof(extname) ) {
                         extname = strtrim(extname);
                         if( extname == strtrim(str_exten) \
                                 && in_extver == extver ) {
                            extno = i;
                            break;
                         }
                      }
                   }
                }
             }
          }


       } else {  /* Expect something like +123 */

          flag = 1;
          while( flag ) {
             stp = strpart(fits_name_extno,pos:pos);
             if( is_digit(stp) )  {
                 str_exten_no = stp+str_exten_no;
             } else {
                 flag = 0;
             }
             pos = pos - 1;
          }
          if( stp == "+" ) {
            extno = toint(str_exten_no);
            fits_name = strpart(fits_name_extno,:pos);
            str_exten = strpart(fits_name_extno,pos+2:999);
         } else {
            extno = 0;
            fits_name = fits_name_extno;
            str_exten = "";
         }


       }

   } else {
      extno = 0;
      fits_name = fits_name_extno;
      str_exten = "";
   }

   if( nores ) extno = str_exten;

}

/* Function wrmfitscols */

func wrmfitscols( filename_or_fh, colname, coldata, .., var=, cont=, clobber=, extname= )
/* DOCUMENT  wrmfitscols, filename_or_fh, colname, coldata, .., var=, cont=, clobber=, extname=

   Write multiple FITS columns to a file.

   Keyword 'var' (scalar or array) can be set to give the column number(s) with variable length
   records i.e. the 1PX(max) convention. The coldata variable for such a column is disregarded
   and only used as a placeholder.

   After the filename the arguments are alternating "colname, coldata"
   'colname' will be converted to upper case.
   Setting keyword 'clobber' will cause an overwrite of the file
   if it exists beforehand. Keyword 'extname' will add the EXTNAME
   to the header.
   If the first argument is a string scalar then it is assumed to be a filename
   and if it exists beforehand then the 'clobber' keyword must be set to overwrite
   it. Else it will be created.
   If the first argument is a file handle, then it is assumed to be an open file
   and the extension will be appended to the file. There is no way to append
   an extension to a file that has been closed.

   Called as a functon with keyword 'cont' set : returns the filehandle and leaves
   the file open in order to allow for more extensions to be added.

   Limitations for this version:
      The first column cannot be of variable length i.e. 'var=1' is not possible
      since the input data give the number of rows.

   2006-02-08/NJW
   2006-08-17/NJW Updated to handle vector columns as in IDL:
                  array n x m produces m rows where each bin
                  contains n values
   2007-02-22/NJW Updated with continue option
   2008-10-02/NJW Updated with variable length option
   2010-11-19/NJW Updated with variable length option for several columns

*/
{
   require,"idlx.i";
   require,"kfits.i"; // that contains a correction relative to fits.i

   if( numberof(coldata) < 1 ) {
      write,format="No data present in first argument, skip writing%s\n","";
      return;
   }

// Determine whether 'filename_or_fh' is a file or a FITS handle

   if( typeof(filename_or_fh) == "string" ) {
      filename = filename_or_fh;
      fh = [];
   } else if( typeof(filename_or_fh) == "list" ) {
      fh = filename_or_fh;
      filename = "";
   } else {
      write,"writefits: invalid first argument";
      return [];
   }

// Test for file existence - remove if it is to be overwritten

   if( is_void(fh) ) {
      if( file_test( filename ) ) {
         if( is_void(clobber) ) {
            write,format="wrmfitscols: %s exists already, no action!\n", filename;
            return;
         } else {
            remove, filename;
         }
      }
   }

// If new file then create file handle and write the primary data header unit

   if( is_void(fh) ) {
      fh = fits_create(filename);
      fh = fits_set(fh,"EXTEND",'T',"There may be extensions");
      fits_write_header, fh;
   }
   fits_new_bintable, fh;
   p = array(pointer, 1);

   if( !is_void(extname) ) fits_set,fh,"EXTNAME",extname,"Name of extension";

// Add data for column 1 to the array of pointers 'p'

   numcol = 1;
   ttype = "TTYPE"+swrite(format="%i",numcol);
   dm = dimsof(coldata);
   if( dm(1) == 1 ) {
      nrows = dm(2);
      p(1) = &coldata;
   } else if( dm(1) == 2 ) {
      // Case of vector bins. Assume that each column goes into a single bin
      // e.g. array 4x3 will produce 3 rows and 4 numbers in each bin
      // Rearranging seems to be required
      tmp = transpose(coldata);
      nrows = dm(3);
      p(1) = &tmp;
   } else {
      write,format="Column %d has illegal format\n", 1;
      return;
   }
   fits_set, fh, ttype, strupcase(colname), "Name of column 1";

// Prepare for variable length column(s)

   stype = [];
   if( is_void(var) ) kvar = 0;
   else kvar = var;

   while( more_args() ) {
      ++numcol;
      scol = swrite(format="%i",numcol);
      ttype = "TTYPE"+scol;
      cname = next_arg();
      cdata = next_arg();
      if( nallof(kvar - numcol) ) { // check for match with 'kvar' (array or scalar)
         if( structof(cdata) == short ) {
            grow, stype, 'I';
         } else if( structof(cdata) == long || structof(cdata) == int ) {
            grow, stype, 'J';
         } else if( structof(cdata) == float ) {
            grow, stype, 'E';
         } else if( structof(cdata) == double ) {
            grow, stype, 'D';
         } else error,"Data type for variable length not supported";
         cdata = array( long, 2, nrows );
      }
      dm = dimsof(cdata);
      if( dm(1) == 1 ) {
         nrws = dm(2);
         grow, p, &cdata;
      } else if( dm(1) == 2 ) {
         // Case of vector bins. Assume that each column goes into a single bin
         // e.g. array 4x3 will produce 3 rows and 4 numbers in each bin
         // Rearranging seems to be required
         nrws = dm(3);
         tmp = transpose(cdata);
         grow, p, &tmp;
      } else {
         write,format="Column %d has illegal format\n", numcol;
         return;
      }
      if( nrws != nrows ) {
         write,format="Error in number of rows in column #%i\n", numcol;
         fits_close, fh;
         return;
      }
      fits_set, fh, ttype, strupcase(cname), "Name of column "+scol;
   }

   kwds_put, fh;

   fits_write_bintable, fh, p, var=var, stype=stype;
   if( cont ) {
      return fh;
   } else {
      fits_close, fh;
      return [];
    }
}

/* Function skypos_fits */

struct s_Coords {
   int flag;
   string ctype1, ctype2;
   double crval1, crval2, crpix1, crpix2;
   double cd1_1, cd1_2, cd2_1, cd2_2;
   double scale; // degrees per pixel regardless of rotation
}

func skypos_fits( arg1, &pix1, &pix2, &coord1, &coord2, to_sky=, to_pix=, r1=,r2=, silent=)
/* DOCUMENT skypos_fits, arg1, (>)pix1, (>)pix2, (>)coord1, (>)coord2, to_sky=, to_pix=, r1=,r2=, silent=

   Get sky position for a given position in FITS image
   pix1 and pix2 are pixel numbers starting count with 1 (to_sky=1)
   i.e. 1 larger than in C and IDL
   or pixel numbers from coordinates (to_pix=1)

   First argument is either of:
             1) a FITS DOL
             2) a FITS header
             3) an instance of the struct 's_Coords'

    2003-09-16/NJW
    2003-12-17/NJW Updated to derive pixel numbers from coords
*/

{
   require, "matrix.i";

   vb = silent ? 0 : 1;
   if( !to_sky ) to_sky = 0;
   if( !to_pix ) to_pix = 0;
   if( to_sky + to_pix != 1 ) {
      write,"Exactly one of the keywords 'to_sky' or 'to_pix' must be set";
      return;
   }

   s_coords = [];
   if( typeof(arg1) == "string" ) { // 1. argument is a DOL

      file_ext = arg1;

      local file, extno;
      get_exten_no, file_ext, file, extno;

      if( !file_test(file) ) {
         write,"file "+file+" not found!";
         return;
      }

      hdr = headfits(file_ext);
      if( is_void(hdr) ) return;
      if( is_void(fits_get(hdr,"BITPIX") ) ) {
         write,"Requested extension ("+itoa(extno)+") is not found!";
         return;
      }
      s_coords = get_wcs( arg1 );

   } else if( typeof(arg1) == "struct_instance" ) {
      s_coords = arg1;
   } else s_coords = get_wcs( arg1 );

   dr = pi / 180;

   crval1 = s_coords.crval1;
   crval2 = s_coords.crval2;
   crpix1 = s_coords.crpix1;
   crpix2 = s_coords.crpix2;
   cd1_1 = s_coords.cd1_1;
   cd1_2 = s_coords.cd1_2;
   cd2_1 = s_coords.cd2_1;
   cd2_2 = s_coords.cd2_2;

 // Replace crpix values if keywords are given
   if( !is_void(r1) ) crpix1 = r1;
   if( !is_void(r2) ) crpix2 = r2;

   det = cd1_1 * cd2_2 - cd1_2 * cd2_1;

   posangle = atan(cd1_2,cd1_1) / dr;

   cdmat = [[cd1_1,cd2_1],[cd1_2,cd2_2]];

   if( vb ) {
      write,format="CRVAL1 = %f, CRVAL2 = %f\n", crval1, crval2;
      write,format="Derived POSANGLE = %f\n", posangle;
      write,format="CRPIX1 = %f, CRPIX2 = %f\n", crpix1, crpix2;
      write,format="CD1_1 = %f, CD1_2 = %f\n", cd1_1, cd1_2;
      write,format="CD2_1 = %f, CD2_2 = %f\n", cd2_1, cd2_2;
   }


   a0 = crval1 * dr;
   ca0 = cos(a0);
   sa0 = sin(a0);
   d0 = crval2 * dr;
   cd0 = cos(d0);
   sd0 = sin(d0);

// transformation matrices:

   t1 = [[ca0,sa0,0],[-sa0,ca0,0],[0,0,1]];
   t2 = [[cd0,0,sd0],[0,1,0],[-sd0,0,cd0]];

   t = t1(,+)*t2(+,);

   if( to_sky ) {

      // star position in image (y,z) expressed in degrees;
      yz = cdmat(,+) * [pix1-crpix1,pix2-crpix2](+);
      y = atan(yz(1) * dr);
      z = atan(yz(2) * dr);
     // unit vector expressed in image system;
      vi = [0,sin(y),sin(z)];
      vi(1) = sqrt(1. - vi(2)^2 - vi(3)^2);

     // star position in eq system

      ve = t(,+) * vi(+);

     // derive RA and Dec;

      d = asin(ve(3));
      a = zero2pi(atan(ve(2),ve(1)));
      ddeg = d / dr;
      adeg = a / dr;

      if( vb ) write,format="RA: %f, Dec: %f\n",adeg,ddeg;

      coord1 = adeg;
      coord2 = ddeg;

   } else {

      arad = coord1 * dr;
      drad = coord2 * dr;

      ve = [cos(arad)*cos(drad),sin(arad)*cos(drad),sin(drad)];
      vi = LUsolve( t )(,+) *  ve(+,);

      yz = tan(asin(vi(2:3))) / dr;

      p = LUsolve(cdmat)(,+) * yz(+) + [crpix1,crpix2];

      pix1 = p(1);
      pix2 = p(2);

   }

   return;

}

/* Function simple_peak */

func simple_peak( dol, ra_obj, dec_obj, peak_size, bkg_size, chat= )
/* DOCUMENT peaksize = simple_peak( dol, ra_obj, dec_obj, peak_size, bkg_size, chat= )

   Calculates the number of counts in an area peak_size x peak_size around
   the source placed at (ra_obj, dec_obj) in a FITS image (NAN values are
   replaced with zeros). The background is evaluated in a region bkg_size x bkg_size
   around the source position.

   If bkg_size <= peak_size then the background is ignored (set to zero).

   2006-12-28/NJW
*/
{
   require, "basic.i";
   require, "idlx.i";

   im = readfits(dol);
   if( is_void(im) ) {
      write,"No such DOL: "+dol;
      return [];
   } else im = nan2zero(double(im));

   sz = dimsof(im);
   skypos_fits, dol, pix1, pix2, ra_obj, dec_obj, to_pix=1, silent=1;
   pix1 = long(pix1 + 0.5);
   pix2 = long(pix2 + 0.5);
   if( pix1 < 1 || pix2 < 1 || pix1 > sz(2) || pix2 > sz(3) ) {
      write,"Warning - object outside the image";
   }
   sbox = extract_box(im,pix1,pix2,peak_size,peak_size,cen=1);
   source = sum(sbox);
   nsource = numberof(sbox);
   if( chat ) {
      write,format="Total in source box: %f\n", source;
      write,format="Num pixels in source box: %i\n", nsource;
   }
   if( bkg_size > peak_size ) {
      bbox = extract_box(im,pix1,pix2,bkg_size,bkg_size,cen=1);
      totbkg = sum(bbox);
      ntotbkg = numberof(bbox);
      if( chat ) {
         write,format="Total in bkg box: %f\n", totbkg;
         write,format="Num pixels in bkg box: %i\n", ntotbkg;
      }
      bkg = totbkg - source;
      nbkg = ntotbkg - nsource;
      if( chat ) {
         write,format="Bkg in bkg ring: %f\n", bkg;
         write,format="Num pixels in bkg ring: %i\n", nbkg;
         write,format="Bkg counts/pixel: %f\n", bkg / nbkg;
      }
      correction = (nsource * bkg) / nbkg;
   } else {
      correction = 0.0;
   }

   return source - correction;

}

/* Function gz_proxy_file */

func gz_proxy_file( filename, dir=, silent= )
/* DOCUMENT non_gzfilename =  gz_proxy_file( filename, dir=, silent= )

   The filename must be given without the trailing '.gz'.
   Returns the name of the proxy file for a gzipped file
   The original file is copied to /scratch/njw/proxies and unzipped

      2006-02-02/NJW
      2007-01-29/NJW, updated to use derivative of file name
           in order to avoid clashes. Directory can be specified.
*/
{

   require, "idlx.i";
   require, "basic.i";

   if( is_void(filename) ) {
      write,"Syntax: newfile = gz_proxy_file( filename )";
      return [];
   }
   if( is_void(silent) ) silent = 0;
   vb = silent == 0 ? 1 : 0;

// Define directory where to put the proxy file

   if( is_void(dir) ) {
      dir = "/scratch/njw/proxies/";
   }

   if( ! file_test(filename) ) {
      //+ write,"#2# did not find "+filename
      if( file_test(filename+".gz") ) { // found in compressed format
         sname = fullpath(filename);
         sname = strcharrepl( sname,"/","_");
         if( strlen(sname) > 150 ) sname = strpart(sname, -149:0);
         //+ proxy_name = get_next_filename("gz_proxy_??????.fits",dir="/net/uhuru/r1/pool/pool1");
         proxy_name = app_slash(dir)+sname;
         if( !file_test( proxy_name ) ) { // Only make a copy if not found
            if(vb) write,format="Do: > %s\n", "cp "+filename+".gz "+proxy_name+".gz";
            system,"cp "+filename+".gz "+proxy_name+".gz";
            system,"gunzip "+proxy_name+".gz";
         } else {
            if(vb) write,format="Exists already: %s\n", proxy_name;
         }
         return proxy_name;
         //+ write,"#3# New filename = "+filename
      } else {
         if(vb) {
            write,"GZ_PROXY_FILE: Neither "+filename;
            write," nor "+filename+".gz was found";
         }
         return [];
      }
   } else return filename;  // no change if file exists

}

/* Function kwds_init */

func kwds_init( value )
/* DOCUMENT kwds_init[, value]

    Initialize the in-memory keywords of the same type as 'value'.
    Omitting 'value' causes a complete initialization.

    SEE ALSO: kwds_set, kwds_get, kwds_put, kwds_init, kwds_del

    2007-02-04/NJW
*/
{

   require, "idlx.i";

   extern kwds_rnames, kwds_inames, kwds_snames;
   extern kwds_rvalues, kwds_ivalues, kwds_svalues;
   extern kwds_rcomments, kwds_icomments, kwds_scomments;

   if( is_void(value) ) {
      //+ write,"Initializing all keywords";
      kwds_rnames = [];
      kwds_rvalues = [];
      kwds_rcomments = [];
      kwds_inames = [];
      kwds_ivalues = [];
      kwds_icomments = [];
      kwds_snames = [];
      kwds_svalues = [];
      kwds_scomments = [];
      return;
   }

   if( "double" == typeof(value) || "float" == typeof(value) ) {
      //+ write,"Initializing double keywords"
      kwds_rnames = [];
      kwds_rvalues = [];
      kwds_rcomments = [];
   } else if( "int" == typeof(value) || "long" == typeof(value) ) {
      //+ write,"Initializing long keywords"
      kwds_inames = [];
      kwds_ivalues = [];
      kwds_icomments = [];
   } else if( "string" == typeof(value) ) {
      //+ write,"Initializing string keywords"
      kwds_snames = [];
      kwds_svalues = [];
      kwds_scomments = [];
   } else {
      write,"KWDS_INIT: No action since data type \""+typeof(value)+"\" is not supported";
   }

}

/* Function kwds_put */

func kwds_put( &fh )
/* DOCUMENT fh = kwds_put( fh )

    Update the filehandle 'fh' with all keyword information
    from database in memory.

    SEE ALSO: kwds_set, kwds_get, kwds_init, kwds_del

    2007-02-04/NJW
*/
{

   require, "idlx.i";

   extern kwds_rnames, kwds_inames, kwds_snames;
   extern kwds_rvalues, kwds_ivalues, kwds_svalues;
   extern kwds_rcomments, kwds_icomments, kwds_scomments;

   for( i = 1; i <= numberof(kwds_rnames); i++ ) {
      fits_set, fh, kwds_rnames(i),kwds_rvalues(i),kwds_rcomments(i);
   }
   for( i = 1; i <= numberof(kwds_inames); i++ ) {
      fits_set, fh, kwds_inames(i),kwds_ivalues(i),kwds_icomments(i);
   }
   for( i = 1; i <= numberof(kwds_snames); i++ ) {
      if( kwds_snames(i) == "HISTORY" || kwds_snames(i) == "COMMENT" ) {
         fits_set, fh, kwds_snames(i),kwds_svalues(i);
      } else {
         fits_set, fh, kwds_snames(i),kwds_svalues(i),kwds_scomments(i);
      }
   }

   return fh;

}

/* Function kwds_set */

func kwds_set( name, value, comment )
/* DOCUMENT kwds_set, keyword_name, value, comment

    Update keyword database with keyword information

    SEE ALSO: kwds_get, kwds_put, kwds_init, kwds_del

    2007-02-04/NJW
*/
{

   require, "idlx.i";

   name = strupcase(name);
   if( is_void(comment) ) comment = "";

   extern kwds_rnames, kwds_inames, kwds_snames;
   extern kwds_rvalues, kwds_ivalues, kwds_svalues;
   extern kwds_rcomments, kwds_icomments, kwds_scomments;

   if( "double" == typeof(value) || "float" == typeof(value) ) {
      // see if keyword is already there
      w = where( name == kwds_rnames );
      if( numberof(w) > 0 ) {
         kwds_rvalues(w(1)) = value;
         kwds_rcomments(w(1)) = comment;
      } else {
         grow, kwds_rnames, name;
         grow, kwds_rvalues, double(value);
         grow, kwds_rcomments, comment;
      }
   } else if( "int" == typeof(value) || "long" == typeof(value) ) {
      // see if keyword is already there
      w = where( name == kwds_inames );
      if( numberof(w) > 0 ) {
         kwds_ivalues(w(1)) = value;
         kwds_icomments(w(1)) = comment;
      } else {
         grow, kwds_inames, name;
         grow, kwds_ivalues, long(value);
         grow, kwds_icomments, comment;
      }
   } else if( "string" == typeof(value) ) {
      // avoid overwriting for special keywords
      if( name == "HISTORY" || name == "COMMENT" ) {
         grow, kwds_snames, name;
         grow, kwds_svalues, value;
         grow, kwds_scomments, ""; // to maintain accounting
      } else {

         // see if keyword is already there
         w = where( name == kwds_snames );
         if( numberof(w) > 0 ) {
            kwds_svalues(w(1)) = value;
            kwds_scomments(w(1)) = comment;
         } else {
            grow, kwds_snames, strupcase(name);
            grow, kwds_svalues, value;
            grow, kwds_scomments, comment;
         }
      }
   } else {
      write,"KWDS_SET: No action for "+name+" since data type \""+typeof(value)+"\" is not supported";
   }

}

/* Function kwds_setlongstr */

func kwds_setlongstr( keyword, long_string, comment )
/* DOCUMENT kwds_setlongstr, keyword, long_string, comment

    Use kwds_set several times to split up 'long_string'.
    Use 'keyword' as it is for the first part, and then
    truncate to 6 letters (if necessary) and count from
    01 thru 99.

    SEE ALSO: kwds_init, kwds_set, kwds_del, kwds_put.

    2012-10-26/NJW

*/
{
   if( typeof(long_string) != "string" ) error,"Called with non-string 2. argument";

   lenk = strlen(keyword);
   lenl = strlen(long_string);
   if( lenl < 30 ) { // No real use for this function
      kwds_set, keyword, long_string, comment;
      return;
   }

   keyw6 = strpart(keyword,1:6);
   count = 0;

   while( lenl > 0 ) {
      body = strpart( long_string, 1:60 );
      long_string = strpart( long_string, 61: );
      lenl = strlen(long_string);
      cont = lenl == 0 ? "" : " &";
      if( count == 0 ) {
         kwds_set, keyword, body+cont;
      } else {
         kwds_set, keyw6+itoa(count,2), body+cont;
      }
      count++;
   }
   if( strlen(comment) ) kwds_set, keyw6+itoa(count,2), "COMMENT", comment;
}

/* Function kwds_del */

func kwds_del( name )
/* DOCUMENT kwds_del, keyword_name

    Delete a keyword

    Will not delete BYTPIX and HISTORY.

    SEE ALSO: kwds_set, kwds_get, kwds_put, kwds_init

    2007-02-20/NJW
    2008-06-17/NJW, may now delete "COMMENT" keywords.
*/
{

   require, "idlx.i";

   name = strupcase(name);

   extern kwds_rnames, kwds_inames, kwds_snames;
   extern kwds_rvalues, kwds_ivalues, kwds_svalues;
   extern kwds_rcomments, kwds_icomments, kwds_scomments;

   // Check if deletion is prohibited by keyword name

   if( name == "BYTPIX" ) { write,"Cannot delete BYTPIX"; return; }
   // if( name == "COMMENT" ) { write,"Cannot delete COMMENT"; return; }
   if( name == "HISTORY" ) { write,"Cannot delete HISTORY"; return; }

   // see if keyword is from 'real' group
   w = where( name == kwds_rnames );
   if( numberof(w) > 0 ) {
      m = where( name != kwds_rnames );
      if( numberof(m) > 0 ) {
         kwds_rnames = kwds_rnames(m);
         kwds_rvalues = kwds_rvalues(m);
         kwds_rcomments = kwds_rcomments(m);
      } else {
         kwds_rnames = [];
         kwds_rvalues = [];
         kwds_rcomments = [];
      }
      return;
   }

   // see if keyword is from 'integer' group
   w = where( name == kwds_inames );
   if( numberof(w) > 0 ) {
      if( numberof(m) > 0 ) {
         m = where( name != kwds_inames );
         kwds_inames = kwds_inames(m);
         kwds_ivalues = kwds_ivalues(m);
         kwds_icomments = kwds_icomments(m);
         return;
      } else {
         kwds_inames = [];
         kwds_ivalues = [];
         kwds_icomments = [];
      }
   }

   // see if keyword is from 'string' group
   w = where( name == kwds_snames );
   if( numberof(w) > 0 ) {
      m = where( name != kwds_snames );
      if( numberof(m) > 0 ) {
         kwds_snames = kwds_snames(m);
         kwds_svalues = kwds_svalues(m);
         kwds_scomments = kwds_scomments(m);
      } else {
         kwds_snames = [];
         kwds_svalues = [];
         kwds_scomments = [];
      }
      return;
   }

}

/* Function kwds_get */

func kwds_get( name, &comment )
/* DOCUMENT value = kwds_get( keyword_name, >comment )

    Get the value of a keyword previously stored in memory
    by 'kwds_set'

    SEE ALSO: kwds_set, kwds_put, kwds_init, kwds_del

    2008-06-27/NJW
*/
{

   require, "idlx.i";

   name = strupcase(name);

   extern kwds_rnames, kwds_inames, kwds_snames;
   extern kwds_rvalues, kwds_ivalues, kwds_svalues;
   extern kwds_rcomments, kwds_icomments, kwds_scomments;

   // see if keyword is from 'real' group
   w = where( name == kwds_rnames );
   if( numberof(w) > 0 ) {
      comment = kwds_rcomments(w);
      return kwds_rvalues(w);
   }

   // see if keyword is from 'integer' group
   w = where( name == kwds_inames );
   if( numberof(w) > 0 ) {
      comment = kwds_icomments(w);
      return kwds_ivalues(w);
   }

   // see if keyword is from 'string' group
   // Special treatment for "COMMENT" and "HISTORY"
   //    i.e. they have no comment fields
   w = where( name == kwds_snames );
   if( numberof(w) > 0 ) {
      if( name == "COMMENT" || name == "HISTORY" ) {
         comment = [];
      } else {
         comment = kwds_scomments(w);
      }
      return kwds_svalues(w);
   }

   // The keyword was not found
   comment = [];
   return [];

}


/* Function admfitscols */

func admfitscols( filename, colname, coldata, .. , nob= )
/* DOCUMENT  admfitscols, filename, colname, coldata, .., nob=

   Add extra column data to an existing FITS binary table file in
   extension number 1. The number of rows is increased.
   After the filename the arguments are alternating "colname, coldata"
   'colname' will be converted to upper case and they must match
   the existing names. Similarly the data types must match existing
   ones.

   Keyword 'nob' (no back up) prevents the automatic backup

   SEE ALSO: fits_add_rows

   2007-08-01/NJW
   2007-08-13/NJW, nob keyword added

*/
{
   ydir = strlen(get_env("OSTYPE")) == 0 ? "c:/yo/" : "" ;
   require,ydir+"idlx.i";
   require,ydir+"basic.i";
   require,ydir+"kfits.i"; // that contains a correction relative to fits.i

   if( numberof(coldata) < 1 ) {
      write,format="No data present in first argument, skip writing%s\n","";
      return;
   }
   if( !file_test( filename ) ) {
      write,format="admfitscols: %s does not exist, quit!\n", filename;
      return;
   }
   if( is_void(nob) ) nob = 0;

//  read all data in existing file and find column names; close file afterwards

   old_fh = fits_open( filename );
   fits_goto_hdu, old_fh, 2; //  Extension 1 (Yorick counting starts at 1)
   old_p = fits_read_bintable( old_fh );
   fits_close, old_fh;

// Make a backup copy of old file and delete it

   if( !nob ) back, filename;
   remove, filename;

// Initiate the new version of the file

   fh = fits_create(filename);
   fh = fits_set(fh,"EXTEND",'T',"There may be extensions");
   fits_write_header, fh;

   fits_new_bintable, fh;
   p = array(pointer, 1);

//  get existing column names to ensure a match with new ones

   ncols = dimsof( old_p )(2);
   //+ print,"ncols= ",ncols;
   old_colname = array(string,ncols);
   for( i = 1; i <= ncols; i++ ) {
      keyname = swrite(format="TTYPE%i",i);
      cname = fxpar( old_fh, keyname );
      if( is_void(cname) ) {
         write,format="##2## problem with column name #%i\n", i;
         return;
      } else old_colname(i) = cname;
   }

//   Check consistency between the given arguments and the existing file

   colname = strupcase(colname);
   if( old_colname(1) != colname ) {
      write,format="Colname %s does not match %s\n", colname, filename;
      return;
   }
   if( typeof(*old_p(1)) != typeof(coldata) ) {
      write,format="Datatype mismatch for column %s in file %s\n", colname, filename;
      return;
   }

   dms = dimsof(coldata);
   dms1 = dms(1);
   olddms = dimsof(*old_p(1));
   old_coldata = *old_p(1);
   if( olddms(1) != dms(1) ) {
      write,format="Inconsistent dimensionality in column %s\n", colname;
      return;
   }
   if( olddms(1) == 2 ) {
      old_coldata = transpose(old_coldata);
      olddms = dimsof(old_coldata);
      if( olddms(2) != dms(2) ) {
         write,format="Vector bin inconsistency in column %s\n", colname;
         return;
      }
   }

// append new data to old data for this column

   version = 1;
//  ---- version 1 begin -----
   if( version == 1 ) {
      grow, old_coldata, coldata;
      if( olddms(1) == 2 ) old_coldata = transpose(old_coldata);
      p(1) = &old_coldata;
   }
//  ---- version 1 end -----

//  ---- version 2 begin -----
   if( version == 2 ) {
      if( dms(1) == 2 ) coldata = transpose(coldata);
      p(1) = &coldata;
   }
//  ---- version 2 end -----

   numcol = 1;
   ttype = "TTYPE"+swrite(format="%i",numcol);
   fits_set, fh, ttype, strupcase(colname), "Name of column 1";

   while( more_args() ) {
      scol = swrite(format="%i",++numcol);
      ttype = "TTYPE"+scol;
      cname = strupcase(next_arg());
      cdata = next_arg();

//   Check consistency between the given arguments and the existing file

      if( old_colname(numcol) != cname ) {
         write,format="Colname %s does not match %s\n", cname, filename;
         return;
      }
      if( typeof(*old_p(numcol)) != typeof(cdata) ) {
         write,format="Datatype mismatch for column %s in file %s\n", cname, filename;
         return;
      }

      dms = dimsof(cdata);
      grow, dms1, dms(1);
      olddms = dimsof(*old_p(numcol));
      old_coldata = *old_p(numcol);
      if( olddms(1) != dms(1) ) {
         write,format="Inconsistent dimensionality in column %s\n", cname;
         return;
      }
      if( olddms(1) == 2 ) {
         old_coldata = transpose(old_coldata);
         olddms = dimsof(old_coldata);
         if( olddms(2) != dms(2) ) {
            write,format="Vector bin inconsistency in column %s\n", colname;
            return;
         }
      }

// append new data to old data for this column

//  ---- version 1 begin -----
      if( version == 1 ) {
         grow, old_coldata, cdata;
         if( olddms(1) == 2 ) old_coldata = transpose(old_coldata);
         grow, p, &old_coldata;
      }
//  ---- version 1 end -----
//  ---- version 2 begin -----
      if( version == 2 ) {
         if( dms(1) == 2 ) cdata = transpose(cdata);
         grow, p, &cdata;
      }
//  ---- version 2 end -----

      fits_set, fh, ttype, strupcase(cname), "Name of column "+scol;
   }

   p_out = p;
//  ---- version 2 begin -----
   if( version == 2 ) {
      for( i = 1; i <= numcol; i++ ) {
         old_tmp = *old_p(i);
         tmp = *p(i);
         if( dms1(i) == 2 ) {
            old_tmp = transpose(old_tmp);
            tmp = transpose(tmp);
            grow, old_tmp, tmp;
            old_tmp = transpose(old_tmp);
         } else grow, old_tmp, tmp;
         p_out(i) = &old_tmp;
      }
   }
//  ---- version 2 end -----
   kwds_put, fh;

   fits_write_bintable, fh, p_out;
   fits_close, fh;

}

/* Function fits_add_rows */

func fits_add_rows( dol, num_extra_rows, outfile= )
/* DOCUMENT fits_add_rows, dol, num_extra_rows, outfile=

   Add a number of (empty) rows to an existing FITS binary table file
   in extension 1. Copy all header keywords.
   If no keyword 'outfile' is given the original file will be
   overwritten.

   SEE ALSO: admfitscols

   2008-08-22/NJW

*/
{
   local fh, nrows, filename, extno;

   ptr = rdfitsbin( dol, fh, nrows );

   numcols = numberof(ptr);

  /*
   *  Loop over columns to grow each of them individually
   *  All other data types than 'string' may be two-dimensional
   */

   for( col = 1; col <= numcols; col++ ) {

      tmp = *ptr(col);
      type = typeof(tmp);
      dms = dimsof(tmp);

      if( type == "string" ) {
         grow, tmp, array( string, num_extra_rows );
      } else {
         if( dms(1) == 2 ) {     // in case of 2D array transposition
            tmp = transpose(tmp); // is required since internal
            dms = dimsof(tmp);    // representation is different
         }
         dms(0) = num_extra_rows;
         if( type == "char" ) {
            grow, tmp, array( char, dms );
         } else if( type == "int" ) {
            grow, tmp, array( int, dms );
         } else if( type == "long" ) {
            grow, tmp, array( long, dms );
         } else if( type == "float" ) {
            grow, tmp, array( float, dms );
         } else if( type == "double" ) {
            grow, tmp, array( double, dms );
         } else error,"FITS_ADD_ROWS: Data type not supported";
      }

      if( dms(1) == 2 ) tmp = transpose(tmp);
      ptr(col) = &tmp;

   }

   if( numberof(outfile) ) {
      filename = outfile;
   } else {
      get_exten_no, dol, filename, extno;
   }
   wrfitsbin, filename, fh, ptr, clobber=1;

}

/* Function fits_copy_keys */

func fits_copy_keys( fhfrom, &fhto, list=, tokwds= )
/* DOCUMENT fits_copy_keys, fhfrom, >fhto, list=, tokwds=

   Keyword 'list' can be a comma-separated list (scalar string)
   of FITS keywords to be copied.

   If keyword 'list' is not given then
   all non-FITS specific keywords will be copied from 'fhfrom'
   to 'fhto'.

   If the keyword 'tokwds' is set then the 'kwds' functions
   are activated in stead. The keywords will be reset prior
   to the copying unless the value of 'tokwds' is larger than 1.

   2007-09-12/NJW
   2010-08-18/NJW, list keyword added
*/
{
   cards = _car(fhfrom,1);
   ncards = numberof(cards);
   if( tokwds ) {
      if( tokwds <= 1 ) kwds_init;
   }

   if( typeof(list) == "string" ) {
      selkeys = strsplit(list,",");
      nselkeys = numberof(selkeys);
      ql = 1;
   } else ql = 0;

   for( i = 1; i <= ncards; i++ ) {

      key = strtrim(strpart(cards(i),1:8));
      if( key == "XTENSION" ) continue;
      if( key == "BITPIX" ) continue;
      if( key == "NAXIS" ) continue;
      if( key == "CONTINUE" ) continue;
      key5 = strpart(key,1:5);
      if( key5 == "NAXIS" && is_digit(strpart(key,6:8)) ) continue;
      if( key == "PCOUNT" ) continue;
      if( key == "TFIELDS" ) continue;
      if( key5 == "TTYPE" && is_digit(strpart(key,6:8)) ) continue;
      if( key5 == "TFORM" && is_digit(strpart(key,6:8)) ) continue;
      if( key5 == "TZERO" && is_digit(strpart(key,6:8)) ) continue;
      if( key5 == "TSCAL" && is_digit(strpart(key,6:8)) ) continue;
      if( key5 == "TUNIT" && is_digit(strpart(key,6:8)) ) continue;

      if( ql ) {
         accept = 0;
         for( j = 1; j <= nselkeys; j++ ) {
            if( selkeys(j) == key ) accept = 1;
         }
         if( !accept ) continue;
      }

      value = fits_parse( cards(i) );
      if( tokwds ) {
         if( is_void(_fits_parse_comment) ) {
            kwds_set, key, value;
         } else {
            kwds_set, key, value, strtrim(_fits_parse_comment);
         }
      } else {
         if( is_void(_fits_parse_comment) ) {
            fits_set, fhto, key, value;
         } else {
            fits_set, fhto, key, value, _fits_parse_comment;
         }
      }

   }

}

/* Function rdfitsbin */

func rdfitsbin( dol, &fh, &nrows, silent= )
/* DOCUMENT ptr = rdfitsbin( dol, >fh, >nrows, silent= )

   Read entire FITS binary table and return the pointer array.

   If the file or the extension is not found then a 'void' is returned.

   2007-09-12/NJW, updated 2011-09-13/NJW
*/
{
   local filename, extno;

   get_exten_no, dol, filename, extno;
   if( !file_test(filename) ) {
      if( !silent ) write,"File not found: "+filename;
      return [];
   }
   if( extno < 1 ) {
      if( !silent ) write,"Extension not found: "+dol;
      return [];
   }
   fh = fits_open( filename, 'r');
   fits_goto_hdu, fh, extno+1;
   ptr = fits_read_bintable(fh);
   nrows = fits_get(fh, "NAXIS2");
   fits_close, fh;
   return ptr;
}

/* Function wrfitsbin */

func wrfitsbin( filename, fh, ptr, clobber= )
/* DOCUMENT wrfitsbin, filename, fh, ptr, clobber=

   Write entire FITS binary table to the first extension
   into the file 'filename' and copy the essential keywords
   from 'fh' that also holds the column name and unit info.
   The input is the array of pointers for the binary table.

   2007-09-12/NJW
*/
{
   require, "idlx.i";
   require, "kfits.i";

   if( file_test( filename ) ) {
      if( clobber ) {
         remove, filename;
      } else {
         write,format="No action, %s exists already\n", filename;
         return;
      }
   }
   newfh = fits_create(filename);
   newfh = fits_set( newfh, "EXTEND",'T',"There may be extensions");
   fits_write_header, newfh;
   fits_new_bintable, newfh;

   /* copy all non FITS specific keywords */

   fits_copy_keys, fh, newfh;
   fits_set, newfh, "DATE", ndate(3), "Time of file creation";

   /* copy all column names */

   colname = "";
   ncols = 0;
   while( 1 ) {
      ttype = swrite(format="TTYPE%i",++ncols);
      colname = fits_get(fh,ttype);
      if( is_void(colname) ) {
         break;
      } else {
         fits_set,newfh, ttype, colname,"Column name";
      }
   }

   if( --ncols != numberof(ptr) ) {
      write,format="Inconsistency: %i columns in fh but %i pointers\n", \
                          ncols, numberof(ptr);
      fits_close, newfh;
      return;
   }

   /* copy all unit names */

   unit = "";
   for( i = 1; i <= ncols; i++ ) {
      tunit = swrite(format="TUNIT%i",i);
      unit = fits_get(fh,tunit);
      if( !is_void(unit) ) fits_set,newfh, tunit, unit,"Unit for this column";
   }

   /* Check columns of type 'string' for consistency */

   for( i = 1; i <= ncols; i++ ) {
      if( typeof(*ptr(i)) == "string" ) {
         tform = swrite(format="TFORM%i", i);
         tval = fits_get(fh, tform);
         if( strpart(tval,0:0) != "A" ) {
            write,format="%s problem, value = %s\n", tform, tval;
            fits_close, newfh;
            return;
         }
         len = atoi(strpart(tval, 1:-1));
         ss = s = (*ptr(i))(1);
         while( strlen(s) < len ) s += " ";
         if( strlen(ss) != len ) (*ptr(i))(1) = s;
      }
   }

   fits_write_bintable, newfh, ptr;
   fits_close, newfh;
}

/* Function fits_colnum */

func fits_colnum( fh_or_dol, colname, silent= )
/* DOCUMENT number = fits_colnum( fh_or_dol, colname, silent= )

   Returns the column number of column 'colname' (may be lower case)
   when DOL or header information is in 'fh_or_dol'.

   Keyword silent:  To suppress screen message

   2007-09-12/NJW
*/
{

   if( typeof(fh_or_dol) == "string" ) {
      fh = headfits( fh_or_dol );
   } else if( typeof(fh_or_dol) == "list" ) {
      fh = fh_or_dol;
   } else error,"First argument is neither string nor file handle";

   colname = strupcase(colname);
   k = 1;
   colnum = 0;
   keynam = "TTYPE"+swrite(format="%i",k);
   while( coln = fits_get(fh, keynam) ) {
      if( coln == colname ) {
         colnum = k;
         break;
      }
      keynam = "TTYPE"+swrite(format="%i",++k);
   }
   if( !colnum ) {
      if(!silent)write,format="Column %s was not found\n", colname;
      return [];
   }

   return colnum;

}

/* fits_numcols */

func fits_numcols( fh_or_dol )
/* DOCUMENT number = fits_numcols( fh_or_dol )

   Returns the number of columns
   Argument is either a FITS file handle (header) or a DOL

   2007-09-25/NJW
*/
{

   if( typeof(fh_or_dol) == "string" ) {
      fh = headfits( fh_or_dol );
   } else if( typeof(fh_or_dol) == "list" ) {
      fh = fh_or_dol;
   } else error,"First argument is neither string nor file handle";

   numcols = 0;
   while( fits_get(fh, swrite(format="TTYPE%i",numcols+1) ) ) numcols++;

   return numcols;

}

/* Function fits_bintable_poke */

func fits_bintable_poke( fh_or_DOL, row_number, col_desig, value, keeppcount=, chat= )
/* DOCUMENT fits_bintable_poke, fh_or_DOL, row_number, col_desig, value, keeppcount=, chat=

   Substitutes the table bin with 'value' that can be an array if the
   bin is a vector bin.

   If row_number <= 0 then the entire column will be replaced
   provided 'value' is an array with as many elements as there are rows.
   For a fixed length vector column 'value' must be a 2D array (mxn)
   with 'm' as the number of values in each bin and 'n' equal to the
   number of rows in the table.
   Variable length vector columns must be updated one row at a time.

   'col_desig' is either the column number or its name.

   Keyword  keeppcount  If set, no changes are made to the FITS PCOUNT keyword.

   2007-09-26/NJW
   2008-01-18/NJW, updated with vector bin option
   2008-10-02/NJW, updated with variable length vector bin option
   2010-11-19/NJW, updated with more than one variable length vector bin
*/
{

/*
   - overwrite single bin (row_number > 0) fixed length
      Accepts only DOL

   - overwrite entire column (row_number <= 0) fixed length
      Accepts only DOL

   - write single bin (row_number > 0) to variable length column
      When col_number points to variable length column

*/
   if( is_void(value) ) error,"Entered void value";
   if( is_void(chat) ) chat = 0;

   nvalue = numberof( value );
   dms = dimsof( value );
   if( dms(1) == 0 ) dms = [1,1];
   nvrows = dms(1) ? dms(0) : 1; // number of rows in input data
   nvector = dms(1) ? dms(2) : 1; // number of elements in vector
   pcount = 0;

  /*
   * There are cases such a Linux on 64 bit machines where
   *  sizeof(long) == 8. This is not compatible with FITS J-type
   *  where 4 bytes are expected. Hence if 'value' is of type 'long'
   *  it must be converted to 'int'.
   */

   if( typeof(value) == "long" && sizeof(long) == 8 ) {
      value = int(value);
   }

   // Analyze first argument

   if( structof(fh_or_DOL) == list ) {
      is_dol = 0;
      fh = fh_or_DOL;
   } else if( structof(fh_or_DOL) == string ) {
      is_dol = 1;
      local filename, extno;
      get_exten_no, fh_or_DOL, filename, extno;
      if( extno == 0 ) error,"No extension number found";
      if( !file_test(filename) ) error,filename+" not found!";
      fh = fits_open( filename, 'r');
      fits_goto_hdu, fh, extno+1; // Yorick counting starts with 1
   } else error,"First argument of illegal type";

   //  starting file

   btdes = fits_btdes( fh );

   // new file (temporary)

   //+ filenameo = get_next_filename("_tmp_???.fits");
   filenameo = ranstr(10)+".fits";
   fho = fits_open( filenameo, 'w', overwrite=1 );


   // Number of columns in the extension
   ncols = _car( btdes, 2);
   if(chat)write,format="Number of columns in extension: %i\n", ncols;
   nrows = _car( btdes, 1);
   if(chat)write,format="Number of rows in extension: %i\n", nrows;

   // Identify the variable vector columns

   nreps = _car( btdes, 4);
   varcol = where( nreps == 0 );

   col_number = structof(col_desig) == string ? \
         fits_colnum( fh, col_desig ) : col_desig;
   if( col_number > ncols ) error,"Column number too high";
   if( row_number > nrows ) error,"Row number too high";

   //  Reorganize basic table information

   local sizecol; eq_nocopy, sizecol, _car(btdes,5);
   local repeats; eq_nocopy, repeats, _car(btdes,4);
   local dtypes; eq_nocopy, dtypes, _car(btdes,3);
   fixvmode = (repeats(col_number) > 1)&&(dtypes(col_number)!="A");
   if( chat > 1 ) {
      write,format="fixvmode (fixed vector bin mode) = %i\n", fixvmode;
   }

   // Check if requested column is variable length

   varvmode = !repeats(col_number); // repeats has value zero for var.len.
   if( chat > 1 ) {
      write,format="varvmode (variable length vector bin mode) = %i\n", varvmode;
   }

   if( row_number <= 0 ) row_number = 1;

   // Test dimensional compatibility

   if( varvmode ) { // A scalar or vector is accepted

      if( dms(1) > 1 ) error,"Data dimensionality is illegal";
      if( dms(1) == 0 ) dms = [1,1];
      local lengths, positions;

      // find the highest address of the heap by searching all variable length
      //  columns

      position_of_insertion = 0;
      for( i = 1; i <= numberof(varcol); i++ ) {
         dtyp = dtypes(varcol(i));
         if( dtyp == "I" ) {
            colw = 2;
         } else if( dtyp == "J" ) {
            colw = 4;
         } else if( dtyp == "E" ) {
            colw = 4;
         } else if( dtyp == "D" ) {
            colw = 8;
         } else {
            write,"Datatype "+dtyp+" is not supported";
            return;
         }
         _fits_var_length_info, fh, varcol(i), lengths, positions;
         p = max(colw*lengths + positions);
         if( p > position_of_insertion ) position_of_insertion = p;
      }

      // PCOUNT should reflect the size of the heap
      pcount = position_of_insertion;

        // relative to start of heap after ordinary table
      if( chat > 1 ) {
         write,format="Position of insertion of new data in heap: %i\n", position_of_insertion;
      }
      n_repl_rows = 1;

   } else {

      if( fixvmode ) { // This is a vector column hence there must be enough
                    // data values to fill it
         // first investigate if a format change is adequate
         if( dms(1) == 1 ) {
            if( dms(2) == repeats(col_number) ) {
               value = reform(value, dms(2),1);
               dms = dimsof(value);
            }
         }
         if( dms(1) != 2 ) error, "##25##";
         if( dms(2) != repeats(col_number) ) error,"##26##";
         if( dms(3) + row_number - 1 > nrows ) error,"##27##";
         n_repl_rows = dms(3);

      } else {  // We have a scalar column

         if( dms(2) + row_number - 1 > nrows ) error,"##28##";
         n_repl_rows = dms(2);

      }
   }

   // Calculate address where replacement begins


  //        begin of data section
   //+ address_row = _car(btdes,6)(3);
   rowsize = sizecol(sum);
   nbytes_before = col_number > 1 ? sum(sizecol(1:col_number-1)) : 0;
   nbytes_after = col_number < ncols ? sum(sizecol(col_number+1:0)) : 0;
   if( chat > 1 ) {
      write,format="nbytes_before : %10i\n", nbytes_before;
      write,format="nbytes_after  : %10i\n", nbytes_after;
   }

   address = _car(btdes,6)(3) \
           + (row_number-1) * sizecol(sum); // adding preceding rows
   if( chat > 2 ) {
      write,format="##100## row_number = %i, address = %i\n", row_number, address;
   }
   //+ if( col_number > 1 ) address += sum(sizecol(1:col_number-1));
   //+                    // adding first part of row

   sizec  = sizecol(col_number);
   dtype  = typeof( value );
   if( dtype == "string" ) {
      if( repeats(col_number) < max(strlen(value)) ) error,"String too long";
   }
   if(chat)write,format="Data type needs to be %s\n", dtypes(col_number);

   // Checking data type compatibility

   if( dtypes(col_number) == "B" ) {
      // A single byte is expected
      if( dtype != "char" ) error,"Data type not 'char'";
   } else if( dtypes(col_number) == "I" ) {
      // A size of two bytes is expected i.e. short
      if( dtype != "short" ) error,"Data type not 'short'";
      if( sizeof(short) != 2 ) error,"Short size incompatibility";
   } else if( dtypes(col_number) == "J" ) {
      if( dtype == "long" ) {
         if( sizeof(long) != 4 ) error,"Long size incompatibility - use 'int' instead";
      } else if( dtype == "int" ) {
         if( sizeof(int) != 4 ) error,"Int size incompatibility";
      } else error,"Data type neither int nor long";
   } else if( dtypes(col_number) == "E" ) {
      if( dtype != "float" ) error,"Data type not float";
   } else if( dtypes(col_number) == "D" ) {
      if( dtype != "double" ) error,"Data type not double";
   } else if( dtypes(col_number) == "A" ) {
      if( dtype != "string" ) error,"Data type not string";
   } else error,"Unrecognized data type";

   vc = array(char,1); // defining byte for file copying

   //  Copy byte by byte until start address of first row
   //  where replacement must take place

   for( addr=0; addr < address; addr++ ) {
      _read, _car(fh,4), addr, vc;
      _write, _car(fho,4), addr, vc;
   }

   for( row = 1; row <= n_repl_rows; row++ ) {
      if( chat > 2 ) write,format="##101## row %i, address = %i\n", row, address;
      // Copy first part of row until replacement begins
      if( nbytes_before > 0 ) {
         for(i=0;i<nbytes_before;i++) {
            _read, _car(fh,4), address, vc;
            _write, _car(fho,4), address++, vc;
         }
      }
      if( chat > 2 ) write,format="##102## row %i, address = %i\n", row, address;

      if( varvmode ) {

         _write, _car(fho,4), address, dms(2); // Length of array
         address += 4;
         _write, _car(fho,4), address, position_of_insertion; // Position in heap
         address += 4;

      } else {

         // do the replacement

         if( fixvmode ) {
            for( i = 1; i <= repeats(col_number); i++ ) {
               _write, _car(fho,4), address, value(i,row);
               address += sizeof(value(i,row));
            }
         } else {
            if( dtypes(col_number) == "A" ) {
               stra = value(row);
               while( strlen(stra) < repeats(col_number) ) stra += " ";
               cstra = strchar( stra );
               for( i = 1; i <= repeats(col_number); i++ ) {
                  _write, _car(fho,4), address++, cstra(i);
               }
            } else {
               _write, _car(fho,4), address, value(row);
               address += sizec;
            }
         }
      }
      if( chat > 2 ) write,format="##103## row %i, address = %i\n", row, address;
      if( nbytes_after > 0 ) {
         for(i=0;i<nbytes_after;i++) {
            _read, _car(fh,4), address, vc;
            _write, _car(fho,4), address++, vc;
         }
      }
      if( chat > 2 ) write,format="##104## row %i, address = %i\n", row, address;
   }

   // Copy remainder of ordinary table data

   last_data_address = _car(fh,3)(3) + rowsize*nrows;

   while( address < last_data_address ) {
      _read, _car(fh,4), address, vc;
      _write, _car(fho,4), address++, vc;
   }

   // If data needs to be added to heap

   if( varvmode ) {

      // Copy already existing part of the heap

      for( i = 1; i <= position_of_insertion; i++ ) {
         _read, _car(fh,4), address, vc;
         _write, _car(fho,4), address++, vc;
      }

      // Add the new data values

      sizev = sizeof(value(1));
      for( i = 1; i <= dms(2); i++ ) {
         _write, _car(fho,4), address, value(i);
         address += sizev;
      }
   }

   if( varvmode ) {
      fits_close, fho, last=address;
   } else {
      // Copy remainder of the file
      while( _read( _car(fh,4), address, vc) == 1 ) _write, _car(fho,4), address++, vc;
      fits_close, fho, nopad=1;
   }

   fits_close, fh;

   // Update the PCOUNT keyword

   if( keeppcount ) {
      cp, filenameo, filename;
   } else {
      fits_ch_keyw,filenameo,"PCOUNT",pcount,outfile=filename;
   }
   remove, filenameo;

}

/* Function fits_btdes */

func fits_btdes( fh_or_DOL, chat= )
/* DOCUMENT btdes = fits_btdes( fh_or_DOL, chat= )

   returns Binary Table DEScription.

     num_rows = _car(btdes,1)
     num_cols = _car(btdes,2)
     data_types = _car(btdes,3) // string array of length num_cols
     repeats    = _car(btdes,4) // long array of repeat counts
     sizecols   = _car(btdes,5) // long array of length num_cols
     offset     = _car(btdes,6) // 5 element array as _car(fh,3)

    2007-09-25/NJW
*/
{
   local filename, extno;
   if( typeof(fh_or_DOL) == "string" ) {
      if(chat)write,"fits_btdes - arg is string";
      get_exten_no, fh_or_DOL, filename, extno;
      fh = fits_open( filename );
      fits_goto_hdu, fh, extno+1;
      is_dol = 1;
   } else if( typeof(fh_or_DOL) == "list" ) {
      if(chat)write,"fits_btdes - arg is list";
      fh = fh_or_DOL;
      is_dol = 0;
   } else error,"Argument is neither string nor list";

   local cards; eq_nocopy, cards, _car(fh,1);
   //+local offset; eq_nocopy, offset, _car(fh,3);
   offset = _car(fh,3);

   // current HDU
   if(chat)write,format="Current HDU: %i\n", offset(1);
   // Address in file of CHDU (Current HDU)
   if(chat)write,format="Address CHDU: %i\n", offset(2);
   // Address in file of data of CHDU
   if(chat)write,format="Address data CHDU: %i\n", offset(3);
   // Address in file of next HDU
   if(chat)write,format="Address next HDU: %i\n", offset(4);
   // Filemode
   if(chat)write,format="Filemode: %c\n", offset(5);
   // Number of columns
   ncols = fits_numcols(fh);
   if(chat)write,format="Number of columns: %i\n", ncols;

   naxis1 = fits_get(fh,"NAXIS1");
   naxis2 = fits_get(fh,"NAXIS2");
   if(chat)write,format="Number of rows: %i\n", naxis2;

   // Setup arrays for column size information

   sizecol = array(0,ncols);
   dtypes = array(string,ncols);
   repeats = array(0,ncols);

   // Walk through all columns to extract information

   for( col = 1; col <= ncols; col++ ) {
      d = fits_get( fh, swrite(format="TFORM%i",col) );
      // include possibility of variable length vector column
      if( strpart(d,1:2) == "1P" ) {
         repeat = 0; // signals variable length
         dtype = strpart(d,3:3); // Type of data in the heap (not in the column)
         sizecol(col) = 8; // Namely 2 long's (J)
      } else {
         // Format of TFORM:  NT where N is a number (can have more than one digit)
         //   and T is the type indicator: B, I, J, E, or D
         repeat = atoi(strpart( d, 1:-1 ));
         // if 'N' is left out then the result will be zero - it should be one
         if( repeat == 0 ) repeat = 1;
         dtype = strpart( d, 0:0 );
         if( dtype == "B" ) {
            sizecol(col) = repeat * 1;
         } else if ( dtype == "I" ) {
            sizecol(col) = repeat * 2;
         } else if ( dtype == "J" ) {
            sizecol(col) = repeat * 4;
         } else if ( dtype == "E" ) {
            sizecol(col) = repeat * 4;
         } else if ( dtype == "D" ) {
            sizecol(col) = repeat * 8;
         } else if ( dtype == "A" ) {
            sizecol(col) = repeat * 1;
         } else error,"Unrecognized data type: "+dtype;
      }
      dtypes(col) = dtype;
      repeats(col) = repeat;
   }
   if(chat)write,format="Summed size: %i, NAXIS1 = %i\n", \
           sizecol(sum), naxis1;

   btdes = _lst( naxis2, ncols, dtypes, repeats, sizecol, offset );

   if( is_dol ) fits_close, fh;

   return btdes;

}

/* Function get_crd */

func get_crd( dol )
/* DOCUMENT crd = get_crd( dol )

   Returns array crd(3,2)
      crd(1,1) = crpix1     crd(1,2) = crpix2
      crd(2,1) = crval1     crd(2,2) = crval2
      crd(3,1) = cdelt1     crd(3,2) = cdelt2

    2008-04-07/NJW
*/
{
   fh = headfits( dol );
   crpix1 = fxpar( fh, "crpix1" );
   crval1 = fxpar( fh, "crval1" );
   cdelt1 = fxpar( fh, "cdelt1" );
   crpix2 = fxpar( fh, "crpix2" );
   crval2 = fxpar( fh, "crval2" );
   cdelt2 = fxpar( fh, "cdelt2" );
   n_miss = 0;
   if( is_void(crpix1) ) n_miss++;
   if( is_void(crval1) ) n_miss++;
   if( is_void(cdelt1) ) n_miss++;
   if( is_void(crpix2) ) n_miss++;
   if( is_void(crval2) ) n_miss++;
   if( is_void(cdelt2) ) n_miss++;
   if( n_miss ) {
      write,format="%i missing CRPIX etc. in %s\n", n_miss, dol;
      write,format="Returning default %s\n","values";
      crpix1 = crpix2 = crval1 = crval2 = 0.0;
      cdelt1 = cdelt2 = 1.0;
   }
   crd = array(double, 3, 2 );
   crd(1,1) = crpix1;     crd(1,2) = crpix2;
   crd(2,1) = crval1;     crd(2,2) = crval2;
   crd(3,1) = cdelt1;     crd(3,2) = cdelt2;

   return crd;

}

/* Function fits_bintable_peek */

func fits_bintable_peek( DOL, row_number, col_desig, chat= )
/* DOCUMENT value = fits_bintable_peek( DOL, row_number, col_desig, chat= )

   'col_desig' is either the column number or its name.

   Returns the content of FITS binary table bin (row_number, col_number)

   2007-09-26/NJW
   2008-05-28/NJW updated to handle strings properly
   2008-10-03/NJW updated to handle variable length columns

*/
{

   if( is_void(chat) ) chat = 0;
   local filename, extno;
   if( typeof(DOL) == "string" ) {
      isfile = 1;
      get_exten_no, DOL, filename, extno;
      if( extno == 0 ) error,"No extension number found";
      fh = fits_open( filename );
      fits_goto_hdu, fh, extno+1;
      btdes = fits_btdes( fh );
   } else error,"DOL is not a string";


   // Address in file of CHDU (Current HDU)
   if( chat > 2 )write,format="Address CHDU: %i\n", _car(fh,3)(2);
   // Address in file of data of CHDU
   if( chat > 2 )write,format="Address data CHDU: %i\n", _car(fh,3)(3);
   // Address in file of next HDU
   if( chat > 2 )write,format="Address next HDU: %i\n", _car(fh,3)(4);
   // Filemode
   if( chat > 3 )write,format="Filemode: %c\n", _car(fh,3)(5);
   // Number of columns
   ncols = _car( btdes, 2);
   if( chat > 0 ) write,format="Number of columns: %i\n", ncols;
   nrows = _car( btdes, 1);
   if( chat > 0 ) write,format="Number of rows: %i\n", nrows;

   col_number = structof(col_desig) == string ? \
         fits_colnum( fh, col_desig ) : col_desig;

   if( col_number > ncols ) error,"Column number too high";
   if( row_number > nrows ) error,"Row number too high";

   // Calculate address

   local sizecol; eq_nocopy, sizecol, _car(btdes,5);
   local repeats; eq_nocopy, repeats, _car(btdes,4);
   local dtypes; eq_nocopy, dtypes, _car(btdes,3);

  //        begin of data section
   address = _car(fh,3)(3) \
           + (row_number-1) * sizecol(sum); // preceding rows
   if( col_number > 1 ) address += sum(sizecol(1:col_number-1));

   if( chat > 0) write,format="Reading %i%s at address %i\n", \
          repeats(col_number), dtypes(col_number), address;

   if( repeats(col_number) ) { // Fixed length column
      if( dtypes(col_number) == "I" ) {
         value = array( short, repeats(col_number));
         _read, _car(fh,4), address, value;
      } else if( dtypes(col_number) == "J" ) {
         if( sizeof(long) == 4 ) {
            value = array( long, repeats(col_number) );
         } else if( sizeof(int) == 4 ) {
            value = array( int, repeats(col_number) );
         } else error,"Incompatible datatype";
         _read, _car(fh,4), address, value;
      } else if( dtypes(col_number) == "E" ) {
         value = array( float, repeats(col_number) );
         _read, _car(fh,4), address, value;
      } else if( dtypes(col_number) == "D" ) {
         value = array( double, repeats(col_number) );
         _read, _car(fh,4), address, value;
      } else if( dtypes(col_number) == "A" ) {
         c = array(char,repeats(col_number));
         value = "";
         _read, _car(fh,4), address, c;
         for(i=1;i<=repeats(col_number);i++) {
            value += swrite(format="%c",c(i));
         }
      } else error,"Unrecognized data type";
   } else { // variable length column
     // Get number of values in bin
     num_values = int(0);
     if( sizeof(num_values) != 4 ) error,"Bad size of int variable";
     _read, _car(fh,4), address, num_values;
     // Check for existence for values at all
     if( num_values == 0 ) return [];
     address += 4;
     // Get byte address in heap
     val_address = long(0);
     _read, _car(fh,4), address, val_address;

     // Read the actual values in the heap

     address = _car(fh,3)(3) + nrows * sizecol(sum) + val_address;
     if( dtypes(col_number) == "I" ) {
        value = array( short, num_values );
     } else if( dtypes(col_number) == "J" ) {
        if( sizeof(long) == 4 ) {
           value = array( long, num_values );
        } else if( sizeof(int) == 4 ) {
           value = array( int, num_values );
        } else error,"Incompatible datatype z";
     } else if( dtypes(col_number) == "E" ) {
        value = array( float, num_values );
     } else if( dtypes(col_number) == "D" ) {
        value = array( double, num_values );
     } else error,"Datatype not supported";

     _read, _car(fh,4), address, value;

   }

   if( isfile ) fits_close, fh;

   return value;

}

/* Function _fits_var_length_info */

func _fits_var_length_info( fh_or_DOL, colnum, &lengths, &positions, chat= )
/* DOCUMENT _fits_var_length_info, fh_or_DOL, colnum, >lengths, >positions, chat=

   Reads the vector lengths and heap addresses of a variable vector column
   and returns the values in the arguments.
   If first argument is a file handle then it must be opened for reading

    2008-01-02/NJW, 2010-11-19/NJW update with colnum for handling more than one
                                   variable length vector column
*/
{

   if( is_void(chat) ) chat = 0;

   if( structof(fh_or_DOL) == list ) {
      // Probably file handle
      fh = fh_or_DOL;
      if( _car(fh,3)(5) != 'r' ) error,"Not opened for reading";
      is_dol = 0;
   } else if( structof(fh_or_DOL) == string ) {
      // probably a DOL
      local filename, extno;
      get_exten_no, fh_or_DOL, filename, extno;

      fh = fits_open( filename, 'r');
      fits_goto_hdu, fh, extno+1;
      is_dol = 1;
   } else error,"Illegal first argument";

   btdes = fits_btdes( fh );

   // Identify position of variable length column information

   varcol = where( _car(btdes,4) == 0 );
   if( numberof(varcol) == 0 ) {
      write,"No variable length column found";
      if( is_dol ) fits_close, fh;
      return;
   }
   if( allof( varcol - colnum ) ) {
      write,"Requested colnum is not of variable length";
      if( is_dol ) fits_close, fh;
      return;
   }
   varcol = colnum;
   nrows = _car(btdes,1);
   ncols = _car(btdes,2);
   address_data = _car(fh,3)(3);
   lengths = positions = array( long, nrows );
   j = array( long, 1);

   nbytes_before = varcol == 1 ? 0 : long(sum(_car(btdes,5)(1:varcol-1)));
   nbytes_after = varcol == ncols ? 0 : long(sum(_car(btdes,5)(varcol+1:ncols)));

   address = address_data;
   for( row = 1; row <= nrows; row++ ) {
      address += nbytes_before;
      _read, _car(fh,4), address, j;
      lengths(row) = j;
      address += 4; // increase with 4 since datatype is J
      _read, _car(fh,4), address, j;
      positions(row) = j;
      address += 4;
      address += nbytes_after;
   }

   if( is_dol ) fits_close, fh;

}

/* Function pixsize */

func pixsize( list, outfile, silent= )
/* DOCUMENT pixsize, list, outfile, silent=

   Get the pixel size from the CDx_x keywords in FITS images
   as given in input string array 'list' of file names.
   For each files the first extension with valid CDx_x keywords is
   used and the remaining extensions are skipped.

   The result is written into file 'outfile'.

   2008-12-09/NJW
*/
{
   fout = open( outfile, "w" );
   n = numberof(list);
   for( i = 1; i <= n; i++ ) {
      next = nfits_extens( list(i) );
      for(j = 1; j <= next; j++ ) {
         fh = headfits( list(i)+"+"+itoa(j));
         cd1_1 = fxpar(fh,"cd1_1");
         cd1_2 = fxpar(fh,"cd1_2");
         cd2_1 = fxpar(fh,"cd2_1");
         cd2_2 = fxpar(fh,"cd2_2");
         if( is_void(cd1_1) || is_void(cd1_2) ) continue;
         pix1 = sqrt(cd1_1^2 + cd1_2^2);
         pix2 = sqrt(cd2_1^2 + cd2_2^2);
         if( abs(pix1-pix2) > 1.e-5 ) {
            write,format="Warning pixsizes in file: %s\n", list(i)+"+"+itoa(j);
         }
         if(!silent)write,format="%12.7f %s[%i]\n", pix1, list(i), j;
         write,fout,format="%12.7f %s[%i]\n", pix1, list(i), j;
         break; // assume all other extensions have same pixel size
      }
   }
   close, fout;
}

/* Function fits_add_cols */

func fits_add_cols( filename, colname, coldata, .. , nob= )
/* DOCUMENT  fits_add_cols, filename, colname, coldata, .., nob=

   Add columns to an existing FITS binary table file in
   extension number 1. The number of rows is kept.
   After the filename the arguments are alternating "colname, coldata"
   'colname' will be converted to upper case.

   Keyword 'nob' (no back up) prevents the automatic backup

   SEE ALSO: fits_add_rows

   2009-05-07/NJW

*/
{
   if( numberof(coldata) < 1 ) {
      write,format="No data present in first argument, skip writing%s\n","";
      return;
   }
   if( !file_test( filename ) ) {
      write,format="fits_add_cols: %s does not exist, quit!\n", filename;
      return;
   }
   if( is_void(nob) ) nob = 0;

//  read all data in existing file and find column names; close file afterwards

   old_fh = fits_open( filename );
   fits_goto_hdu, old_fh, 2; //  Extension 1 (Yorick counting starts at 1)
   ptr = fits_read_bintable( old_fh );
   fits_close, old_fh;
   olddms = dimsof(*ptr(1));
   nrows = olddms(2); // '2' because of internal representation if
                      // column 1 has vector bins

// Make a backup copy of old file and delete it

   if( !nob ) back, filename;
   remove, filename;

// Initiate the new version of the file

   fh = fits_create(filename);
   fh = fits_set(fh,"EXTEND",'T',"There may be extensions");
   fits_write_header, fh;

   fits_new_bintable, fh;

// copy all existing keywords

   fits_copy_keys, old_fh, fh;

//  get existing column names to avoid duplicating a name
//  and update 'fh'

   ncols = dimsof( ptr )(2);
   old_colname = array(string,ncols);
   for( i = 1; i <= ncols; i++ ) {
      keyname = swrite(format="TTYPE%i",i);
      cname = fxpar( old_fh, keyname );
      if( is_void(cname) ) {
         write,format="##2## problem with column name #%i\n", i;
         return;
      } else old_colname(i) = cname;
      fits_set,fh,keyname,cname,"Name of column";
   }

//   Check consistency between the given arguments and the existing file

   colname = strupcase(colname);
   if( anyof(old_colname == colname) ) {
      write,format="Colname %s exists already in %s\n", colname, filename;
      return;
   }
   grow, old_colname, colname;

   dms = dimsof(coldata);
   dms1 = dms(1);
   if( nrows != dms(1+dms1) ) {
      write,"Column %s does not match existing columns\n", colname;
      return;
   }

   if( dms(1) == 2 ) coldata = transpose(coldata);
   grow, ptr, &coldata;
   keyname = swrite(format="TTYPE%i",++ncols);
   fits_set, fh, keyname, colname,"Name of column";

   while( more_args() ) {
      cname = strupcase(next_arg());
      cdata = next_arg();

//   Check consistency between the given arguments and the existing file

      if( anyof(old_colname == cname) ) {
         write,format="Colname %s exists already in %s\n", cname, filename;
         return;
      }
      grow, old_colname, cname;

      dms = dimsof(cdata);
      dms1 = dms(1);
      if( nrows != dms(1+dms1) ) {
         write,"Column %s does not match existing columns\n", cname;
         return;
      }

      if( dms(1) == 2 ) cdata = transpose(cdata);
      grow, ptr, &cdata;
      keyname = swrite(format="TTYPE%i",++ncols);
      fits_set, fh, keyname, cname,"Name of column";

   }

   kwds_put, fh;

   fits_write_bintable, fh, ptr;
   fits_close, fh;

}

/* Function ttype */

func ttypes( dol_or_fh )
/* DOCUMENT ttypes, dol_or_fh
      list = ttypes( dol_or_fh )

   prints or returns the list of column names
   2009-05-25/NJW
*/
{
   if( typeof(dol_or_fh) == "string" ) {
      fh = headfits(dol_or_fh);
   } else fh = dol_or_fh;
   xtension = fxpar(fh,"xtension");
   if( xtension != "BINTABLE" ) error,"Not a binary table";

   i = 0;
   res = [];
   while( !is_void((colname = fxpar(fh,swrite(format="TTYPE%i",++i))))) {
      if( am_subroutine() ) {
         write,colname;
      } else grow, res, colname;
   }
   return res;
}

/* Function fits_info_col */

func fits_info_col( fh_or_dol, outfile= )
/* DOCUMENT fits_info_col, fh_or_dol, outfile=

    Displays column information.
    Keyword 'out' is an output file name.
*/
{
   fout =  structof(outfile) == string ? open(outfile,"w") : [];

   if( structof(fh_or_dol) == string ) {
      fh = headfits( fh_or_dol );
   } else fh = fh_or_dol;

   hdu = listhead( fh );
   ncols = fits_numcols( fh );

   for( i = 1; i <= ncols; i++ ) {
      ttype = fits_get( fh, swrite(format="TTYPE%i",i));
      tform = fits_get( fh, swrite(format="TFORM%i",i));
      tunit = fits_get( fh, swrite(format="TUNIT%i",i));
      write,fout,format="%3i  %16s %10s", i, ttype, tform;
      if( is_void(tunit) ) {
         write,fout,"";
      } else write,fout,format="%10s\n",tunit;
   }
   close,fout;

}

/* Function fits_ch_keyw */

func fits_ch_keyw( filename, keyword, new_value, outfile=, chat= )
/* DOCUMENT fits_ch_keyw, filename, keyword, new_value, outfile=, chat=

    Will change the FITS keyword 'keyword' to the 'new_value'
    in all extensions.
    ('keyword' wil be converted to upper case)

    Keyword outfile : If given the new file will be written to this,
                      else the original file will be overwritten.

    2010-11-29/NJW

*/
{

   // Convert keyword to char array for the search

   keyword = strupcase(keyword);
   ckeyword = *pointer(keyword);
   ckeyword = ckeyword(1:-1); // remove trailing '\0'
   nckeyword = numberof(ckeyword);

   // Convert new_value to a string

   if( structof(new_value) == string ) { // Already a string - test the length
      len = strlen(new_value);
      if( len > 68 ) error,"Not enough room for string";
      new_value_str = "'"+new_value+"'";
   } else if( structof(new_value) == int || structof(new_value) == long ) {
      new_value_str = swrite(format="%i",new_value);
   } else if( structof(new_value) == float || structof(new_value) == double ) {
      new_value_str = swrite(format="%g",new_value);
   } else error,"Type of new value: "+typeof(new_value)+" is not supported";
   cnew_value_str = *pointer(new_value_str);
   cnew_value_str = cnew_value_str(1:-1);
   ncnew_value_str = numberof(cnew_value_str);

   block = array(char,2880);
   stream = open(filename,"rb");
   //+ ostream = open("_tmp_.fits","wb");
   filenameo = ranstr(10)+".fits";
   ostream = open( filenameo, "wb" );

   size = sizeof(stream);
   nblocks = size/2880;
   //+ write,"size = ", size;
   //+ write,"nblocks = ", nblocks;

/*
 *  Go through file block by block
 */

   address = 0;
   for( iblock = 1; iblock <= nblocks; iblock++ ) {
     /*
      *  Read the block
      */
      _read, stream, address, block;
      //+ write,"Has read block#", iblock,"  at address ", address;
      for( j = 1; j <= 36; j++ ) {
         line = block((j-1)*80+1:j*80);
        /*
         *   Check for occurrence of string "keyword" which is
         *   unlikely unless in header block
         */
         if( noneof( line(1:nckeyword) - ckeyword) ) {  // Match!!!!
            // report original header card
            line0 = line;
            grow,line0,'\0';
            sline = string(&line0);
            if( chat ) write,"Original card with a match :";
            if( chat ) write,sline;
            newline = line;
            // clear the new line
            for( i = 10; i <= 80; i++ ) newline(i) = 32;

            // find where the comment starts
            for( islash = 80; islash > 0; islash-- ) {
               if( line(islash) == 47 ) break;
            }
            if( islash ) {
               comment = line(islash:80); // including the slash
               ncomment = numberof(comment);
            } else comment = []; // no comment found

            rmost = ncnew_value_str <= 20 ? 30 : 30 + (ncnew_value_str - 20);
            fpos = rmost - ncnew_value_str + 1;

            // Insert the string representation of the keyword
            for( i = fpos; i <= rmost; i++ ) newline(i) = cnew_value_str(i-fpos+1);

            // Insert the comment if it has been found
            if( ncomment ) {
               i = rmost+2;
               k = 1;
               while( i <= 80 && k <= ncomment ) {
                  newline(i++) = comment(k++);
               }
            }
            newline0 = newline;
            grow, newline0, '\0';
            snewline = string(&newline0);
            if( chat ) write,"            New card :";
            if( chat ) write,snewline;
            block((j-1)*80+1:j*80) = newline;
         } // end of dealing with a match
      } // end of search in block
      _write,ostream,address,block;
      address += 2880;
   } // end of loop over all blocks

   close, stream;
   close,ostream;

   if( !is_void( outfile ) ) filename = outfile;
   cp, filenameo, filename;
   remove, filenameo;
   remove, filenameo+"L";

}

/* Function fits_coldump */

func fits_coldump( dol, colname, .., rowsel=, outfile= )
/* DOCUMENT fits_coldump, dol, colname, .., rowsel=, outfile=

    Makes a nice print of the data in the chosen columns and
    selected rows.

    Keyword rowsel : Row selection by row number either as integer array
                     or as a text string e.g. "1-10,20-25".
            outfile: (string) If not given, then only terminal output.
                     If given the output stream is only to the file
                     unless preceded by a "+" sign e.g. "+mycols.txt"
                     in which case the columns will be written to the
                     terminal and to the file "mycols.txt".

*/
{
   p = 0; ps = 1;
   if( typeof(outfile) == "string" ) {
      if( strpart(outfile,1:1) == "+" ) {
         outfile = strpart( outfile, 2:0 );
      } else ps = 0;
      p = 1;
      fp = open(outfile,"w");
      write,fp,format="// Dump from %s\n", dol;
   }

   hdr = headfits(dol); // just in case
   ptr = &rdfitscol(dol,colname);
   if( structof(colname) != string ) colname = fxpar( hdr, "TTYPE"+itoa(colname));
   ncols = 1;
   nrows = numberof(*ptr);
   headline = strpadd(colname,12," ",rj=1,truncate=1);

   if( is_void(rowsel) ) {
      rowsel = indgen(nrows);
   } else {
      if( structof(rowsel) == string ) rowsel = str2arr(rowsel);
   }
   nrows = numberof(rowsel);

   while( more_args() ) {
      coln = next_arg();
      if( structof(coln) != string ) coln = fxpar( hdr, "TTYPE"+itoa(coln));
      headline += strpadd(coln,12," ",rj=1,truncate=1);
      grow,ptr,&rdfitscol(dol,coln);
      ncols++;
   }

   if(ps)write,format="   %s\n", headline;
   if(p)write,fp,format="   %s\n", headline;
   for( j = 1; j <= nrows; j++ ) {
      row = rowsel(j);
      if(ps)write,format="%3i",row; // row number
      if(p)write,fp,format="%3i",row; // row number
      for( i = 1; i <= ncols; i++ ) {
         v = (*ptr(i))(row);
         sv = structof(v);
         if( sv == int || sv == long ) {
            if(ps)write,format="%12i", v;
            if(p)write,fp,format="%12i", v;
         }
         if( sv == float || sv == double ) {
            if(ps)write,format="%12.6f", v;
            if(p)write,fp,format="%12.6f", v;
         }
         if( sv == string ) {
            if(ps)write,format="%s", strpadd(v,12," ",rj=1,truncate=1);
            if(p)write,fp,format="%s", strpadd(v,12," ",rj=1,truncate=1);
         }
      }
      if(ps)write,"";
      if(p)write,fp,"";
   }

   if( p ) {
      write,"Results in "+outfile;
      close,fp;
   }
}

/* Function fits_binsplit */

func fits_binsplit( dol, nparts, stem= )
/* DOCUMENT filenames = fits_binsplit( dol, nparts, stem= )

    Splits the binary FITS table pointed to by 'dol' into
    'nparts' new files with names <stem>_nnnn.fits
    saving approx. NAXIS2/nparts rows into each.

    The default value for 'stem' is "split".

    Returns the list of the filenames.

    Variable length records are not supported.

    2012-02-10/NJW
*/
{
   local fname, extno;

   get_exten_no, dol, fname, extno;
   if( !file_test(fname) ) error,"File not found: "+fname;

   if( typeof(stem) != "string" ) stem = "split";
   hdr = headfits(dol);
   nrows = fxpar(hdr,"naxis2");

   // read all data
   ptr = rdfitsbin( dol, hdr, nrows );
   nptr = numberof(ptr);
   newptr = array(pointer, nptr);

   // the files must at least have nshare rows each
   nshare = nrows / nparts;
   r = nrows - nshare*nparts; // remainder
   // the remainder is 'given' to the first r files, one each
   names = array(string,nparts);
   row2 = 0;
   for( i = 0; i < nparts; i++ ) {
      row1 = row2 + 1;
      row2 = row1 + nshare - 1;
      if( i < r ) row2++;
      write,itoa(i)+" rows "+itoa(row1)+" - "+itoa(row2);
      names(i+1) = stem+"_"+itoa(i,4)+".fits";
      m = indgen(row1:row2);
      for( j = 1; j <= nptr; j++ ) {
         x = (*ptr(j))(m,..);
         newptr(j) = &x;
      }
      wrfitsbin, names(i+1), hdr, newptr, clobber=1;
   }
   return names;
}

/* Function fstrselect */

func fstrselect( dol, outfile, colid, str )
/* DOCUMENT fstrselect, dol, outfile, colid, str

   Makes a strmatch( colid, str) and outputs to outfile

*/
{
   local fh, nrows;

   ptr = rdfitsbin( dol, fh, nrows );
   if( structof(colid) == string ) colid = fits_colnum(fh,colid);
   w = where( strmatch( *ptr(colid) , str ) );
   if( numberof(w) == 0 ) {
      write,"No action, no rows were selected!";
      return;
   }
   n = numberof(ptr);
   newptr = array(pointer,n);
   for( i = 1; i <= n; i++ ) newptr(i) = &((*ptr(i))(w));
   wrfitsbin, outfile, fh, newptr, clobber=clobber;
   write,outfile+" has been written.";

}

/* Function fselect */


func fselect( dol, outfile, expres )
/* DOCUMENT fselect, dol, outfile, expres

    The expression 'expres' can be a scalar string that is valid
    as an argument for 'where' with column names as variables
    ('#row' can be used as rownumber (as in the ftool 'fselect')).
    In this case a hyphen in a column name is not allowed.

    The other option for 'expres' is a two element array [row1, row2]
    (including both) with start and end row numbers
    and the selection will be between those.

    2012-02-13/NJW

*/
{
   local hdr, nrows, fitsname, extno;

   get_exten_no, dol, fitsname, extno;
   if( !file_test(fitsname) ) error,"Did not find "+fitsname;
   hdr = headfits( dol );

   if( typeof(expres) == "string" ) { // expects a valid logical expression
        // replace occurrences of #row with 'r_n_u_m' (an unlikely column name)
        // since #row cannot be a variable name
        expres = strstrrepl( expres, "#row", "r_n_u_m" );
        // get column names embedded in the expression, including e.g. numbers
        names = parse_expres( expres );
        // match column names against those that actually are found in the header
        colnames = check_colnames( hdr, names );
        ncolnames = numberof(colnames);
        // Use column names to define variables in new function that is written
        // to a file for including by 'require' function.
        // A random file name is used in order to force 'require' to update for
        // every call.
        tmpname = ranstr(10,lc=1)+".tmp";
        ff = open(tmpname,"w");
        write,ff,format="%s\n","func ffsel( ffdol )";
        write,ff,format="%s\n","{";
        write,ff,format="%s\n","   local ffhdr;";
        //+ write,ff,format="%s\n","   write,\"ffsel DOL: \"+ffdol";
        write,ff,format="%s\n","   ptr = rdfitsbin( ffdol, ffhdr );"
        write,ff,format="%s\n","   r_n_u_m = indgen(dimsof(*ptr(1))(2));"
        for( i = 1; i <= ncolnames; i++ ) {
           write,ff,format="   if( \"%s\" != \"r_n_u_m\" ) %s = *ptr(fits_colnum( ffhdr, \"%s\"));\n",colnames(i),colnames(i),colnames(i);
        }
        write,ff,format="   w = where(%s);\n", expres;
        write,ff,format="%s\n","   return w;";
        write,ff,format="%s\n","}";
        close, ff;
        require,tmpname;
        //+ write,"About to call ffsel with DOL : "+dol;
        m = ffsel( dol );
        // Clean up after use.
        remove, tmpname;

   } else {   // expect selection by row numbers : from, to (included)

      if( numberof(expres) != 2 ) error,"Bad expression";
      expres = long(expres);
      m = indgen(expres(1):expres(2));

   }

   if( numberof(m) ) {

      ptr = rdfitsbin( dol, hdr, nrows );
      newptr = array(pointer, numberof(ptr));

      for( i = 1; i <= numberof(ptr); i++ ) {
         x = (*ptr(i))(m,..);
         newptr(i) = &x;
      }

      wrfitsbin, outfile, hdr, newptr, clobber=1;

   } else {

      write,"No action since the selection is empty.";

   }

}

func parse_expres( expres )
{
   syms = "<>=!&|*+-/";
   s = strcompress( expres, all=1 ); // remove all blanks
   names = [];
   t = strtok( s, syms );

   while( strlen(t(2)) ) {
      grow, names, strlowcase(t(1));
      t = strtok( t(2), syms );
   }
   return grow(names,t(1));
}

func check_colnames( hdr, names )
{
   n = numberof(names);
   colnames = [];
   for( i = 1; i <= n; i++ ) {
      colnum = fits_colnum( hdr, names(i), silent=1 );
      if( colnum ) grow, colnames, names(i);
      if( names(i) == "r_n_u_m" ) grow, colnames, "r_n_u_m";
   }
   return colnames;
}

/* Function get_wcs */

func get_wcs( dol_or_hdu )
/* DOCUMENT coords = get_wcs( dol_or_hdu )

    Returns an instance of the struct 's_Coords' as defined in mfits.i
    from a FITS file header unit, either by DOL or by header directly

    coords.flag is set to 1 if all information is available, 0 otherwise.

    2012-08-17/NJW
*/
{
   if( typeof(dol_or_hdu) == "string" ) { // we have a DOL
      hdr = headfits(dol_or_hdu);
   } else hdr = dol_or_hdu;

   coords = s_Coords();
   coords.flag = 0;

   if( is_void((crval1 = fxpar(hdr,"crval1"))) ) {write,"CRVAL1 keyword missing"; return coords;}
   if( is_void((crval2 = fxpar(hdr,"crval2"))) ) {write,"CRVAL2 keyword missing"; return coords;}
   if( is_void((crpix1 = fxpar(hdr,"crpix1"))) ) {write,"CRPIX1 keyword missing"; return coords;}
   if( is_void((crpix2 = fxpar(hdr,"crpix2"))) ) {write,"CRPIX2 keyword missing"; return coords;}
   cd1_1  = fxpar(hdr,"cd1_1");
   if( is_void(cd1_1) ) { // This may be oldfashioned CDELT etc.
      if( is_void((cdelt1 = fxpar(hdr,"cdelt1"))) ) {write,"CDELT1 keyword missing"; return coords;}
      if( is_void((cdelt2 = fxpar(hdr,"cdelt2"))) ) {write,"CDELT2 keyword missing"; return coords;}
      //+ if( is_void((crota2 = fxpar(hdr,"crota2"))) ) {write,"CROTA2 keyword missing, reset!"; crota2 = 0.0;}
      if( is_void((crota2 = fxpar(hdr,"crota2"))) ) { crota2 = 0.0;}
      if( abs(crota2) < 1.e-5 ) {
         cd1_1 = cdelt1;
         cd2_2 = cdelt2;
         cd1_2 = cd2_1 = 0.0;
      } else {write,"CROTA2 is not zero"; return coords;}
   } else {
      if( is_void((cd1_2  = fxpar(hdr,"cd1_2"))) ) {write,"CD1_2 keyword missing"; return coords;}
      if( is_void((cd2_1  = fxpar(hdr,"cd2_1"))) ) {write,"CD2_1 keyword missing"; return coords;}
      if( is_void((cd2_2  = fxpar(hdr,"cd2_2"))) ) {write,"CD2_2 keyword missing"; return coords;}
   }

   coords.flag = 1; // signal OK values returned
   coords.crval1 = crval1;
   coords.crval2 = crval2;
   coords.crpix1 = crpix1;
   coords.crpix2 = crpix2;
   coords.cd1_1 = cd1_1;
   coords.cd1_2 = cd1_2;
   coords.cd2_1 = cd2_1;
   coords.cd2_2 = cd2_2;
   coords.scale = sqrt(cd1_1^2 + cd1_2^2);

   return coords;
}

/* Function put_wcs */

func put_wcs( coords )
/* DOCUMENT put_wcs, coords

     Adds the appropriate keywords CRVAL, CRPIX, CTYPE, CD1_1, .. to the
     keywords as accessed by functions kwds_set etc.

     'coords' must be an instance of the struct 's_Coords'.

     SEE ALSO: get_wcs

*/
{
   kwds_set,"CTYPE1", coords.ctype1,"Coordinate system 1. axis";
   kwds_set,"CTYPE2", coords.ctype2,"Coordinate system 2. axis";
   kwds_set,"CRVAL1", coords.crval1,"Reference value coordinate 1";
   kwds_set,"CRVAL2", coords.crval2,"Reference value coordinate 2";
   kwds_set,"CRPIX1", coords.crpix1,"Reference pixel coordinate 1";
   kwds_set,"CRPIX2", coords.crpix2,"Reference pixel coordinate 2";
   kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
   kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
   kwds_set,"CD1_1", coords.cd1_1,"Part of conversion matrix";
   kwds_set,"CD1_2", coords.cd1_2,"Part of conversion matrix";
   kwds_set,"CD2_1", coords.cd2_1,"Part of conversion matrix";
   kwds_set,"CD2_2", coords.cd2_2,"Part of conversion matrix";
}

/* Function im2skyfits */

func im2skyfits( im, outfile, ra=, dec=, rot=, scale=, crpix1=, crpix2=, clobber= )
/* DOCUMENT im2skyfits, im, outfile, ra=, dec=, rot=, scale=, crpix1=, crpix2=, clobber=

     RA, dec, rot, and scale in degrees

    2012-09-12/NJW

*/
{
   dr = pi / 180.;
   dms = dimsof(im);
   if( dms(1) != 2 ) error,"##1##";
   if( is_void(ra) ) ra = 0.;
   if( is_void(dec) ) dec = 0.;
   if( is_void(rot) ) rot = 0.;
   if( is_void(scale) ) scale = 1./60.; // defaults to 1 arcmin
   if( is_void(crpix1) ) crpix1 = double(dms(2))/2;
   if( is_void(crpix2) ) crpix2 = double(dms(3))/2;

   coords = s_Coords();

   coords.ctype1 = "RA---TAN";
   coords.ctype2 = "DEC--TAN";
   coords.crpix1 = crpix1;
   coords.crpix2 = crpix2;
   coords.crval1 = ra;
   coords.crval2 = dec;
//    kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
//    kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
//    crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
//    kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
//    kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
//    kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
//    kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
//    crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
//    kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
//    kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
//    pix1 = (Pixel_size1/Focal_length)*(180./pi);
//    rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
//    kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
//    kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
//    kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
//    kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";
   rot_rad = rot * dr;
   coords.cd1_1 = -scale*cos(rot_rad);
   coords.cd1_2 = -scale*sin(rot_rad);
   coords.cd2_1 = -scale*sin(rot_rad);
   coords.cd2_2 =  scale*cos(rot_rad);

   put_wcs, coords;

   writefits, outfile, im, clobber=clobber;

}
%FILE% mk_func_catalog.i
/* Function mk_func_catalog */

func mk_func_catalog(a)
{

   func_names = [];
   file_names = [];

   sdir = "/home/njw/yorick";
   mk_func_cat_dir, sdir, func_names, file_names;
   nnow = numberof(func_names);
   write,format="In %s there are %i functions\n", sdir, nnow;
   nprev = nnow;

   sdir = "/home/njw/yorick/yorick-2.1/i";
   mk_func_cat_dir, sdir, func_names, file_names;
   nnow = numberof(func_names);
   write,format="In %s there are %i functions\n", sdir, nnow - nprev;
   nprev = nnow;

   sdir = "/home/njw/yorick/yorick-2.1/i0";
   mk_func_cat_dir, sdir, func_names, file_names;
   nnow = numberof(func_names);
   write,format="In %s there are %i functions\n", sdir, nnow - nprev;
   nprev = nnow;

   nu = numberof(func_names);
   ni = numberof(file_names);
   if( nu != ni ) {
      write,"You have a problem - different size arrays";
      return;
   }

   isrt = sort(strtolower(func_names));

   for(i=1; i<=nu; i++) func_names(i) += (" "+file_names(i));
   func_names = func_names(isrt);

   write_slist,"func_catalog.man", func_names;

}
/* Function mk_func_cat_dir */

func mk_func_cat_dir( sdir, &func_names, &file_names )
{

   list = grep( "func ", sdir, sel="*.i" );
   nlist = numberof(list);

   if( nlist > 0 ) {

      for( i = 1; i<= nlist; i++ ) {
         sl = strpart(list(i),1:10);
         if( sl == "// file = " ) { // We have a filename
            filename = strpart(list(i), 11:0);
         } else {           // We may have a function
            if( strpart(list(i),1:4) == "func" ) {
               pos = strpos( list(i), "(", 5 );
               funcname = strpart(list(i), 6:pos-1 );
               len = strlen(funcname);
               for(k=len;k<25;k++) funcname += ".";
               grow, func_names, funcname;
               grow, file_names, filename;
               // write,format="%s  %s\n", funcname, filename;
            } else {
               // write,format=" --- discarded %s\n", list(i);
            }
         }
      }
   }

   return;

}
%FILE% mk_region_file.i
/* Function mk_region_file */

func mk_region_file( reg_file_out, coords=, srcname=, offset= )
/* DOCUMENT mk_region_file, reg_file_out, coords=, srcname=, offset=
   Make region file with source names given a
   region file with "circle" regions

   Keywords:
      coords   2-element array with [RA, Dec]
      srcname  string scalar. If 'coords' has not been given the a
               catalog search for this source will be done.
               If 'coords' has been given and 'srcname' is the word "find"
               then the nearest source will be named.

   2005-03-08/NJW (original IDL version)
   2009-03-16/NJW
*/
{
   local dist;

   crd = 0;
   if( numberof(coords) ) {
      ra = coords(1);
      dec = coords(2);
      crd = 1;
   }
   nsrc = numberof(srcname);
   if( crd ) {
      if( nsrc ) {
         if( srcname == "find" ) { // find nearest source within 0.3 deg
            res = nearest_source( ra, dec, 0.3, dist );
            if( is_void(res) ) error,"##55## no source found";
            name = res.name;
         } else { // use as given
            name = srcname;
         }
      } else { // only use coordinates
         name = [];
      }
   } else {
      if( nsrc ) {
         if( srcname == "find" ) {
            error,"##56## nothing to go on";
         } else { // look up in catalog
            res = find_src_by_name( srcname );
            if( is_void(res) ) error,"##57## No source found by name: "+srcname;
            ra = res.ra_obj;
            dec = res.dec_obj;
            name = res.name;
         }
      } else {
         error,"##58## Neither name nor position to go on";
      }
   }


   stream = open( reg_file_out,"w");

   if( is_void(offset) ) offset = 0.3;

   write,stream,format="fk5;circle(%.4f,%.4f,0.1)\n", \
         ra, dec;

   close, stream;

}
%FILE% mk_sky_def.i
func mk_sky_def( input_file, outfile )
{
   x_sky = rscol(input_file,"x_sky",dble=1,nomem=1,silent=1);
   y_sky = rscol(input_file,"y_sky",dble=1,nomem=1,silent=1);
   energy = rscol(input_file,"energy",dble=1,nomem=1,silent=1);
   dphot = rscol(input_file,"dphot",dble=1,nomem=1,silent=1);
   renorm = rscol(input_file,"renorm",dble=1,nomem=1,silent=1);
   sc = rscol(input_file,"sc",str=1,nomem=1,silent=1);
   nh = rscol(input_file,"nh",dble=1,nomem=1,silent=1);
   norm = rscol(input_file,"norm",dble=1,nomem=1,silent=1);
   p1 = rscol(input_file,"p1",dble=1,nomem=1,silent=1);
   dol = rscol(input_file,"dol",str=1,nomem=1,silent=1);

   n = numberof(x_sky);
   w = where(dol == "-" );
   nw = numberof(w);
   if( nw ) dol(w) = " ";

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of extension";
   kwds_set,"DATE", ndate(3),"Date/time of creation";
   kwds_set,"TUNIT1","arcmin","Unit of x_sky";
   kwds_set,"TUNIT2","arcmin","Unit of y_sky";
   kwds_set,"TUNIT3","keV","Unit of energy";
   kwds_set,"TUNIT4","/mm2","Unit of dphot (photon density)";

   wrmfitscols, outfile,"X_SKY",x_sky,"Y_SKY",y_sky,"ENERGY",energy, \
           "DPHOT", dphot, "RENORM", renorm, "SC", sc, "NH", nh, \
           "NORM", norm, "P1", p1, "DOL", dol,clobber=1;
}
%FILE% mk_swid_mosphaii.i
func mk_swid_mosphaii( jemxNum, swid, proj, rmf= )
/* DOCUMENT mk_swid_mosphaii, jemxNum, swid, proj, rmf=

     Makes all preparations to produce a mosaic_spec spectrum,
     executes mosaic_spec, and transforms the resulting
     spectrum to PHAII format.

     Assumes a sky image file has been produced as
      /jemx/njw/sky_ima/jmxi_sky_ima_proj_RRRRPPPPSSSN.fits
     and a corresponding SRCL-RES files as
      /jemx/njw/srcl_res/jmxi_srcl_res_proj_RRRRPPPPSSSN.fits

*/
{
   jstr = "jmx"+itoa(jemxNum);
   Jstr = strupcase(jstr);

  /*
   *   Establish the existence of all necessary files
   *     i.e.   jmxi_sky_ima_s005_012300430010.fits
   *     and    jmxi_srcl_res_s005_012300430010.fits
   *     and if keyword 'rmf' has been defined the rmf file.
   */

   skyimaname = jstr+"_sky_ima_"+proj+"_"+swid+".fits";
   srclname = jstr+"_srcl_res_"+proj+"_"+swid+".fits";
   datdir = "/jemx/njw/";
   not_ok = 0;
   if( !file_test(datdir+"srcl_res/"+srclname) ) {
      write,datdir+"srcl_res/"+srclname+" is missing!";
      not_ok++;
   }
   if( !file_test(datdir+"sky_ima/"+skyimaname) ) {
      write,datdir+"sky_ima/"+skyimaname+" is missing!";
      not_ok++;
   }
   if( !is_void(rmf) ) {
      if( !file_test(rmf) ) {
         write,"RMF file: "+rmf+" is missing!";
         not_ok++;
      }
   }
   if( not_ok ) {
      if( not_ok == 1 ) {
         write,"A file is missing.";
      } else {
         write,format="%i files are missing.\n", not_ok;
      }
      return;
   }

  /*
   *    Get the exposure time
   */

   hdr = headfits(datdir+"sky_ima/"+skyimaname+"["+Jstr+"-SKY.-IMA]");
   exposure = fxpar( hdr, "EXPOSURE" );
   if( is_void(exposure) ) {
      exposure = 1111.; // taken out of the blue, except fairly reasonable
      write,"Exposure was not found and set to 1111 s.";
   } else {
      write,format="Exposure = %.2f s.\n",exposure;
   }

  /*
   *    Get source positions and names
   */

   ra_cat =    rdfitscol(datdir+"srcl_res/"+srclname+"+1","ra_cat");
   dec_cat =   rdfitscol(datdir+"srcl_res/"+srclname+"+1","dec_cat");
   ra_obj =    rdfitscol(datdir+"srcl_res/"+srclname+"+1","ra_obj");
   dec_obj =   rdfitscol(datdir+"srcl_res/"+srclname+"+1","dec_obj");
   name =      rdfitscol(datdir+"srcl_res/"+srclname+"+1","name");
   source_id = rdfitscol(datdir+"srcl_res/"+srclname+"+1","source_id");

   n_srcs = numberof(ra_cat);
   if( n_srcs == 0 ) {
      write,"No sources in this swid.";
      return;
   }
   name = strtrim(name);
   if( n_srcs > 1 ) {
      write,format="Found %i sources.\n", nsrcs;
   } else {
      write,format="Found %i source.\n", nsrcs;
   }

  /*
   *   Prepare running mosaic_spec for each source
   *
   *   There are shell problems by letting Yorick run the
   *   shell scripts that must be under 'tcsh' control.
   *   So all commands are written to the file 'mk_swid_mosphaii.csh'
   *   which must then be executed outside Yorick.
   */

   macro = "#!/bin/tcsh";
   grow,macro,"source /r9/njw/jemx/analysis9/setup_env_osa9";
   grow,macro,"setenv COMMONLOGFILE log";

   for( isrc = 1; isrc <= n_srcs; isrc++ ) {
      write,"Source: "+name(isrc);
      if( dec_cat(isrc) < -90. ) {
         write,"Bad CAT position - exchange with RA/DEC_OBJ";
         ra_cat(isrc) = ra_obj(isrc);
         dec_cat(isrc) = dec_obj(isrc);
      }
      // remove expected output file
      remove,jstr+"_mosphai_"+itoa(isrc)+".fits";

      // build the 'macro' string array with call of
      // mosaic_spec followed by parameters

      grow,macro,"#";
      grow,macro,"#  Sourcename: "+name(isrc);
      grow,macro,"#  Source_id: "+source_id(isrc);
      grow,macro,"#";
      grow,macro,"mosaic_spec \\";
// specifying input file
      line = "DOL_idx=\""+datdir+"sky_ima/"+skyimaname+"[1]\" \\";
      grow,macro,line;
// specifying output file
      line = "DOL_spec=\""+jstr+"_mosphai_"+itoa(isrc)+\
             ".fits("+Jstr+"-PHA1-SPE.tpl)\" \\";
      grow,macro,line;
      grow,macro,swrite(format="ra=%.3f \\",ra_cat(isrc));
      grow,macro,swrite(format="dec=%.3f \\",dec_cat(isrc));
      grow,macro,"posmode=-1 \\";
      grow,macro,"widthmode=-1 \\";
      grow,macro,"EXTNAME=\""+Jstr+"-SKY.-IMA\" \\";
      grow,macro,"Intensity=RECONSTRUCTED \\";
      grow,macro,"size=7 \\";
      grow,macro,"chatty=3";
      //+ prstrarr,macro;
   }
   write_slist,"mk_swid_mosphaii.csh",macro;

   // Prepare for execution and start

   system,"chmod +x mk_swid_mosphaii.csh";
   system,"mk_swid_mosphaii.csh";

   // test for the expected files

   not_ok = 0;
   for( isrc = 1; isrc <= n_srcs; isrc++ ) {
      if( !file_test(jstr+"_mosphai_"+itoa(isrc)+".fits") ) {
         write,"Spec file "+jstr+"_mosphai_"+itoa(isrc)+".fits is missing";
         not_ok++;
      }
   }
   if( not_ok ) {
      if( not_ok == 1 ) {
         write,"A file is missing.";
      } else {
         write,format="%i files are missing.\n", not_ok;
      }
      return;
   }

  /*
   *   Read the spectral data
   */

   for( isrc = 1; isrc <= n_srcs; isrc++ ) {
      rate = rdfitscol(jstr+"_mosphai_"+itoa(isrc)+".fits+1", "rate" );
      stat_err = rdfitscol(jstr+"_mosphai_"+itoa(isrc)+".fits+1", "stat_err" );
      if( isrc == 1 ) {
         n_ener = numberof(rate);
         rates = reform(rate,n_ener,1);
         stat_errs = reform(stat_err,n_ener,1);
      } else {
         grow,rates,rate;
         grow,stat_errs,stat_err;
      }
   }

  /*
   *    Ready to produce the PHAII spectral file
   */

   outfile = jstr+"_mospec_"+proj+"_"+swid+".fits";
   remove, outfile;

   // Get the relevant ARF

   ancrfile = [];
   if( !is_void(rmf) ) {
      arf = rdfitscol(rmf+"["+Jstr+"-IMAG-ARF]","specresp");
      elo = rdfitscol(rmf+"["+Jstr+"-IMAG-ARF]","energ_lo");
      ehi = rdfitscol(rmf+"["+Jstr+"-IMAG-ARF]","energ_hi");
      arfs = arf(,-:1:n_srcs); // expand to number of sources
      elos = elo(,-:1:n_srcs); // expand to number of sources
      ehis = ehi(,-:1:n_srcs); // expand to number of sources
      arffile = jstr+"_mosarf_"+proj+"_"+swid+".fits";
      remove, arffile;
      arf2phaii, arffile, arfs, elos, ehis, telescop="INTEGRAL", \
                 instrume=Jstr;
      write,"Has now written ARF: "+arffile;
      ancrfile = array( arffile, n_srcs );
      for( isrc = 1; isrc <= n_srcs; isrc++ ) ancrfile(isrc) += "{"+itoa(isrc)+"}";
   }
      
   spec2phaii, outfile, rates, stat_errs, ra_obj=ra_cat, dec_obj=dec_cat, \
               name=name, ancrfile=ancrfile, exposure=array(exposure,n_srcs), \
               respfile=rmf, telescop="INTEGRAL", instrume=Jstr;
   write,"Has now written SPE: "+outfile;

}
mm = mk_swid_mosphaii;
write,"Has defined shorthand 'mm' for mk_swid_mosphaii ...";
%FILE% mmach.i
/*
 *    Multi-machine project steering
 *
 *    1) Set up database file with expected files
 *        FITS file with columns:
 *          TAKEN, MACHINE, TIMESTART, FILENAME, PARAMETERS
 *          VERIFY
 *       Remove terminate file if it exists
 *    2) Function to initiate a run, repeats
 *            - check lock file, if absent:
 *               - set lock file
 *               - read TAKEN column, find first free (i)
 *               - update TAKEN(i), MACHINE(i), TIMESTART(i)
 *               - start running in background
 *               - remove lock file
 *             endif
 *    3) Function to check status
 *             Verify result file existence and release a case if it appears to have failed
 *            - check lock file, if absent:
 *               - set lock file
 *               - read TAKEN column, go through all taken ones
 *                  - check file existence inclusive a basic consistency check
 *                  - if invalid
 *                     - mark as free; goto end
 *                  endif
 *                  - if not existing
 *                     - check time difference between now and TIMESTART
 *                     - if suspiciously high, mark as free; goto end
 *                  endif
 *                  - if all OK define terminate file
 *               end:
 *               - remove lock file
 *             endif
 *
 */

func mmach_setup
/* DOCUMENT mmach_setup

*/
{
   n = 10; // number of result files
   fns = array(string,n); // filenames including path
   for(i = 1; i <= n; i++ ) fns(i) = "m/m"+itoa(i,4)+".dat";
   parameters = span(1.,2.,n);
   taken = verify = timestart = array(0,n);
   machine = array("           ",n);

   wrmfitscols,"mmach_controlfile.fits", "TAKEN",taken, "MACHINE", machine, \
         "TIMESTART", timestart, "FILENAME", fns, "PARAMETERS", parameters, \
         "VERIFY", verify;

   remove,"mmach_terminator.txt";
}

func mmach_runs
/* DOCUMENT mmach_runs

*/
{
   local hdr, nrows, tnow;

   if( !file_test("mmach_lock.txt") ) { // skip if controlfile is locked

      system,"touch mmach_lock.txt";

      dol = "mmach_controlfile.fits+1";
      ptr = rdfitsbin( dol, hdr, nrows );
      free = 1 - (taken = *ptr(1));
      timestart = *ptr(3);
      filename = *ptr(4);
      parameters = *ptr(5);
      verify = *ptr(6);

      w = where( free );
      if( numberof(w) == 0 ) {
         write,"No jobs left ...";
         remove,"mmach_lock.txt"; // open for other processes
         return;
      }
      job = w(1); // pick the first available job

      colnum = 1;
      fits_bintable_poke, dol, job, colnum, 1; // mark as 'taken'
      colnum = 2;
      fits_bintable_poke, dol, job, colnum, ghost(); // tell who took the job
      timestamp, tnow;
      colnum = 3;
      fits_bintable_poke, dol, job, colnum, tnow; // set start time in seconds

      remove,"mmach_lock.txt"; // open for other processes

   } // end of if not locked
   else {
      write,"No action, controlfile locked!";
   }
}

func mmach_check
/* DOCUMENT mmach_check

*/
{
   local hdr, nrows, tnow;

   if( !file_test("mmach_lock.txt") ) { // skip if controlfile is locked

      system,"touch mmach_lock.txt";

      dol = "mmach_controlfile.fits+1";
      ptr = rdfitsbin( dol, hdr, nrows );
      free = 1 - (taken = *ptr(1));
      timestart = *ptr(3);
      filename = *ptr(4);
      parameters = *ptr(5);
      to_check = 1 - (verify = *ptr(6));
      n_jobs = nrows;

      write,itoa(n_jobs)+" jobs in total";

      w = where( to_check );
      nw = numberof(w);
      write,"nw = "+itoa(nw);
      if( nw == 0 ) {
         write,"All jobs completed ...";
         remove,"mmach_lock.txt"; // open for other processes
         return;
      }

      n_compl = 0; // to count the jobs seen as completed with this run

      for( i = 1; i <= nw; i++ ) {
         job = w(i); // job to check if completed
         fn = filename(job);
         if( file_test(fn) ) { // mark as completed, i.e. verify = 1
            colnum = 6;
            fits_bintable_poke, dol, job, colnum, 1; // mark as 'verified'
            n_compl++;
         }
      }
      write,"n_compl = "+itoa(n_compl);

      write,itoa(n_compl)+" jobs completed since last check";
      write,itoa(nw - n_compl)+" jobs still waiting for completion";

      remove,"mmach_lock.txt"; // open for other processes

   } // end of if not locked
   else {
      write,"No action, controlfile locked!";
   }
}
%FILE% mroots.i
extern mrootsdoc;
/* DOCUMENT  mroots package ********************

    Functions for root finding

    root_bracket : Identify intervals with a root
                    Auxiliary function to 'zbrent'
    zbrent   :  Brent's method
    rootpoly :

************************************************/

/* Function root_bracket */

func root_bracket( fun_of_x, x1, x2, level, nlevels, lg= )
/* DOCUMENT root_bracket( fun_of_x, x1, x2, level, nlevels, lg= )

    Searches in the interval [x1,x2] for one or two
    roots of the one-dimensional function 'fun_of_x'.

    If (at least) one root is found it returns [x1,x2];
    If (at least) two roots are found [x11,x12,x21,x22] is returned,
    i.e. first to values bracket one root and the last two values
    bracket the second one.

   2012-05-09/NJW
*/
{
   fx1 = fun_of_x(x1);
   fx2 = fun_of_x(x2);

   write,format="rootb x1,x2: %.4f, %.4f, fx1,fx2: %.4f, %.4f, level=%i\n", \
           x1,x2,fx1,fx2,level; 

   if( fx1 == 0. ) error,"x1 is a root";
   if( fx2 == 0. ) error,"x2 is a root";

   if( fx1*fx2 < 0. ) return [x1,x2];

   if( level >= nlevels ) return [];

   // Search for two roots

   // use bi-section
   x = lg ? sqrt(x1*x2) : 0.5*(x1 + x2);
   fx = fun_of_x(x);

   if( fx1*fx < 0. ) return [x1,x,x,x2];

   res1 = root_bracket( fun_of_x, x1, x, level+1, nlevels, lg=lg );
   res2 = root_bracket( fun_of_x, x, x2, level+1, nlevels, lg=lg );
   return grow(res1, res2);

}

/* Function zbrac */

func zbrac( &x1, &x2, fun_of_x, lg= )
/* DOCUMENT ok = zbrac( (>)x1, (>)x2, fun_of_x, lg= )

    Uses x1 and x2 as initial values for the search and returns the
    result in them. Returns 1 if succesful, 0 if the search failed.

    This function will expand the interval in the search for a root.

    The keyword 'lg' will ensure that x is logarithmically searched
    rather than linearly.

    Numerical Recipes p. 245

*/
{
   factor = 1.6;
   ntry = 50;

   xx1 = double(x1);
   xx2 = double(x2);

   fx1 = fun_of_x(xx1);
   fx2 = fun_of_x(xx2);

   kount = 0;

   while( kount < ntry ) {

      write,format="xx1: %.4f, fx1: %.4f\n", xx1, fx1;
      write,format="xx2: %.4f, fx2: %.4f\n", xx2, fx2;

      if( fx1*fx2 < 0. ) {
         x1 = xx1;
         x2 = xx2;
         return 1; // Succesful search
      }

      if( abs(fx1) < abs(fx2) ) {

         if( lg ) {
            xx1 *= (xx1/xx2)^factor
         } else xx1 += factor*(xx1 - xx2);
         fx1 = fun_of_x(xx1);
         write,format="New xx1: %.4f, fx1: %.4f\n", xx1, fx1;

      } else {

         if( lg ) {
            xx2 *= (xx2/xx1)^factor
         } else xx2 += factor*(xx2 - xx1);
         fx2 = fun_of_x(xx2);
         write,format="New xx2: %.4f, fx2: %.4f\n", xx2, fx2;

      }
      kount++;

   }

   return 0; // When you get here the search failed

}

/* Function zbrent */

func zbrent( fun_of_x, x1, x2, tol )
/* DOCUMENT xzero = zbrent( fun_of_x, x1,x2, tol )

    Uses Brent's method to find the root of the function 'fun_of_x' known to lie
    between x1 and x2.

    Numerical recipes,  2011-05-12/NJW
*/
{
   if( is_void(tol) ) tol = 1.e-3;
   itmax = 100;
   epsi = 3.e-8;

   a = x1;
   b = x2;
   fa = fun_of_x(a);
   fb = fun_of_x(b);
   if( fa*fb > 0 ) error,"ZBRENT root must be bracketed between x1 and x2";
   fc = fb;
   for( iter = 1; iter <= itmax; iter++ ) {
      if( fb*fc > 0 ) {
         c = a;
         fc = fa;
         d = b - a;
         e = d;
      }
      if( abs(fc) < abs(fb) ) {
         a = b;
         b = c;
         c = a;
         fa = fb;
         fb = fc;
         fc = fa;
      }
      tol1 = 2.*epsi*abs(b)+0.5*tol; // convergence check
      xm = 0.5*(c - b);
      if( abs(xm) < tol1 || fb == 0.0 ) return b;
      if( abs(e) > tol1 && abs(fa) > abs(fb) ) {
         s = fb / fa;
         if( a == c ) {
            p = 2.*xm*s;
            q = 1. - s;
         } else {
            q = fa / fc;
            r = fb / fc;
            p = s*(2.*xm*q*(q-r) - (b - a)*(r - 1.));
            q = (q - 1.)*(r - 1.)*(s - 1.);
         }
         if( p > 0.0 ) q = -q; // check whether it bounds
         p = abs(p);
         if( 2.*p < min(3.*xm*q - abs(tol1*q), abs(e*q))) {
            e = d;  // accept interpolation
            d = p/q;
         } else {
            d = xm;
            e = d;
         }
      } else {
         d = xm;
         e = d;
      }
      a = b;
      fa = fb;
      if( abs(d) > tol1 ) {
         b += d;
      } else {
         b += SiGn(tol1,xm);
      }
      fb = fun_of_x(b);
   }
   write,"ZBRENT exceeding maximum iteration";
   return b;
}

/* Function rootpoly */

func rootpoly( x, xroots )
/* DOCUMENT y = rootpoly( x, xroots )

    Returns   Prod(x - xroots(i))
*/
{
   n = numberof(xroots);

   y = x - xroots(1);
   for( i = 2; i <= n; i++ ) y *= (x-xroots(i));
   return y;
}

func coef_rootpoly( xroots )
/* DOCUMENT c = coef_rootpoly( xroots )

    Returns the coefficients of the polynomium with
    roots in the array 'xroots'

*/
{
   n = numberof( xroots );
   c = array(double,n+1);

   //+ if( n == 1 ) {
   //+    c(1) = -xroots(1);
   //+    c(2) = 1.;
   //+ }

   for( i = 1; i<= n; i++ ) {
      // x^(i-1)
      if( i == 1 ) {
         coef = 1.;
         for(j=1;j<=n;j++) coef *= (-xroots(j));
         c(i) = coef;
      } else {
         nkom = nkombi(n-i+1,n);
         coef = 0.0;
         for(j = 1; j <= nkom; j++ ) {
            xr_sel = kombi(n-i+1,xroots,j);
            dcoef = 1.;
            for(k=1;k<=n-i+1;k++) dcoef *= (-xr_sel(k));
            coef += dcoef;
         }
         c(i) = coef;
      }
   }
   c(n+1) = 1.0;

   return c;
}
%FILE% mt.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=
  > mt_gravity_bend,gbend,mlength=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_bg_run_eff_area,
  > mt_eff_area_quick,earr=,outfile=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )
  > mt_substr_volume()

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,offset=, cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.4.5, 2013-01-24/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.4.5"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files
   4.4.0  2012-06-04 Added function mt_gravity_bend
   4.4.1  2012-07-04 kkkk
   4.4.2  2012-09-14 Introduced dead pixel map in the detector description
                     and translation.
   4.4.5  2013-01-24 Introduced storage of flux arrays in the extended source
                     simulation (using mem_storage.i package).

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
   long phs_index;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file (pff), check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               //  Changes with version 4.4.5
               //+ if( !file_test(filepff) ) error,"Not found: "+filepff;
               //+ fh = headfits( dolpff );
               //+ extnm = fxpar(fh,"extname");
               //+ if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
               //+            error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   local energ_lo, energ_hi, photflux;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      //  Changes with version 4.4.5
      //+ if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      //+ dol = src_spec_file+"+1";
      //+ hdr = headfits(dol);
      //+ energ_lo = rdfitscol( dol, "energ_lo" );
      //+ energ_hi = rdfitscol( dol, "energ_hi" );
      //+ photflux = rdfitscol( dol, "photflux" );

      // three new lines from version 4.4.5

      mem_restore,"ENERG_LO",energ_lo;
      mem_restore,"ENERG_HI",energ_hi;
      mem_restore, src_spec_file, photflux;

      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      // evaluate the photon density (include conversion to /mm2)
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if(!is_void(Src_offaxis))kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      if(!is_void(Src_azimuth))kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"SAMPLING", samp, "One out of this number of photons is used";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The keyword 'gbend' (Gravitational bending) applies only for loading
   a mirror deformation file. The function mt_gravity_bend is called.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
   Updated to version 4.4.2   2012-09-14/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type, Dead_pixel_map;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         /*
          * Gravitational sag is introduced if requested. The phase is rotated like the optic
          * is rotated.
          */
         if( !is_void(gbend) ) mt_gravity_bend, gbend;
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      // Load the dead pixel map if found else set to 'all active'
      //    A pixel value of 1 (one) signals that the pixel is dead
      //    A pixel value of 0 (zero) signals that the pixel is active

      dol_dead_pixel_map = comgets(detfile,"dead_pixel_map");
      if( is_void(dol_dead_pixel_map)) {
         Dead_pixel_map = array(short,Num_pixels1,Num_pixels2);
      } else {
         local file_dead_pixel_map, extno_dpm;
         get_exten_no, dol_dead_pixel_map, file_dead_pixel_map, extno_dpm;
         if( !file_test(file_dead_pixel_map) ) error,"MT_LOAD did not find "+file_dead_pixel_map;
         Dead_pixel_map = readfits(dol_dead_pixel_map);
         dms = dimsof(Dead_pixel_map);
         if( Num_pixels1 != dms(2) || Num_pixels2 != dms(3) ) error,"MT_LOAD inconsistency in dead pixel map dimensions";
      }

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=, title= )
/* DOCUMENT im = mt_qimage( z_value )
       or   mt_qimage, z_value

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one
   Keyword 'title'  Like for 'plot'

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
   Version 4.3   2012-06-01/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, gbend=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, gbend=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.

   Keywords:
        no_scatter=1  will disable scattering (but include Rcoef).
        no_deform=1   will disable mirror deformations.
        chat          puts info on terminal
        gbend         defines the amount of gravitational bending [mm]

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num),gbend=gbend;
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten=, angle=, unit= )
/* DOCUMENT mt_reflplot, win=, atten=, angle=, unit=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to current window.
                atten only one curve for this many angles
                angle Plot only for this angle (overrides 'atten')
                unit  Unit of 'angle'. Can be "deg", "rad" (default), "mrad",
                                       "mdeg", "arcsec", or "arcmin"

   2007-10-31/NJW, updated 2012-10-29/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = window();
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";

   if( is_void(angle) ) {

      if( Scatter_type == 1 ) {
         plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
            title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      } else { // must be of type 2
         plot, E_uniq, R_coefarr(1,), \
            title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      }
   
      if( na > 1 ) {
         for( i = 2; i <= na; i += atten ) {
            if( Scatter_type == 1 ) {
               oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
            } else {
               oplot, E_uniq, R_coefarr(i,);
            }
         }
      }
      str = swrite(format="Coating type : %i",Coating_scat);
      xyouts,0.2,0.83,str,ndc=1,align=0,charsize=1.1;
      str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
           Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
      xyouts,0.2,0.80,str,ndc=1,align=0,charsize=1.1;
      str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
           Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
      xyouts,0.2,0.77,str,ndc=1,align=0,charsize=1.1;

   } else {

      if( typeof(unit) == "string" ) {
         if( unit == "deg" ) angle *= pi/180.;
         if( unit == "mrad" ) angle /= 1000.;
         if( unit == "mdeg" ) angle *= pi/180000.;
         if( unit == "arcsec" ) angle *= pi/(180.*3600.);
         if( unit == "arcmin" ) angle *= pi/(180.*60.);
      }
      ne = numberof(E_uniq);
      r = array(double,ne);
      for(i = 1; i <= ne; i++ ) r(i) = mt_get_rcoef(E_uniq(i),angle);
      plot, E_uniq, r, title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      str = swrite(format="Coating type : %i",Coating_scat);
      xyouts,0.2,0.83,str,ndc=1,align=0,charsize=1.1;
      str = swrite(format="Angle: %9.2e rad = %8.1f mdeg", \
           angle, angle*(180/pi)*1000.);
      xyouts,0.2,0.80,str,ndc=1,align=0,charsize=1.1;
   }

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic in the counterclock
                  direction when viewed from the X-ray source towards the aperture.
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform
   gbend       Amplitude of gravitational bending [mm] of optic

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation of the optic %.3f deg around z\n", roll;
   mt_roll, -roll*pi/180; // convert to radians, mt_roll rotates the photons
      // so the roll angle must have opposite sign

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,gbend=gbend,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back, remember the photon rotation is opposite the
   //    rotation of the optic
   mt_roll, roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   if( !is_void(Dphot) ) kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   if( !is_void(Src_offaxis)) kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   if( !is_void(Src_azimuth)) kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFL%i",i);
         kwds_setlongstr,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
   Version 4.4.2 2012-09-14/NJW with dead pixel detector map
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Data in mirror deformation file are not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) {
      write,"Bad definition of 'Dim_focp'";
      warn += 100000;
   }
   if( numberof(Pix_focp) != 1 ) {
      write,"Bad definition of 'Pix_focp'";
      warn += 100000;
   }

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else {
         warn += 1000000;
         write,"Did not find detector_descr_file: "+Detector_descr_file;
      }
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,ndc=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( offset=, cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, offset=, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: offset  - a 2 element array [dx,dy] in mm that shifts the
                       optical axis relative to the detector center.
             cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo, \
          Det_offset, Dead_pixel_map;
// yxclude =

   if( is_void(offset) ) {
      Det_offset = [0.,0.];
   } else {
      if( numberof(offset) != 2 ) error,"Error in offset for mt_detector";
      Det_offset = double(offset);
   }
   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probability
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;
      evt.phs_index = i;

      // now determine the pixel

      w = where(Xpixlo - Det_offset(1) < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1) + Det_offset(1); // relative to detector center
      w = where(Ypixlo - Det_offset(2) < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      if( Dead_pixel_map(evt.rawx,evt.rawy) ) continue; // skip if landed on a dead pixel
      evt.dety = Phs(sel(i)).E(2) + Det_offset(2); // relative to detector center
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      dead = where( Dead_pixel_map );
      if( numberof(dead) ) {
         idx = (bkg.rawy - 1) * Num_pixels1 + bkg.rawx;
         idx = whereany( idx, dead );
         bkg = rem_elem( bkg, idx );
         nbkg = numberof( bkg );
      }
      bkg.flag = 0;
      bkg.phs_index = -2;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length, Det_offset;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2. + Det_offset(1)/Pixel_size1,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2. + Det_offset(2)/Pixel_size2,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   if( am_subroutine() ) {
      disp, im;
   } else return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.phs_index = -1;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.phs_index = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   // Reset the Energ_lo, Energ_hi, and Flux content of memory
   mem_reset;

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   memflag = 1;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      // Change with version 4.4.5
      //+ mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
      //+     p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,nof=1,mem=memflag,silent=1;
      sx_sum += Sx_photflux;
      memflag++;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians. Please note that this is the opposite angle
   of the optic rotation.

   The roll angle is saved as an external variable: Roll_phot (in radians).

*/
{
   extern Phs, Roll_phot;

   Roll_phot = roll_angle;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'gbend', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, gbend=gbend, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/ymbr_<random string>.ymbr' and a yorick save
    file '<dir>/ytmp_<random string>.ytmp' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"ymbr_"+ranstr(15)+".ymbr";
   fn = open(fname,"w");
   badir = get_env("HOSTSITE") == "CALTECH" ? "/users/njw/yorick" : "/home/njw/yorick";
   write,fn,format="#include \"%s/common.id\"%s",badir,"\n";
   write,fn,format="#include \"%s/mt_rayor.i\"%s",badir,"\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(gbend) ) comm += (",gbend="+ftoa(gbend,ndec=4));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if( !is_void(offaxis) ) kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      if( !is_void(azimuth) ) kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius, cen_dx=, cen_dy=, photfile=, undo=, chat= )
/* DOCUMENT mt_aperture_stop, z_position, open_radius, cen_dx=, cen_dy=, photfile=, undo=, chat=

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    Keywords
        cen_dx      [mm] displacement in x-direction
        cen_dy      [mm] displacement in y-direction
        photfile    Operate on the named photonfile
        undo        Undo the operation on the named photonfile
        chat        Display certain extra information

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as, Cen_dx_as, Cen_dy_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( !is_void(z_position) ) {
      Z_position_as = double(z_position);
   }
   if( !is_void(open_radius) ) {
      Open_radius_as = double(open_radius);
   }

   // Shifting center position in x/y directions

   if( is_void(cen_dx) ) {
      if( is_void(Cen_dx_as) ) Cen_dx_as = 0.0;
   } else {
      Cen_dx_as = double(cen_dx);
   }
   if( is_void(cen_dy) ) {
      if( is_void(Cen_dy_as) ) Cen_dy_as = 0.0;
   } else {
      Cen_dy_as = double(cen_dy);
   }

   if( is_void(photfile) ) {

      if( is_void(Phs) ) {
         write,"External 'Phs' does not exist, no action.";
         return; // If no photons then only set externals
      }
      w0 = where( Phs.status == 0 );
      if( numberof(w0) == 0 ) {
         if( chat ) write,"Found no status zero photons, no action.";
         return; // No good photons, simply skip this step
      }

      mt_propagate, Z_position_as;
      eq_nocopy, cE, Phs.E;
      r = sqrt((cE(1,w0)-Cen_dx_as)^2 + (cE(2,w0)-Cen_dy_as)^2);
      w = where( r > Open_radius_as );
      if( numberof(w) ) Phs(w0(w)).status = 201;
      mt_propagate, 0.0; // set photon positions (back) to focal plane

   } else {  // Operate on a photon file

      if( !file_test(photfile) ) {
         write,"Photfile: "+photfile+" was not found, no action.";
         return;
      }

      local hdr, nrows;
      ptr = rdfitsbin( photfile+"+1", hdr, nrows );
      colstat = fits_colnum(hdr,"status");
      status = *ptr(colstat);
      detx = *ptr(fits_colnum(hdr,"detx"));
      dety = *ptr(fits_colnum(hdr,"dety"));
      rayx = *ptr(fits_colnum(hdr,"rayx"));
      rayy = *ptr(fits_colnum(hdr,"rayy"));
      rayz = *ptr(fits_colnum(hdr,"rayz"));

      if( undo ) {
         nw = numberof( (w = where( status == 201 ) ) );
         if( nw == 0 ) {
            if( chat ) write,"Found no status 201 photons, no action.";
            return; // No 201 photons, simply skip this step
         }
         status(w) = 0; // Remove aperture stop signature
         if( chat ) write,"Updating "+photfile+" with "+itoa(nw)+" reversals to  status zero ...";
         fits_bintable_poke, photfile+"+1", 1, colstat, status;
         if( chat ) write,"done";

      } else {

         nw = numberof( (w = where( status == 0 ) ) );
         if( nw == 0 ) {
            if( chat ) write,"Found no status zero photons, no action.";
            return; // No good photons, simply skip this step
         }

         kount = 0;
         for( i = 1; i <= nw; i++ ) {
            p = _propa([detx(w(i)),dety(w(i)),0.],[rayx(w(i)),rayy(w(i)),rayz(w(i))],Z_position_as);
            if( sqrt( (p(1) - Cen_dx_as)^2 + (p(2) - Cen_dy_as)^2) > Open_radius_as ) {status(w(i)) = 201; kount++;}
         }
         if( kount ) {
            if( chat ) write,"Updating "+photfile+" with "+itoa(kount)+" times status 201 ...";
            fits_bintable_poke, photfile+"+1", 1, colstat, status;
            if( chat ) write,"done";
         } else {
            if( chat ) write,"No update of "+photfile+" was required.";
         }
      }
   }
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}

/* Function mt_gravity_bend */

func mt_gravity_bend( gbend, mlength= )
/* DOCUMENT mt_gravity_bend, gbend, mlength=

    Make mirror deformation from circular bending of an X-ray telescope
    horizontally suspended in a gravitational field giving largest deviation
    in the middle.

    deform = -delta_r = -(gbend/mlength^2) * (z + mlength) * (z - mlength)

    for mirror parts above the axis and with reversed sign below the axis.
    Sign reversal is taken care of by the sine function in azimuth.

        For 1-alpha   z c [ 0., mlength]
        For 3-alpha   z c [-mlength, 0.]

    The 'gbend' parameter is the distance (same unit as 'mlength', often mm)
    between the cord and the circular arc where it is at a maximum,
    i.e. right between the 1alpha and 3alpha mirror sections.

    Use dimensions from already existing deformation cube Mirror_deform_arr.

    The mirror length can be set with keyword 'mlength' (defaults to 225. mm)

    2012-06-04/NJW

*/
{
   extern Mirror_deform_arr, Module_num, Roll_phot;

   //   Module_num is either 1 (U or 1-alpha section) or 2 (L or 3-alpha section)

   if( is_void(mlength) ) mlength = 225.; // mm - mirror length

   dms = dimsof( Mirror_deform_arr );

   naz = dms(2);
   nz =  dms(3);
   nlayers = dms(4);

   // Ensure that the largest deviation is found for low indices
   // for the 1-alpha section

   if( Module_num == 1 ) {

      z = span(0.,mlength,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   } else {

   // Ensure that the largest deviation is found for high indices
   // for the 3-alpha section

      z = span(-mlength,0.,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   }

}

/* Function mt_substr_volume */

func mt_substr_volume( void )
{
// ynclude = jdhf
   extern Mirror_thicknessarr, Num_modules, R1arr, R2arr, Om_files, Z1arr, Z2arr;
// yxclude =

   // Loading first mirror module;
   mt_load,omfile=Om_files(1);

   // vol = Mirror_thicknessarr * 0.5 * (R1arr + R2arr) * 2 * pi * (Z1arr - Z2arr);
   vol = pi * sum( Mirror_thicknessarr * (R1arr + R2arr) * (Z1arr - Z2arr) );

   if( Num_modules > 1 ) {
      mt_load,omfile=Om_files(2);
      vol += pi * sum( Mirror_thicknessarr * (R1arr + R2arr) * (Z1arr - Z2arr) );
   }

   write,format="Substrate volume = %10.2e mm3 = %10.2e liters\n", vol, vol*1.e-6;

   return vol;

}
%FILE% mt_collapse_psf.i
/* Function mt_collapse_psf */

func mt_collapse_psf( &y )
/* DOCUMENT x = mt_collapse_psf( >y )

   Part of the MT_RAYOR package.

   Collapses the resulting positions of rays in the current
   position based on the azimuth angle of telescope entering.

   Assumes the presence of Phs as an external variable.

   Returns the x-values in mm and y as an argument for the status==0 photons.

*/
{
   w = where( Phs.status == 0 );
   if( numberof(w) ) {
      eq_nocopy, e, Phs(w).E;   // focal plane position
      eq_nocopy, e1, Phs(w).E1; // entrance position

      phi = atan(e1(2,),e1(1,));
      x =  e(1,)*cos(phi) + e(2,)*sin(phi);
      y = -e(1,)*sin(phi) + e(2,)*cos(phi);
      return x;
   } else {
      write,"No status==0 photons found";
      return [];
   }
}
%FILE% mt_define_coating_chequer.i
/* Function mt_define_coating_chequer */

func mt_define_coating_chequer( filename, mode )
/* DOCUMENT mt_define_coating_chequer, filename, mode

   Made for version 4.0 of MT_RAYOR  2011-08-25/NJW
*/
{
// ynclude = zmm
   extern N_mirrors;
// yxclude =

   if( is_void(mode) ) mode = 1;

   // Define file with multi-coatings on the mirrors
   mirarr = indgen(N_mirrors)
   azbds = 1.; // only for type definition
   zbds = 1.; // only for type definition
   coating = 1; // only for type definition
   wrmfitscols,filename, "MIRROR_NUMBER", mirarr, "AZBDS", azbds, \
                         "ZBDS", zbds, "COATING", coating, var=[2,3,4], \
                         clobber=1, extname="COATING_CHEQUER";

   if( mode == 1 ) {

      //  Degenerate case (mode == 1) where the entire mirror shell has the same
      //  coating number.

      az = [0.,2*pi];
      z  = [0., 1.];
      for( mir = 1; mir <= N_mirrors; mir++ ) {
         // The coat definition within the loop is a preparation
         // for a layer dependent coating type
         coat = [1]; // only one number per layer
         fits_bintable_poke,filename+"+1",mir,"azbds",az;
         fits_bintable_poke,filename+"+1",mir,"zbds",z;
         fits_bintable_poke,filename+"+1",mir,"coating",coat;
      }

   } else {
   
      //  Example with coating #2 in the outer parts of the mirrors in a telescope
      //  produced in quadrants
      //  and coating #1 in the inside

      daz = 0.157; // = (2*pi*0.2)/8
      baz = span(0.,2*pi,5);
      az = [baz(1), baz(1)+daz, \
            baz(2) - daz, baz(2) + daz, \
            baz(3) - daz, baz(3) + daz, \
            baz(4) - daz, baz(4) + daz, \
            baz(5) - daz, baz(5)];
      z = [0.,0.1,0.9,1.];
      n = (numberof(z)-1)*(numberof(az)-1);
      // index = (i_z - 1)*N_az + i_az
      coat = [2,2,2,2,2,2,2,2,2, \
              2,1,2,1,2,1,2,1,2, \
              2,2,2,2,2,2,2,2,2];

      for( mir = 1; mir <= N_mirrors; mir++ ) {
         fits_bintable_poke,filename+"+1",mir,"azbds",az;
         fits_bintable_poke,filename+"+1",mir,"zbds",z;
         fits_bintable_poke,filename+"+1",mir,"coating",coat;
      }

   }
}
%FILE% mt_evts2txt.i
func mt_evts2txt( events_fits_file )
/* DOCUMENT mt_evts2txt, events_fits_file

    Write a text file with columns:
     RAWX, RAWY, DETX, DETY, ENERGY

*/
{
   local hdr, nrows;

   p = strpos(events_fits_file,".fits",rev=1);
   outfile = strpart(events_fits_file,1:p-1)+".txt";
   ptr = rdfitsbin(events_fits_file+"+1", hdr, nrows );
   rawx = *ptr(fits_colnum(hdr,"RAWX"));
   rawy = *ptr(fits_colnum(hdr,"RAWY"));
   detx = *ptr(fits_colnum(hdr,"DETX"));
   dety = *ptr(fits_colnum(hdr,"DETY"));
   energy = *ptr(fits_colnum(hdr,"ENERGY"));

   wstab, outfile, rawx, rawy, detx, dety, energy, fmt="%7i%7i%10.3f%10.3f%11.3f", \
       hdr=["// "+ndate(3),"// input = "+events_fits_file,"// RAWX   RAWY   DETX(mm) DETY(mm) ENERGY(keV)"];
}
%FILE% mt_extern.i
   extern Acoef, Acoefarr, Angle_inarr, Angle_uniq, Anglesarr, Coat_list, \
      Coatingarr, Dcoef, Dcoefarr, Dim_focp, Distributionarr, \
      Dphot, E_uniq, Earr, Energy, Fcoef, Logfilename, Logstream, Mirror_angle, \
      Mirror_anglearr, Mirror_coating, Mirror_lengths, Mirror_thickness, \
      Mirror_thicknesses, Modtype, Module_num, N_mirrors, Num_modules, \
      Om_files, Om_functions, Om_parameters, Opt_module_file, Phs, \
      Pix_focp, R1_mirror, R1arr, R2arr, R_coefarr, R_inner, R_outer, \
      Rb1iarr, Rb1oarr, Rb2iarr, Rb2oarr, Scat_files, Scatter_file, \
      Src_azim, Src_offaxis, Version, Z1_mirror, Z1_setups, Z1arr, \
      Z2_setups, Z2arr, Z_reference, Zb1iarr, Zb1oarr, \
      Zb2iarr, Zb2oarr, Zfocus, Zfocusarr;
%FILE% mt_import_rcoef.i
#include "mt_rayor-4.2.i"

/* Function mt_import_rcoef */

func mt_import_rcoef( scat_type1_file, scat_in_file )
/* DOCUMENT mt_import_rcoef, scat_type1_file, scat_in_file

     Update the R_COEF column in 'scat_type1_file', the target file.
     The values are taken from 'scat_in_file'

    2012-03-02/NJW
*/
{

   write,"Loading input scatter file ..."
   mt_load,scatfile=scat_in_file;
   write,"Loading done ...";

   // Get relevant info from existing scatter file

   if( !file_test(scat_in_file)) error,"Missing file: "+scat_in_file;
   if( !file_test(scat_type1_file)) error,"Missing file: "+scat_type1_file;

   write,"Start reading the scatter file ...";
   dol = scat_type1_file+"+1";
   ptr = rdfitsbin(dol, hdr, nrows );
   energy = (*ptr(fits_colnum(hdr,"energy"))); // remember that first value is a dummy
   n_energy = nrows;
   angle_in = (*ptr(fits_colnum(hdr,"angle_in"))); // remember that first value is a dummy
   rcoef = (*ptr(fits_colnum(hdr,"r_coef")));
   //+ distribution = *ptr(fits_colnum(hdr,"distribution"));
   //+ distribution = transpose(distribution); // remember that we get the transposed
                     // array relative to 'rdfitscol'
   //+ angles_dist = distribution(,1);
   //+ n_angles_dist = numberof(angles_dist);
   write,"Got all now ...";

   //  **  Loop over all energies and angle in the target scatter file

   for( i = 2; i <= n_energy; i++ ) {

      angle_scat = angle_in(i);
      energy_scat = energy(i);

      rcoef(i) = mt_get_rcoef( energy(i), angle_in(i) );

   }

   fits_bintable_poke, scat_type1_file+"+1", 1, "R_COEF", rcoef;

}
%FILE% mt_import_scatter.i
#include "get_mikes_scat_frac.i"

/* Function mt_import_scatter */

func mt_import_scatter( scat_type1_file, prototype_file, outfile, coat= )
/* DOCUMENT mt_import_scatter, scat_type1_file, scat_dist_file, outfile, coat=

    The 'scat_type1_file' defines the energies and angles as well as the size
    of the distribution array.
    The input data file, 'scat_dist_file', that redefines the scatter
    distributions must be an s-type text file with keywords 'energy' (keV),
   'angle_in' (deg), and 'scat_frac'.
    2-theta angle in deg in first column of this file, and
    the scatter distribution in fourth column

    File writing will only be done if the third argument (outfile)
    is a scalar string.

*/
{
   extern Angles_dist, Energy, Angle_in, Distribution;

   local nrows, hdr;

   // Get relevant info from existing scatter file

   if( !file_test(prototype_file)) error,"Missing file: "+prototype_file;
   if( !file_test(scat_type1_file)) error,"Missing file: "+scat_type1_file;

   write,"Start reading the scatter file ...";
   dol = scat_type1_file+"+1";
   ptr = rdfitsbin(dol, hdr, nrows );
   energy = (*ptr(fits_colnum(hdr,"energy"))); // remember that first value is a dummy
   Energy = energy(2:0);
   n_energy = nrows;
   angle_in = (*ptr(fits_colnum(hdr,"angle_in"))); // remember that first value is a dummy
   Angle_in = angle_in(2:0);
   rcoef = (*ptr(fits_colnum(hdr,"r_coef")));
   distribution = *ptr(fits_colnum(hdr,"distribution"));
   distribution = transpose(distribution); // remember that we get the transposed
                     // array relative to 'rdfitscol'
   angles_dist = distribution(,1);
   Angles_dist = angles_dist;
   //+ n_angles_dist = numberof(angles_dist);
   dangles_dist = avg(angles_dist(dif));
   izero = abs(angles_dist)(mnx);
   if( is_void(coat) ) { // not given here, take from scatter file
      coat = fxpar( hdr, "coating" );
      if( is_void(coat) ) coat = 1; // set default value
   }
   write,"Got all now ...";

   //  **   Get the prototype input data

   energy_proto = comget(prototype_file, "energy");   // in keV
   angle_in_proto = comget(prototype_file,"angle_in"); // in deg
   //+ glass = comgets(prototype_file,"glass");
   //+ code = comgets(prototype_file,"code");
   //+ scat_frac = comget(prototype_file,"scat_frac");
   a = (rscol( prototype_file, 1, nomem=1,silent=1 ) - 2*angle_in_proto) * pi/180.; // convert to radians
   cs = rscol( prototype_file, 4, nomem=1,silent=1 ); // reading the scatter part
   // ** redistribute to angular scale of scatter file
   cs = interp( cs, a, angles_dist );
   w = where( angles_dist < -angle_in_proto*pi/180. );
   if( numberof(w) ) cs(w) = 0.0;  // no scatter behind the mirror
   //+ cssum = cs(sum);
   //+ cs(izero) += cssum * (1. - scat_frac) / scat_frac;
   ilimit_proto = abs(angles_dist + angle_in_proto*pi/180.)(mnx);

   //  **  Loop over all energies and angle in the scatter file

   for( i = 2; i <= n_energy; i++ ) {

      angle_scat = angle_in(i);
      energy_scat = energy(i);
      scat_frac = 0.125 * get_mikes_scat_frac( energy_scat, angle_scat );

      // expand or compress the left side of the prototype distribution
      // in order to match the actual incidence angle

      ilimit = abs(angles_dist + angle_scat)(mnx);
      if( ilimit == izero ) ilimit--; // avoid division by zero

      ratio = angles_dist(ilimit_proto)/angles_dist(ilimit)

      j = indgen(ilimit:izero);
      jhat = long(izero - (izero - j)*ratio);

      d = cs;
      d(1:izero) = 0.0;
      d(j) = cs(jhat);
      dsum = d(sum);
      d(izero) += dsum * (1. - scat_frac) / scat_frac;
      distribution(,i) = d;

   }

   Distribution = distribution;

   if( typeof(outfile) == "string" && is_scalar(outfile) ) {
      str = array(string,n_energy);
      str(1) = "Angle values in radians";
      str(2:0) = prototype_file;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_import_scatter","produced this file";
      //+ kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"ENERMIN", energy(2),"[keV] Minimum energy of table";
      kwds_set,"ENERMAX", energy(0),"[keV] Maximum energy of table";
      kwds_set,"ANGLEMAX", angle_in(0),"[rad] Maximum grazing angle of table";
      kwds_set,"DISTAMAX", angles_dist(0),"[rad] Maximum scatter angle of distribution";
      kwds_set,"COATING", coat, "Coating number";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
          "R_COEF", float(rcoef), \
          "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
          clobber=1, extname="SCATTER_TYPE1";
      write,format="Has written scatter file %s\n", outfile;
   } else write,"Skipped file writing ...";

}
%FILE% mt_radii.i
/* Function mt_radii */

func mt_radii( zpos, status=, bsel= )
/* DOCUMENT r = mt_radii( zpos, status=, bsel= )
*/
{
// ynclude = eiidf
   extern Phs;
// yxclude =

   cE = Phs.E;
   curz = cE(3,avg);
   mt_propagate, zpos;
   cE = Phs.E;
   mt_propagate, curz;

   if( !is_void(status) ) {
      if( !is_void(bsel) ) {
         w = where( Phs.status==status & Phs.bounce==bsel );
      } else {
         w = where( Phs.status==status );
      }
   } else {
      if( !is_void(bsel) ) {
         w = where( Phs.bounce==bsel );
      } else {
         w = indgen(numberof(Phs));
      }
   }
   return sqrt(cE(1,w)^2 + cE(2,w)^2);
}
%FILE% mt_rayor-4.2.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_eff_area_quick,earr=,samp=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.2.2, 2012-03-01/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.2.2"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      dol = src_spec_file+"+1";
      hdr = headfits(dol);
      energ_lo = rdfitscol( dol, "energ_lo" );
      energ_hi = rdfitscol( dol, "energ_hi" );
      photflux = rdfitscol( dol, "photflux" );
      // evaluate the photon density (include conversion to /mm2)
      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal= )
/* DOCUMENT im = mt_qimage( z_value, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal= )
       or   mt_qimage, z_value, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.
   Setting keyword 'no_scatter=1' will disable scattering (but include Rcoef).
   Setting keyword 'no_deform=1' will disable mirror deformations.

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num);
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten= )
/* DOCUMENT mt_reflplot, win=, atten=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to 0 (zero).
                atten only one curve for this many angles

   2007-10-31/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = 0;
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";
   if( Scatter_type == 1 ) {
      plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   } else { // must be of type 2
      plot, E_uniq, R_coefarr(1,), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   }

   if( na > 1 ) {
      for( i = 2; i <= na; i += atten ) {
         if( Scatter_type == 1 ) {
            oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
         } else {
            oplot, E_uniq, R_coefarr(i,);
         }
      }
   }
   str = swrite(format="Coating type : %i",Coating_scat);
   xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
   xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
   xyouts,0.2,0.77,str,device=1,align=0,charsize=1.1;

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation %.3f deg around z\n", roll;
   mt_roll, roll*pi/180; // convert to radians

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back
   mt_roll, -roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFILE%i",i);
         kwds_set,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) warn += 100000;
   if( numberof(Pix_focp) != 1 ) warn += 100000;

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else warn += 1000000;
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,device=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo;
// yxclude =

   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probabilitity
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;

      // now determine the pixel

      w = where(Xpixlo < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1);
      w = where(Ypixlo < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      evt.dety = Phs(sel(i)).E(2);
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      bkg.flag = 0;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      sx_sum += Sx_photflux;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians.

*/
{
   extern Phs;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/mbr_<random string>.ymac' and a yorick save
    file '<dir>/y_<random string>.ysav' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"mbr_"+ranstr(15)+".ymac";
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor-4.2.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor-4.2.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius )
/* DOCUMENT mt_aperture_stop, z_position, open_radius

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( is_void(z_position) ) {
      z_position = Z_position_as;
   } else {
      Z_position_as = double(z_position);
   }
   if( is_void(open_radius) ) {
      open_radius = Open_radius_as;
   } else {
      Open_radius_as = double(open_radius);
   }
   if( is_void(Phs) ) return; // If no photons then only set externals
   w0 = where( Phs.status == 0 );
   if( numberof(w0) == 0 ) return; // No good photons, simply skip this step

   mt_propagate, Z_position_as;
   eq_nocopy, cE, Phs.E;
   r = sqrt(cE(1,w0)^2 + cE(2,w0)^2);
   w = where( r > Open_radius_as );
   if( numberof(w) ) Phs(w0(w)).status = 201;
   mt_propagate, 0.0; // set photon positions (back) to focal plane
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}
%FILE% mt_rayor-4.3.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_eff_area_quick,earr=,samp=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.3.1, 2012-06-01/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.3.1"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
   long phs_index;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      dol = src_spec_file+"+1";
      hdr = headfits(dol);
      energ_lo = rdfitscol( dol, "energ_lo" );
      energ_hi = rdfitscol( dol, "energ_hi" );
      photflux = rdfitscol( dol, "photflux" );
      // evaluate the photon density (include conversion to /mm2)
      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=, title= )
/* DOCUMENT im = mt_qimage( z_value )
       or   mt_qimage, z_value

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one
   Keyword 'title'  Like for 'plot'

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
   Version 4.3   2012-06-01/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, gbend=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, gbend=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.

   Keywords:
        no_scatter=1  will disable scattering (but include Rcoef).
        no_deform=1   will disable mirror deformations.
        chat          puts info on terminal
        gbend         defines the amount of gravitational bending [mm]

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num),gbend=gbend;
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten= )
/* DOCUMENT mt_reflplot, win=, atten=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to 0 (zero).
                atten only one curve for this many angles

   2007-10-31/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = 0;
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";
   if( Scatter_type == 1 ) {
      plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   } else { // must be of type 2
      plot, E_uniq, R_coefarr(1,), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   }

   if( na > 1 ) {
      for( i = 2; i <= na; i += atten ) {
         if( Scatter_type == 1 ) {
            oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
         } else {
            oplot, E_uniq, R_coefarr(i,);
         }
      }
   }
   str = swrite(format="Coating type : %i",Coating_scat);
   xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
   xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
   xyouts,0.2,0.77,str,device=1,align=0,charsize=1.1;

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic in the counterclock
                  direction when viewed from the X-ray source towards the aperture.
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform
   gbend       Amplitude of gravitational bending [mm] of optic

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation of the optic %.3f deg around z\n", roll;
   mt_roll, -roll*pi/180; // convert to radians, mt_roll rotates the photons
      // so the roll angle must have opposite sign

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,gbend=gbend,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back, remember the photon rotation is opposite the
   //    rotation of the optic
   mt_roll, roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   if( !is_void(Dphot) ) kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFILE%i",i);
         kwds_set,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) warn += 100000;
   if( numberof(Pix_focp) != 1 ) warn += 100000;

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else warn += 1000000;
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,device=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo;
// yxclude =

   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probability
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;
      evt.phs_index = i;

      // now determine the pixel

      w = where(Xpixlo < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1);
      w = where(Ypixlo < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      evt.dety = Phs(sel(i)).E(2);
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      bkg.flag = 0;
      bkg.phs_index = -2;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.phs_index = -1;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.phs_index = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      sx_sum += Sx_photflux;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians. Please note that this is the opposite angle
   of the optic rotation.

   The roll angle is saved as an external variable: Roll_phot (in radians).

*/
{
   extern Phs, Roll_phot;

   Roll_phot = roll_angle;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/mbr_<random string>.ymac' and a yorick save
    file '<dir>/y_<random string>.ysav' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"mbr_"+ranstr(15)+".ymac";
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor-4.2.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor-4.2.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius )
/* DOCUMENT mt_aperture_stop, z_position, open_radius

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( is_void(z_position) ) {
      z_position = Z_position_as;
   } else {
      Z_position_as = double(z_position);
   }
   if( is_void(open_radius) ) {
      open_radius = Open_radius_as;
   } else {
      Open_radius_as = double(open_radius);
   }
   if( is_void(Phs) ) return; // If no photons then only set externals
   w0 = where( Phs.status == 0 );
   if( numberof(w0) == 0 ) return; // No good photons, simply skip this step

   mt_propagate, Z_position_as;
   eq_nocopy, cE, Phs.E;
   r = sqrt(cE(1,w0)^2 + cE(2,w0)^2);
   w = where( r > Open_radius_as );
   if( numberof(w) ) Phs(w0(w)).status = 201;
   mt_propagate, 0.0; // set photon positions (back) to focal plane
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}
%FILE% mt_rayor-4.4.0.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=
  > mt_gravity_bend,gbend,mlength=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_eff_area_quick,earr=,samp=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.4.0, 2012-06-04/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.4.0"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files
   4.4.0  2012-06-04 Added function mt_gravity_bend

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
   long phs_index;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      dol = src_spec_file+"+1";
      hdr = headfits(dol);
      energ_lo = rdfitscol( dol, "energ_lo" );
      energ_hi = rdfitscol( dol, "energ_hi" );
      photflux = rdfitscol( dol, "photflux" );
      // evaluate the photon density (include conversion to /mm2)
      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if(!is_void(Src_offaxis))kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      if(!is_void(Src_azimuth))kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The keyword 'gbend' (Gravitational bending) applies only for loading
   a mirror deformation file. The function mt_gravity_bend is called.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         /*
          * Gravitational sag is introduced if requested. The phase is rotated like the optic
          * is rotated.
          */
         if( !is_void(gbend) ) mt_gravity_bend, gbend;
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=, title= )
/* DOCUMENT im = mt_qimage( z_value )
       or   mt_qimage, z_value

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one
   Keyword 'title'  Like for 'plot'

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
   Version 4.3   2012-06-01/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, gbend=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, gbend=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.

   Keywords:
        no_scatter=1  will disable scattering (but include Rcoef).
        no_deform=1   will disable mirror deformations.
        chat          puts info on terminal
        gbend         defines the amount of gravitational bending [mm]

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num),gbend=gbend;
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten= )
/* DOCUMENT mt_reflplot, win=, atten=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to 0 (zero).
                atten only one curve for this many angles

   2007-10-31/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = 0;
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";
   if( Scatter_type == 1 ) {
      plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   } else { // must be of type 2
      plot, E_uniq, R_coefarr(1,), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   }

   if( na > 1 ) {
      for( i = 2; i <= na; i += atten ) {
         if( Scatter_type == 1 ) {
            oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
         } else {
            oplot, E_uniq, R_coefarr(i,);
         }
      }
   }
   str = swrite(format="Coating type : %i",Coating_scat);
   xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
   xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
   xyouts,0.2,0.77,str,device=1,align=0,charsize=1.1;

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic in the counterclock
                  direction when viewed from the X-ray source towards the aperture.
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform
   gbend       Amplitude of gravitational bending [mm] of optic

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation of the optic %.3f deg around z\n", roll;
   mt_roll, -roll*pi/180; // convert to radians, mt_roll rotates the photons
      // so the roll angle must have opposite sign

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,gbend=gbend,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back, remember the photon rotation is opposite the
   //    rotation of the optic
   mt_roll, roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   if( !is_void(Dphot) ) kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   if( !is_void(Src_offaxis)) kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   if( !is_void(Src_azimuth)) kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFILE%i",i);
         kwds_set,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) warn += 100000;
   if( numberof(Pix_focp) != 1 ) warn += 100000;

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else warn += 1000000;
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,device=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo;
// yxclude =

   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probability
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;
      evt.phs_index = i;

      // now determine the pixel

      w = where(Xpixlo < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1);
      w = where(Ypixlo < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      evt.dety = Phs(sel(i)).E(2);
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      bkg.flag = 0;
      bkg.phs_index = -2;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.phs_index = -1;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.phs_index = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      sx_sum += Sx_photflux;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians. Please note that this is the opposite angle
   of the optic rotation.

   The roll angle is saved as an external variable: Roll_phot (in radians).

*/
{
   extern Phs, Roll_phot;

   Roll_phot = roll_angle;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'gbend', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, gbend=gbend, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/mbr_<random string>.ymac' and a yorick save
    file '<dir>/y_<random string>.ysav' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"mbr_"+ranstr(15)+".ymac";
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(gbend) ) comm += (",gbend="+ftoa(gbend,ndec=4));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if( !is_void(offaxis) ) kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      if( !is_void(azimuth) ) kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor-4.2.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius )
/* DOCUMENT mt_aperture_stop, z_position, open_radius

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( is_void(z_position) ) {
      z_position = Z_position_as;
   } else {
      Z_position_as = double(z_position);
   }
   if( is_void(open_radius) ) {
      open_radius = Open_radius_as;
   } else {
      Open_radius_as = double(open_radius);
   }
   if( is_void(Phs) ) return; // If no photons then only set externals
   w0 = where( Phs.status == 0 );
   if( numberof(w0) == 0 ) return; // No good photons, simply skip this step

   mt_propagate, Z_position_as;
   eq_nocopy, cE, Phs.E;
   r = sqrt(cE(1,w0)^2 + cE(2,w0)^2);
   w = where( r > Open_radius_as );
   if( numberof(w) ) Phs(w0(w)).status = 201;
   mt_propagate, 0.0; // set photon positions (back) to focal plane
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}

/* Function mt_gravity_bend */

func mt_gravity_bend( gbend, mlength= )
/* DOCUMENT mt_gravity_bend, gbend, mlength=

    Make mirror deformation from circular bending of an X-ray telescope
    horizontally suspended in a gravitational field giving largest deviation
    in the middle.

    deform = -delta_r = -(gbend/mlength^2) * (z + mlength) * (z - mlength)

    for mirror parts above the axis and with reversed sign below the axis.
    Sign reversal is taken care of by the sine function in azimuth.

        For 1-alpha   z c [ 0., mlength]
        For 3-alpha   z c [-mlength, 0.]

    The 'gbend' parameter is the distance (same unit as 'mlength', often mm)
    between the cord and the circular arc where it is at a maximum,
    i.e. right between the 1alpha and 3alpha mirror sections.

    Use dimensions from already existing deformation cube Mirror_deform_arr.

    The mirror length can be set with keyword 'mlength' (defaults to 225. mm)

    2012-06-04/NJW

*/
{
   extern Mirror_deform_arr, Module_num, Roll_phot;

   //   Module_num is either 1 (U or 1-alpha section) or 2 (L or 3-alpha section)

   if( is_void(mlength) ) mlength = 225.; // mm - mirror length

   dms = dimsof( Mirror_deform_arr );

   naz = dms(2);
   nz =  dms(3);
   nlayers = dms(4);

   // Ensure that the largest deviation is found for low indices
   // for the 1-alpha section

   if( Module_num == 1 ) {

      z = span(0.,mlength,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   } else {

   // Ensure that the largest deviation is found for high indices
   // for the 3-alpha section

      z = span(-mlength,0.,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   }

}
%FILE% mt_rayor-4.4.1.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=
  > mt_gravity_bend,gbend,mlength=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_eff_area_quick,earr=,samp=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.4.1, 2012-07-13/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.4.1"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files
   4.4.0  2012-06-04 Added function mt_gravity_bend

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
   long phs_index;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      dol = src_spec_file+"+1";
      hdr = headfits(dol);
      energ_lo = rdfitscol( dol, "energ_lo" );
      energ_hi = rdfitscol( dol, "energ_hi" );
      photflux = rdfitscol( dol, "photflux" );
      // evaluate the photon density (include conversion to /mm2)
      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if(!is_void(Src_offaxis))kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      if(!is_void(Src_azimuth))kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The keyword 'gbend' (Gravitational bending) applies only for loading
   a mirror deformation file. The function mt_gravity_bend is called.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         /*
          * Gravitational sag is introduced if requested. The phase is rotated like the optic
          * is rotated.
          */
         if( !is_void(gbend) ) mt_gravity_bend, gbend;
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=, title= )
/* DOCUMENT im = mt_qimage( z_value )
       or   mt_qimage, z_value

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one
   Keyword 'title'  Like for 'plot'

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
   Version 4.3   2012-06-01/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, gbend=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, gbend=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.

   Keywords:
        no_scatter=1  will disable scattering (but include Rcoef).
        no_deform=1   will disable mirror deformations.
        chat          puts info on terminal
        gbend         defines the amount of gravitational bending [mm]

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num),gbend=gbend;
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten= )
/* DOCUMENT mt_reflplot, win=, atten=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to 0 (zero).
                atten only one curve for this many angles

   2007-10-31/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = 0;
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";
   if( Scatter_type == 1 ) {
      plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   } else { // must be of type 2
      plot, E_uniq, R_coefarr(1,), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   }

   if( na > 1 ) {
      for( i = 2; i <= na; i += atten ) {
         if( Scatter_type == 1 ) {
            oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
         } else {
            oplot, E_uniq, R_coefarr(i,);
         }
      }
   }
   str = swrite(format="Coating type : %i",Coating_scat);
   xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
   xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
   xyouts,0.2,0.77,str,device=1,align=0,charsize=1.1;

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic in the counterclock
                  direction when viewed from the X-ray source towards the aperture.
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform
   gbend       Amplitude of gravitational bending [mm] of optic

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation of the optic %.3f deg around z\n", roll;
   mt_roll, -roll*pi/180; // convert to radians, mt_roll rotates the photons
      // so the roll angle must have opposite sign

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,gbend=gbend,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back, remember the photon rotation is opposite the
   //    rotation of the optic
   mt_roll, roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   if( !is_void(Dphot) ) kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   if( !is_void(Src_offaxis)) kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   if( !is_void(Src_azimuth)) kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFILE%i",i);
         kwds_set,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) warn += 100000;
   if( numberof(Pix_focp) != 1 ) warn += 100000;

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else warn += 1000000;
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,device=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo;
// yxclude =

   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probability
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;
      evt.phs_index = i;

      // now determine the pixel

      w = where(Xpixlo < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1);
      w = where(Ypixlo < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      evt.dety = Phs(sel(i)).E(2);
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      bkg.flag = 0;
      bkg.phs_index = -2;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.phs_index = -1;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.phs_index = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      sx_sum += Sx_photflux;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians. Please note that this is the opposite angle
   of the optic rotation.

   The roll angle is saved as an external variable: Roll_phot (in radians).

*/
{
   extern Phs, Roll_phot;

   Roll_phot = roll_angle;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'gbend', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, gbend=gbend, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/mbr_<random string>.ymac' and a yorick save
    file '<dir>/y_<random string>.ysav' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"mbr_"+ranstr(15)+".ymac";
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(gbend) ) comm += (",gbend="+ftoa(gbend,ndec=4));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if( !is_void(offaxis) ) kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      if( !is_void(azimuth) ) kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius )
/* DOCUMENT mt_aperture_stop, z_position, open_radius

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( is_void(z_position) ) {
      z_position = Z_position_as;
   } else {
      Z_position_as = double(z_position);
   }
   if( is_void(open_radius) ) {
      open_radius = Open_radius_as;
   } else {
      Open_radius_as = double(open_radius);
   }
   if( is_void(Phs) ) return; // If no photons then only set externals
   w0 = where( Phs.status == 0 );
   if( numberof(w0) == 0 ) return; // No good photons, simply skip this step

   mt_propagate, Z_position_as;
   eq_nocopy, cE, Phs.E;
   r = sqrt(cE(1,w0)^2 + cE(2,w0)^2);
   w = where( r > Open_radius_as );
   if( numberof(w) ) Phs(w0(w)).status = 201;
   mt_propagate, 0.0; // set photon positions (back) to focal plane
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}

/* Function mt_gravity_bend */

func mt_gravity_bend( gbend, mlength= )
/* DOCUMENT mt_gravity_bend, gbend, mlength=

    Make mirror deformation from circular bending of an X-ray telescope
    horizontally suspended in a gravitational field giving largest deviation
    in the middle.

    deform = -delta_r = -(gbend/mlength^2) * (z + mlength) * (z - mlength)

    for mirror parts above the axis and with reversed sign below the axis.
    Sign reversal is taken care of by the sine function in azimuth.

        For 1-alpha   z c [ 0., mlength]
        For 3-alpha   z c [-mlength, 0.]

    The 'gbend' parameter is the distance (same unit as 'mlength', often mm)
    between the cord and the circular arc where it is at a maximum,
    i.e. right between the 1alpha and 3alpha mirror sections.

    Use dimensions from already existing deformation cube Mirror_deform_arr.

    The mirror length can be set with keyword 'mlength' (defaults to 225. mm)

    2012-06-04/NJW

*/
{
   extern Mirror_deform_arr, Module_num, Roll_phot;

   //   Module_num is either 1 (U or 1-alpha section) or 2 (L or 3-alpha section)

   if( is_void(mlength) ) mlength = 225.; // mm - mirror length

   dms = dimsof( Mirror_deform_arr );

   naz = dms(2);
   nz =  dms(3);
   nlayers = dms(4);

   // Ensure that the largest deviation is found for low indices
   // for the 1-alpha section

   if( Module_num == 1 ) {

      z = span(0.,mlength,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   } else {

   // Ensure that the largest deviation is found for high indices
   // for the 3-alpha section

      z = span(-mlength,0.,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   }

}
%FILE% mt_rayor-4.4.2.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=
  > mt_gravity_bend,gbend,mlength=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_eff_area_quick,earr=,samp=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.4.2, 2012-07-13/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.4.2"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files
   4.4.0  2012-06-04 Added function mt_gravity_bend
   4.4.1  2012-07-04 kkkk
   4.4.2  2012-09-14 Introduced dead pixel map in the detector description
                     and translation.

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
   long phs_index;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      dol = src_spec_file+"+1";
      hdr = headfits(dol);
      energ_lo = rdfitscol( dol, "energ_lo" );
      energ_hi = rdfitscol( dol, "energ_hi" );
      photflux = rdfitscol( dol, "photflux" );
      // evaluate the photon density (include conversion to /mm2)
      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if(!is_void(Src_offaxis))kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      if(!is_void(Src_azimuth))kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"SAMPLING", samp, "One out of this number of photons is used";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The keyword 'gbend' (Gravitational bending) applies only for loading
   a mirror deformation file. The function mt_gravity_bend is called.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
   Updated to version 4.4.2   2012-09-14/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type, Dead_pixel_map;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         /*
          * Gravitational sag is introduced if requested. The phase is rotated like the optic
          * is rotated.
          */
         if( !is_void(gbend) ) mt_gravity_bend, gbend;
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      // Load the dead pixel map if found else set to 'all active'
      //    A pixel value of 1 (one) signals that the pixel is dead
      //    A pixel value of 0 (zero) signals that the pixel is active

      dol_dead_pixel_map = comgets(detfile,"dead_pixel_map");
      if( is_void(dol_dead_pixel_map)) {
         Dead_pixel_map = array(short,Num_pixels1,Num_pixels2);
      } else {
         local file_dead_pixel_map, extno_dpm;
         get_exten_no, dol_dead_pixel_map, file_dead_pixel_map, extno_dpm;
         if( !file_test(file_dead_pixel_map) ) error,"MT_LOAD did not find "+file_dead_pixel_map;
         Dead_pixel_map = readfits(dol_dead_pixel_map);
         dms = dimsof(Dead_pixel_map);
         if( Num_pixels1 != dms(2) || Num_pixels2 != dms(3) ) error,"MT_LOAD inconsistency in dead pixel map dimensions";
      }

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=, title= )
/* DOCUMENT im = mt_qimage( z_value )
       or   mt_qimage, z_value

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one
   Keyword 'title'  Like for 'plot'

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
   Version 4.3   2012-06-01/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, gbend=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, gbend=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.

   Keywords:
        no_scatter=1  will disable scattering (but include Rcoef).
        no_deform=1   will disable mirror deformations.
        chat          puts info on terminal
        gbend         defines the amount of gravitational bending [mm]

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num),gbend=gbend;
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten= )
/* DOCUMENT mt_reflplot, win=, atten=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to 0 (zero).
                atten only one curve for this many angles

   2007-10-31/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = 0;
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";
   if( Scatter_type == 1 ) {
      plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   } else { // must be of type 2
      plot, E_uniq, R_coefarr(1,), \
         title=esc_uscore(Scatter_file), \
         xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
   }

   if( na > 1 ) {
      for( i = 2; i <= na; i += atten ) {
         if( Scatter_type == 1 ) {
            oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
         } else {
            oplot, E_uniq, R_coefarr(i,);
         }
      }
   }
   str = swrite(format="Coating type : %i",Coating_scat);
   xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
   xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
   str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
        Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
   xyouts,0.2,0.77,str,device=1,align=0,charsize=1.1;

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic in the counterclock
                  direction when viewed from the X-ray source towards the aperture.
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform
   gbend       Amplitude of gravitational bending [mm] of optic

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation of the optic %.3f deg around z\n", roll;
   mt_roll, -roll*pi/180; // convert to radians, mt_roll rotates the photons
      // so the roll angle must have opposite sign

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,gbend=gbend,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back, remember the photon rotation is opposite the
   //    rotation of the optic
   mt_roll, roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   if( !is_void(Dphot) ) kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   if( !is_void(Src_offaxis)) kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   if( !is_void(Src_azimuth)) kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFILE%i",i);
         kwds_set,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
   Version 4.4.2 2012-09-14/NJW with dead pixel detector map
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Data in mirror deformation file are not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) {
      write,"Bad definition of 'Dim_focp'";
      warn += 100000;
   }
   if( numberof(Pix_focp) != 1 ) {
      write,"Bad definition of 'Pix_focp'";
      warn += 100000;
   }

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else {
         warn += 1000000;
         write,"Did not find detector_descr_file: "+Detector_descr_file;
      }
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,device=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( offset=, cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, offset=, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: offset  - a 2 element array [dx,dy] in mm that shifts the
                       optical axis relative to the detector center.
             cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo, \
          Det_offset, Dead_pixel_map;
// yxclude =

   if( is_void(offset) ) {
      Det_offset = [0.,0.];
   } else {
      if( numberof(offset) != 2 ) error,"Error in offset for mt_detector";
      Det_offset = double(offset);
   }
   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probability
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;
      evt.phs_index = i;

      // now determine the pixel

      w = where(Xpixlo - Det_offset(1) < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1) + Det_offset(1); // relative to detector center
      w = where(Ypixlo - Det_offset(2) < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      if( Dead_pixel_map(evt.rawx,evt.rawy) ) continue; // skip if landed on a dead pixel
      evt.dety = Phs(sel(i)).E(2) + Det_offset(2); // relative to detector center
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      dead = where( Dead_pixel_map );
      if( numberof(dead) ) {
         idx = (bkg.rawy - 1) * Num_pixels1 + bkg.rawx;
         idx = whereany( idx, dead );
         bkg = rem_elem( bkg, idx );
         nbkg = numberof( bkg );
      }
      bkg.flag = 0;
      bkg.phs_index = -2;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length, Det_offset;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2. + Det_offset(1)/Pixel_size1,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2. + Det_offset(2)/Pixel_size2,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   if( am_subroutine() ) {
      disp, im;
   } else return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.phs_index = -1;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.phs_index = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      sx_sum += Sx_photflux;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians. Please note that this is the opposite angle
   of the optic rotation.

   The roll angle is saved as an external variable: Roll_phot (in radians).

*/
{
   extern Phs, Roll_phot;

   Roll_phot = roll_angle;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'gbend', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, gbend=gbend, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/mbr_<random string>.ymac' and a yorick save
    file '<dir>/y_<random string>.ysav' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"mbr_"+ranstr(15)+".ymac";
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(gbend) ) comm += (",gbend="+ftoa(gbend,ndec=4));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if( !is_void(offaxis) ) kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      if( !is_void(azimuth) ) kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius )
/* DOCUMENT mt_aperture_stop, z_position, open_radius

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( is_void(z_position) ) {
      z_position = Z_position_as;
   } else {
      Z_position_as = double(z_position);
   }
   if( is_void(open_radius) ) {
      open_radius = Open_radius_as;
   } else {
      Open_radius_as = double(open_radius);
   }
   if( is_void(Phs) ) return; // If no photons then only set externals
   w0 = where( Phs.status == 0 );
   if( numberof(w0) == 0 ) return; // No good photons, simply skip this step

   mt_propagate, Z_position_as;
   eq_nocopy, cE, Phs.E;
   r = sqrt(cE(1,w0)^2 + cE(2,w0)^2);
   w = where( r > Open_radius_as );
   if( numberof(w) ) Phs(w0(w)).status = 201;
   mt_propagate, 0.0; // set photon positions (back) to focal plane
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}

/* Function mt_gravity_bend */

func mt_gravity_bend( gbend, mlength= )
/* DOCUMENT mt_gravity_bend, gbend, mlength=

    Make mirror deformation from circular bending of an X-ray telescope
    horizontally suspended in a gravitational field giving largest deviation
    in the middle.

    deform = -delta_r = -(gbend/mlength^2) * (z + mlength) * (z - mlength)

    for mirror parts above the axis and with reversed sign below the axis.
    Sign reversal is taken care of by the sine function in azimuth.

        For 1-alpha   z c [ 0., mlength]
        For 3-alpha   z c [-mlength, 0.]

    The 'gbend' parameter is the distance (same unit as 'mlength', often mm)
    between the cord and the circular arc where it is at a maximum,
    i.e. right between the 1alpha and 3alpha mirror sections.

    Use dimensions from already existing deformation cube Mirror_deform_arr.

    The mirror length can be set with keyword 'mlength' (defaults to 225. mm)

    2012-06-04/NJW

*/
{
   extern Mirror_deform_arr, Module_num, Roll_phot;

   //   Module_num is either 1 (U or 1-alpha section) or 2 (L or 3-alpha section)

   if( is_void(mlength) ) mlength = 225.; // mm - mirror length

   dms = dimsof( Mirror_deform_arr );

   naz = dms(2);
   nz =  dms(3);
   nlayers = dms(4);

   // Ensure that the largest deviation is found for low indices
   // for the 1-alpha section

   if( Module_num == 1 ) {

      z = span(0.,mlength,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   } else {

   // Ensure that the largest deviation is found for high indices
   // for the 3-alpha section

      z = span(-mlength,0.,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   }

}
%FILE% mt_rayor-4.4.3.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=
  > mt_gravity_bend,gbend,mlength=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_bg_run_eff_area,
  > mt_eff_area_quick,earr=,outfile=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,offset=, cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.4.3, 2012-10-03/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.4.3"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files
   4.4.0  2012-06-04 Added function mt_gravity_bend
   4.4.1  2012-07-04 kkkk
   4.4.2  2012-09-14 Introduced dead pixel map in the detector description
                     and translation.

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
   long phs_index;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      dol = src_spec_file+"+1";
      hdr = headfits(dol);
      energ_lo = rdfitscol( dol, "energ_lo" );
      energ_hi = rdfitscol( dol, "energ_hi" );
      photflux = rdfitscol( dol, "photflux" );
      // evaluate the photon density (include conversion to /mm2)
      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if(!is_void(Src_offaxis))kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      if(!is_void(Src_azimuth))kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"SAMPLING", samp, "One out of this number of photons is used";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The keyword 'gbend' (Gravitational bending) applies only for loading
   a mirror deformation file. The function mt_gravity_bend is called.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
   Updated to version 4.4.2   2012-09-14/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type, Dead_pixel_map;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         /*
          * Gravitational sag is introduced if requested. The phase is rotated like the optic
          * is rotated.
          */
         if( !is_void(gbend) ) mt_gravity_bend, gbend;
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      // Load the dead pixel map if found else set to 'all active'
      //    A pixel value of 1 (one) signals that the pixel is dead
      //    A pixel value of 0 (zero) signals that the pixel is active

      dol_dead_pixel_map = comgets(detfile,"dead_pixel_map");
      if( is_void(dol_dead_pixel_map)) {
         Dead_pixel_map = array(short,Num_pixels1,Num_pixels2);
      } else {
         local file_dead_pixel_map, extno_dpm;
         get_exten_no, dol_dead_pixel_map, file_dead_pixel_map, extno_dpm;
         if( !file_test(file_dead_pixel_map) ) error,"MT_LOAD did not find "+file_dead_pixel_map;
         Dead_pixel_map = readfits(dol_dead_pixel_map);
         dms = dimsof(Dead_pixel_map);
         if( Num_pixels1 != dms(2) || Num_pixels2 != dms(3) ) error,"MT_LOAD inconsistency in dead pixel map dimensions";
      }

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=, title= )
/* DOCUMENT im = mt_qimage( z_value )
       or   mt_qimage, z_value

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one
   Keyword 'title'  Like for 'plot'

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
   Version 4.3   2012-06-01/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, gbend=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, gbend=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.

   Keywords:
        no_scatter=1  will disable scattering (but include Rcoef).
        no_deform=1   will disable mirror deformations.
        chat          puts info on terminal
        gbend         defines the amount of gravitational bending [mm]

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num),gbend=gbend;
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten=, angle=, unit= )
/* DOCUMENT mt_reflplot, win=, atten=, angle=, unit=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to current window.
                atten only one curve for this many angles
                angle Plot only for this angle (overrides 'atten')
                unit  Unit of 'angle'. Can be "deg", "rad" (default), "mrad",
                                       "mdeg", "arcsec", or "arcmin"

   2007-10-31/NJW, updated 2012-10-29/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = window();
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";

   if( is_void(angle) ) {

      if( Scatter_type == 1 ) {
         plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
            title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      } else { // must be of type 2
         plot, E_uniq, R_coefarr(1,), \
            title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      }
   
      if( na > 1 ) {
         for( i = 2; i <= na; i += atten ) {
            if( Scatter_type == 1 ) {
               oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
            } else {
               oplot, E_uniq, R_coefarr(i,);
            }
         }
      }
      str = swrite(format="Coating type : %i",Coating_scat);
      xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
      str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
           Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
      xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
      str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
           Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
      xyouts,0.2,0.77,str,device=1,align=0,charsize=1.1;

   } else {

      if( typeof(unit) == "string" ) {
         if( unit == "deg" ) angle *= pi/180.;
         if( unit == "mrad" ) angle /= 1000.;
         if( unit == "mdeg" ) angle *= pi/180000.;
         if( unit == "arcsec" ) angle *= pi/(180.*3600.);
         if( unit == "arcmin" ) angle *= pi/(180.*60.);
      }
      ne = numberof(E_uniq);
      r = array(double,ne);
      for(i = 1; i <= ne; i++ ) r(i) = mt_get_rcoef(E_uniq(i),angle);
      plot, E_uniq, r, title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      str = swrite(format="Coating type : %i",Coating_scat);
      xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
      str = swrite(format="Angle: %9.2e rad = %8.1f mdeg", \
           angle, angle*(180/pi)*1000.);
      xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
   }

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic in the counterclock
                  direction when viewed from the X-ray source towards the aperture.
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform
   gbend       Amplitude of gravitational bending [mm] of optic

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation of the optic %.3f deg around z\n", roll;
   mt_roll, -roll*pi/180; // convert to radians, mt_roll rotates the photons
      // so the roll angle must have opposite sign

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,gbend=gbend,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back, remember the photon rotation is opposite the
   //    rotation of the optic
   mt_roll, roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   if( !is_void(Dphot) ) kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   if( !is_void(Src_offaxis)) kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   if( !is_void(Src_azimuth)) kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFL%i",i);
         kwds_setlongstr,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
   Version 4.4.2 2012-09-14/NJW with dead pixel detector map
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Data in mirror deformation file are not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) {
      write,"Bad definition of 'Dim_focp'";
      warn += 100000;
   }
   if( numberof(Pix_focp) != 1 ) {
      write,"Bad definition of 'Pix_focp'";
      warn += 100000;
   }

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else {
         warn += 1000000;
         write,"Did not find detector_descr_file: "+Detector_descr_file;
      }
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,device=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( offset=, cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, offset=, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: offset  - a 2 element array [dx,dy] in mm that shifts the
                       optical axis relative to the detector center.
             cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo, \
          Det_offset, Dead_pixel_map;
// yxclude =

   if( is_void(offset) ) {
      Det_offset = [0.,0.];
   } else {
      if( numberof(offset) != 2 ) error,"Error in offset for mt_detector";
      Det_offset = double(offset);
   }
   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probability
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;
      evt.phs_index = i;

      // now determine the pixel

      w = where(Xpixlo - Det_offset(1) < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1) + Det_offset(1); // relative to detector center
      w = where(Ypixlo - Det_offset(2) < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      if( Dead_pixel_map(evt.rawx,evt.rawy) ) continue; // skip if landed on a dead pixel
      evt.dety = Phs(sel(i)).E(2) + Det_offset(2); // relative to detector center
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      dead = where( Dead_pixel_map );
      if( numberof(dead) ) {
         idx = (bkg.rawy - 1) * Num_pixels1 + bkg.rawx;
         idx = whereany( idx, dead );
         bkg = rem_elem( bkg, idx );
         nbkg = numberof( bkg );
      }
      bkg.flag = 0;
      bkg.phs_index = -2;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length, Det_offset;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2. + Det_offset(1)/Pixel_size1,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2. + Det_offset(2)/Pixel_size2,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   if( am_subroutine() ) {
      disp, im;
   } else return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.phs_index = -1;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.phs_index = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      sx_sum += Sx_photflux;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians. Please note that this is the opposite angle
   of the optic rotation.

   The roll angle is saved as an external variable: Roll_phot (in radians).

*/
{
   extern Phs, Roll_phot;

   Roll_phot = roll_angle;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'gbend', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, gbend=gbend, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/mbr_<random string>.ymac' and a yorick save
    file '<dir>/y_<random string>.ysav' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"mbr_"+ranstr(15)+".ymac";
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(gbend) ) comm += (",gbend="+ftoa(gbend,ndec=4));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if( !is_void(offaxis) ) kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      if( !is_void(azimuth) ) kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius, cen_dx=, cen_dy=, photfile=, undo=, chat= )
/* DOCUMENT mt_aperture_stop, z_position, open_radius, cen_dx=, cen_dy=, photfile=, undo=, chat=

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    Keywords
        cen_dx      [mm] displacement in x-direction
        cen_dy      [mm] displacement in y-direction
        photfile    Operate on the named photonfile
        undo        Undo the operation on the named photonfile
        chat        Display certain extra information

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as, Cen_dx_as, Cen_dy_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( !is_void(z_position) ) {
      Z_position_as = double(z_position);
   }
   if( !is_void(open_radius) ) {
      Open_radius_as = double(open_radius);
   }

   // Shifting center position in x/y directions

   if( is_void(cen_dx) ) {
      if( is_void(Cen_dx_as) ) Cen_dx_as = 0.0;
   } else {
      Cen_dx_as = double(cen_dx);
   }
   if( is_void(cen_dy) ) {
      if( is_void(Cen_dy_as) ) Cen_dy_as = 0.0;
   } else {
      Cen_dy_as = double(cen_dy);
   }

   if( is_void(photfile) ) {

      if( is_void(Phs) ) {
         write,"External 'Phs' does not exist, no action.";
         return; // If no photons then only set externals
      }
      w0 = where( Phs.status == 0 );
      if( numberof(w0) == 0 ) {
         if( chat ) write,"Found no status zero photons, no action.";
         return; // No good photons, simply skip this step
      }

      mt_propagate, Z_position_as;
      eq_nocopy, cE, Phs.E;
      r = sqrt((cE(1,w0)-Cen_dx_as)^2 + (cE(2,w0)-Cen_dy_as)^2);
      w = where( r > Open_radius_as );
      if( numberof(w) ) Phs(w0(w)).status = 201;
      mt_propagate, 0.0; // set photon positions (back) to focal plane

   } else {  // Operate on a photon file

      if( !file_test(photfile) ) {
         write,"Photfile: "+photfile+" was not found, no action.";
         return;
      }

      local hdr, nrows;
      ptr = rdfitsbin( photfile+"+1", hdr, nrows );
      colstat = fits_colnum(hdr,"status");
      status = *ptr(colstat);
      detx = *ptr(fits_colnum(hdr,"detx"));
      dety = *ptr(fits_colnum(hdr,"dety"));
      rayx = *ptr(fits_colnum(hdr,"rayx"));
      rayy = *ptr(fits_colnum(hdr,"rayy"));
      rayz = *ptr(fits_colnum(hdr,"rayz"));

      if( undo ) {
         nw = numberof( (w = where( status == 201 ) ) );
         if( nw == 0 ) {
            if( chat ) write,"Found no status 201 photons, no action.";
            return; // No 201 photons, simply skip this step
         }
         status(w) = 0; // Remove aperture stop signature
         if( chat ) write,"Updating "+photfile+" with "+itoa(nw)+" reversals to  status zero ...";
         fits_bintable_poke, photfile+"+1", 1, colstat, status;
         if( chat ) write,"done";

      } else {

         nw = numberof( (w = where( status == 0 ) ) );
         if( nw == 0 ) {
            if( chat ) write,"Found no status zero photons, no action.";
            return; // No good photons, simply skip this step
         }

         kount = 0;
         for( i = 1; i <= nw; i++ ) {
            p = _propa([detx(w(i)),dety(w(i)),0.],[rayx(w(i)),rayy(w(i)),rayz(w(i))],Z_position_as);
            if( sqrt( (p(1) - Cen_dx_as)^2 + (p(2) - Cen_dy_as)^2) > Open_radius_as ) {status(w(i)) = 201; kount++;}
         }
         if( kount ) {
            if( chat ) write,"Updating "+photfile+" with "+itoa(kount)+" times status 201 ...";
            fits_bintable_poke, photfile+"+1", 1, colstat, status;
            if( chat ) write,"done";
         } else {
            if( chat ) write,"No update of "+photfile+" was required.";
         }
      }
   }
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}

/* Function mt_gravity_bend */

func mt_gravity_bend( gbend, mlength= )
/* DOCUMENT mt_gravity_bend, gbend, mlength=

    Make mirror deformation from circular bending of an X-ray telescope
    horizontally suspended in a gravitational field giving largest deviation
    in the middle.

    deform = -delta_r = -(gbend/mlength^2) * (z + mlength) * (z - mlength)

    for mirror parts above the axis and with reversed sign below the axis.
    Sign reversal is taken care of by the sine function in azimuth.

        For 1-alpha   z c [ 0., mlength]
        For 3-alpha   z c [-mlength, 0.]

    The 'gbend' parameter is the distance (same unit as 'mlength', often mm)
    between the cord and the circular arc where it is at a maximum,
    i.e. right between the 1alpha and 3alpha mirror sections.

    Use dimensions from already existing deformation cube Mirror_deform_arr.

    The mirror length can be set with keyword 'mlength' (defaults to 225. mm)

    2012-06-04/NJW

*/
{
   extern Mirror_deform_arr, Module_num, Roll_phot;

   //   Module_num is either 1 (U or 1-alpha section) or 2 (L or 3-alpha section)

   if( is_void(mlength) ) mlength = 225.; // mm - mirror length

   dms = dimsof( Mirror_deform_arr );

   naz = dms(2);
   nz =  dms(3);
   nlayers = dms(4);

   // Ensure that the largest deviation is found for low indices
   // for the 1-alpha section

   if( Module_num == 1 ) {

      z = span(0.,mlength,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   } else {

   // Ensure that the largest deviation is found for high indices
   // for the 3-alpha section

      z = span(-mlength,0.,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   }

}
%FILE% mt_rayor.4.4.4.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=
  > mt_gravity_bend,gbend,mlength=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_bg_run_eff_area,
  > mt_eff_area_quick,earr=,outfile=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,offset=, cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.4.4, 2012-11-28/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.4.4"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files
   4.4.0  2012-06-04 Added function mt_gravity_bend
   4.4.1  2012-07-04 kkkk
   4.4.2  2012-09-14 Introduced dead pixel map in the detector description
                     and translation.

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
   long phs_index;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      dol = src_spec_file+"+1";
      hdr = headfits(dol);
      energ_lo = rdfitscol( dol, "energ_lo" );
      energ_hi = rdfitscol( dol, "energ_hi" );
      photflux = rdfitscol( dol, "photflux" );
      // evaluate the photon density (include conversion to /mm2)
      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if(!is_void(Src_offaxis))kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      if(!is_void(Src_azimuth))kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"SAMPLING", samp, "One out of this number of photons is used";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The keyword 'gbend' (Gravitational bending) applies only for loading
   a mirror deformation file. The function mt_gravity_bend is called.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
   Updated to version 4.4.2   2012-09-14/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type, Dead_pixel_map;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         /*
          * Gravitational sag is introduced if requested. The phase is rotated like the optic
          * is rotated.
          */
         if( !is_void(gbend) ) mt_gravity_bend, gbend;
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      // Load the dead pixel map if found else set to 'all active'
      //    A pixel value of 1 (one) signals that the pixel is dead
      //    A pixel value of 0 (zero) signals that the pixel is active

      dol_dead_pixel_map = comgets(detfile,"dead_pixel_map");
      if( is_void(dol_dead_pixel_map)) {
         Dead_pixel_map = array(short,Num_pixels1,Num_pixels2);
      } else {
         local file_dead_pixel_map, extno_dpm;
         get_exten_no, dol_dead_pixel_map, file_dead_pixel_map, extno_dpm;
         if( !file_test(file_dead_pixel_map) ) error,"MT_LOAD did not find "+file_dead_pixel_map;
         Dead_pixel_map = readfits(dol_dead_pixel_map);
         dms = dimsof(Dead_pixel_map);
         if( Num_pixels1 != dms(2) || Num_pixels2 != dms(3) ) error,"MT_LOAD inconsistency in dead pixel map dimensions";
      }

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=, title= )
/* DOCUMENT im = mt_qimage( z_value )
       or   mt_qimage, z_value

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one
   Keyword 'title'  Like for 'plot'

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
   Version 4.3   2012-06-01/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, gbend=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, gbend=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.

   Keywords:
        no_scatter=1  will disable scattering (but include Rcoef).
        no_deform=1   will disable mirror deformations.
        chat          puts info on terminal
        gbend         defines the amount of gravitational bending [mm]

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num),gbend=gbend;
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten=, angle=, unit= )
/* DOCUMENT mt_reflplot, win=, atten=, angle=, unit=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to current window.
                atten only one curve for this many angles
                angle Plot only for this angle (overrides 'atten')
                unit  Unit of 'angle'. Can be "deg", "rad" (default), "mrad",
                                       "mdeg", "arcsec", or "arcmin"

   2007-10-31/NJW, updated 2012-10-29/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = window();
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";

   if( is_void(angle) ) {

      if( Scatter_type == 1 ) {
         plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
            title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      } else { // must be of type 2
         plot, E_uniq, R_coefarr(1,), \
            title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      }
   
      if( na > 1 ) {
         for( i = 2; i <= na; i += atten ) {
            if( Scatter_type == 1 ) {
               oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
            } else {
               oplot, E_uniq, R_coefarr(i,);
            }
         }
      }
      str = swrite(format="Coating type : %i",Coating_scat);
      xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
      str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
           Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
      xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
      str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
           Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
      xyouts,0.2,0.77,str,device=1,align=0,charsize=1.1;

   } else {

      if( typeof(unit) == "string" ) {
         if( unit == "deg" ) angle *= pi/180.;
         if( unit == "mrad" ) angle /= 1000.;
         if( unit == "mdeg" ) angle *= pi/180000.;
         if( unit == "arcsec" ) angle *= pi/(180.*3600.);
         if( unit == "arcmin" ) angle *= pi/(180.*60.);
      }
      ne = numberof(E_uniq);
      r = array(double,ne);
      for(i = 1; i <= ne; i++ ) r(i) = mt_get_rcoef(E_uniq(i),angle);
      plot, E_uniq, r, title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      str = swrite(format="Coating type : %i",Coating_scat);
      xyouts,0.2,0.83,str,device=1,align=0,charsize=1.1;
      str = swrite(format="Angle: %9.2e rad = %8.1f mdeg", \
           angle, angle*(180/pi)*1000.);
      xyouts,0.2,0.80,str,device=1,align=0,charsize=1.1;
   }

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic in the counterclock
                  direction when viewed from the X-ray source towards the aperture.
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform
   gbend       Amplitude of gravitational bending [mm] of optic

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation of the optic %.3f deg around z\n", roll;
   mt_roll, -roll*pi/180; // convert to radians, mt_roll rotates the photons
      // so the roll angle must have opposite sign

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,gbend=gbend,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back, remember the photon rotation is opposite the
   //    rotation of the optic
   mt_roll, roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   if( !is_void(Dphot) ) kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   if( !is_void(Src_offaxis)) kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   if( !is_void(Src_azimuth)) kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFL%i",i);
         kwds_setlongstr,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
   Version 4.4.2 2012-09-14/NJW with dead pixel detector map
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Data in mirror deformation file are not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) {
      write,"Bad definition of 'Dim_focp'";
      warn += 100000;
   }
   if( numberof(Pix_focp) != 1 ) {
      write,"Bad definition of 'Pix_focp'";
      warn += 100000;
   }

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else {
         warn += 1000000;
         write,"Did not find detector_descr_file: "+Detector_descr_file;
      }
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,device=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( offset=, cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, offset=, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: offset  - a 2 element array [dx,dy] in mm that shifts the
                       optical axis relative to the detector center.
             cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo, \
          Det_offset, Dead_pixel_map;
// yxclude =

   if( is_void(offset) ) {
      Det_offset = [0.,0.];
   } else {
      if( numberof(offset) != 2 ) error,"Error in offset for mt_detector";
      Det_offset = double(offset);
   }
   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probability
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;
      evt.phs_index = i;

      // now determine the pixel

      w = where(Xpixlo - Det_offset(1) < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1) + Det_offset(1); // relative to detector center
      w = where(Ypixlo - Det_offset(2) < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      if( Dead_pixel_map(evt.rawx,evt.rawy) ) continue; // skip if landed on a dead pixel
      evt.dety = Phs(sel(i)).E(2) + Det_offset(2); // relative to detector center
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      dead = where( Dead_pixel_map );
      if( numberof(dead) ) {
         idx = (bkg.rawy - 1) * Num_pixels1 + bkg.rawx;
         idx = whereany( idx, dead );
         bkg = rem_elem( bkg, idx );
         nbkg = numberof( bkg );
      }
      bkg.flag = 0;
      bkg.phs_index = -2;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length, Det_offset;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2. + Det_offset(1)/Pixel_size1,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2. + Det_offset(2)/Pixel_size2,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   if( am_subroutine() ) {
      disp, im;
   } else return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.phs_index = -1;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.phs_index = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      sx_sum += Sx_photflux;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians. Please note that this is the opposite angle
   of the optic rotation.

   The roll angle is saved as an external variable: Roll_phot (in radians).

*/
{
   extern Phs, Roll_phot;

   Roll_phot = roll_angle;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'gbend', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, gbend=gbend, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/ymbr_<random string>.ymbr' and a yorick save
    file '<dir>/ytmp_<random string>.ytmp' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"ymbr_"+ranstr(15)+".ymbr";
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(gbend) ) comm += (",gbend="+ftoa(gbend,ndec=4));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if( !is_void(offaxis) ) kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      if( !is_void(azimuth) ) kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius, cen_dx=, cen_dy=, photfile=, undo=, chat= )
/* DOCUMENT mt_aperture_stop, z_position, open_radius, cen_dx=, cen_dy=, photfile=, undo=, chat=

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    Keywords
        cen_dx      [mm] displacement in x-direction
        cen_dy      [mm] displacement in y-direction
        photfile    Operate on the named photonfile
        undo        Undo the operation on the named photonfile
        chat        Display certain extra information

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as, Cen_dx_as, Cen_dy_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( !is_void(z_position) ) {
      Z_position_as = double(z_position);
   }
   if( !is_void(open_radius) ) {
      Open_radius_as = double(open_radius);
   }

   // Shifting center position in x/y directions

   if( is_void(cen_dx) ) {
      if( is_void(Cen_dx_as) ) Cen_dx_as = 0.0;
   } else {
      Cen_dx_as = double(cen_dx);
   }
   if( is_void(cen_dy) ) {
      if( is_void(Cen_dy_as) ) Cen_dy_as = 0.0;
   } else {
      Cen_dy_as = double(cen_dy);
   }

   if( is_void(photfile) ) {

      if( is_void(Phs) ) {
         write,"External 'Phs' does not exist, no action.";
         return; // If no photons then only set externals
      }
      w0 = where( Phs.status == 0 );
      if( numberof(w0) == 0 ) {
         if( chat ) write,"Found no status zero photons, no action.";
         return; // No good photons, simply skip this step
      }

      mt_propagate, Z_position_as;
      eq_nocopy, cE, Phs.E;
      r = sqrt((cE(1,w0)-Cen_dx_as)^2 + (cE(2,w0)-Cen_dy_as)^2);
      w = where( r > Open_radius_as );
      if( numberof(w) ) Phs(w0(w)).status = 201;
      mt_propagate, 0.0; // set photon positions (back) to focal plane

   } else {  // Operate on a photon file

      if( !file_test(photfile) ) {
         write,"Photfile: "+photfile+" was not found, no action.";
         return;
      }

      local hdr, nrows;
      ptr = rdfitsbin( photfile+"+1", hdr, nrows );
      colstat = fits_colnum(hdr,"status");
      status = *ptr(colstat);
      detx = *ptr(fits_colnum(hdr,"detx"));
      dety = *ptr(fits_colnum(hdr,"dety"));
      rayx = *ptr(fits_colnum(hdr,"rayx"));
      rayy = *ptr(fits_colnum(hdr,"rayy"));
      rayz = *ptr(fits_colnum(hdr,"rayz"));

      if( undo ) {
         nw = numberof( (w = where( status == 201 ) ) );
         if( nw == 0 ) {
            if( chat ) write,"Found no status 201 photons, no action.";
            return; // No 201 photons, simply skip this step
         }
         status(w) = 0; // Remove aperture stop signature
         if( chat ) write,"Updating "+photfile+" with "+itoa(nw)+" reversals to  status zero ...";
         fits_bintable_poke, photfile+"+1", 1, colstat, status;
         if( chat ) write,"done";

      } else {

         nw = numberof( (w = where( status == 0 ) ) );
         if( nw == 0 ) {
            if( chat ) write,"Found no status zero photons, no action.";
            return; // No good photons, simply skip this step
         }

         kount = 0;
         for( i = 1; i <= nw; i++ ) {
            p = _propa([detx(w(i)),dety(w(i)),0.],[rayx(w(i)),rayy(w(i)),rayz(w(i))],Z_position_as);
            if( sqrt( (p(1) - Cen_dx_as)^2 + (p(2) - Cen_dy_as)^2) > Open_radius_as ) {status(w(i)) = 201; kount++;}
         }
         if( kount ) {
            if( chat ) write,"Updating "+photfile+" with "+itoa(kount)+" times status 201 ...";
            fits_bintable_poke, photfile+"+1", 1, colstat, status;
            if( chat ) write,"done";
         } else {
            if( chat ) write,"No update of "+photfile+" was required.";
         }
      }
   }
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}

/* Function mt_gravity_bend */

func mt_gravity_bend( gbend, mlength= )
/* DOCUMENT mt_gravity_bend, gbend, mlength=

    Make mirror deformation from circular bending of an X-ray telescope
    horizontally suspended in a gravitational field giving largest deviation
    in the middle.

    deform = -delta_r = -(gbend/mlength^2) * (z + mlength) * (z - mlength)

    for mirror parts above the axis and with reversed sign below the axis.
    Sign reversal is taken care of by the sine function in azimuth.

        For 1-alpha   z c [ 0., mlength]
        For 3-alpha   z c [-mlength, 0.]

    The 'gbend' parameter is the distance (same unit as 'mlength', often mm)
    between the cord and the circular arc where it is at a maximum,
    i.e. right between the 1alpha and 3alpha mirror sections.

    Use dimensions from already existing deformation cube Mirror_deform_arr.

    The mirror length can be set with keyword 'mlength' (defaults to 225. mm)

    2012-06-04/NJW

*/
{
   extern Mirror_deform_arr, Module_num, Roll_phot;

   //   Module_num is either 1 (U or 1-alpha section) or 2 (L or 3-alpha section)

   if( is_void(mlength) ) mlength = 225.; // mm - mirror length

   dms = dimsof( Mirror_deform_arr );

   naz = dms(2);
   nz =  dms(3);
   nlayers = dms(4);

   // Ensure that the largest deviation is found for low indices
   // for the 1-alpha section

   if( Module_num == 1 ) {

      z = span(0.,mlength,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   } else {

   // Ensure that the largest deviation is found for high indices
   // for the 3-alpha section

      z = span(-mlength,0.,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   }

}
%FILE% mt_rayor.i
/* Function mt_rayor */

extern mt_rayor;
/* DOCUMENT Overview of raytracing procedures

Setup system:
  > mt_setup_system,"system_xxx.scm"
  > mt_log[, logfilename]    Initiate logging

Generate optical module file:
      Independent or master module
  > mt_create_om_par1,filename="om_xxx.fits" (variable mirror lengths)
  > mt_create_om_par2,filename="om_xxx.fits"
  > mt_create_om_con2,filename="om_xxx.fits"
  > mt_create_om_con4,filename="om_xxx.fits"
      Secondary (slave) module
  > mt_create_om_hyp2,filename="om_xxx2.fits"
  > mt_create_om_con3,filename="om_xxx2.fits"
  > mt_create_om_con5,filename="om_xxx2.fits"
      Make new one from previously loaded one:
  > mt_upd_om (interactive)
  > mt_write_om, filename


Update coating information in module file:
  > mt_upd_om_coating,"mircoat_xxx.scm","om_xxx.fits"

Create fake scattering table files:
  > mt_fake_scatter_data,"scat_xyz.fits",fwhm=,angle_max=,ener_max=,coat=

Create scattering table files from ASCII tables:
  > mt_scatter_data_file (see separate help)
  > mt_scatter_data_file_type2 (see separate help)

Update or find scattering width or distribution in scattering table file:
  > mt_upd_scatter_width (see separate help)
  > mt_get_scatter_hpd(energy, angle_in) [keV, radians]
  > distri = mt_sel_scatter( energy, angle_in, >rcoef )

Create mirror deformation file
  > mt_mk_mdeform_file,"filename",mode,parameter,nz=,naz=
  > mt_gravity_bend,gbend,mlength=

Administrate blocking by spokes
  > mt_spoke_read, filename, pos=
  > mt_spoke_blocking, xyphot, pos=

Run a case
  > mt_run,energy,src_offaxis,src_azimuth,dphot=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,source_flux_file,src_offaxis,src_azimuth,renorm=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,sky_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=
      or
  > mt_run,labsource_definition_file,exposure=,no_scatter=,no_mdeform=,fraper=

  For several runs in the background (on Unix/linux systems with several CPUs)
  > mt_bg_run,energy,src_offaxis,src_azimuth,no_scatter,no_mdeform,dphot,ncases=,outfile=,dir=

Apply aperture stop
  > mt_aperture_stop, z_position, radius

Show setup and results
  > mt_qimage[,dz],size=
  > mt_mirdiag[,om_file],rr=,gl=
  > mt_rayplot, iphot, mod_num
  > mt_drayplot, iphot
  > mt_stat[, status][,w=]
  > mt_mirplot, mirror_number, azimuth
  > mt_photpr, iphot

Analyze result (finding HPD)
  > mt_analysis, phd, photon_file=, frac=, geom=

Save results
  > mt_save,mode="efps"

Calculate effective area
  > mt_eff_area_photons,earr=,samp=
  > mt_bg_run_eff_area,
  > mt_eff_area_quick,earr=,outfile=
  > mt_get_mirror_eff_factors

Plot reflectivity curves
  > mt_reflplot

Other utilities
  > mt_propagate, znew[, iphot]
  > mt_translate, [iphot, ], dx=, dy=
  > rcoef = mt_get_rcoef( energy, angle )
  > mt_substr_volume()

Observation simulator
  > mt_dxb2skydef
  > mt_skyima2skyspec
  > mt_skyspec2skydef

Observation simulation by detector
  > mt_detector,offset=, cont=
  > mt_det_add_bkg[, filename]
  > mt_det_image,outfile=,emin=,emax=,bkglvl=


Version 4.4.5, 2013-01-24/NJW

*/

/* Function mt_init */

/********************************************************
 *   An initilization macro for the MT_RAYOR package
 *   for raytracing a variety of X-ray telescopes
 *
 *   Naming rule:
 *   External variables shall have a name with the first letter
 *   as a capital (as the only one)
 *
 ***********************************************************/

Version = "4.4.5"; // Setting Version external variable
write,"Loading MT_RAYOR Version "+Version;

/**********************************************************
     Changes

   4.2.2  2012-03-01 Added n_dist_angles keyword in mt_fake_scatter_data
                     and made it to give extension name SCATTER_TYPE1
   4.2.1  2012-02-21 Added Exposure keyword in mt_save,mode="e" files
   4.4.0  2012-06-04 Added function mt_gravity_bend
   4.4.1  2012-07-04 kkkk
   4.4.2  2012-09-14 Introduced dead pixel map in the detector description
                     and translation.
   4.4.5  2013-01-24 Introduced storage of flux arrays in the extended source
                     simulation (using mem_storage.i package).

************************************************************/

randomize; // Start a different randomization every time

/*
 *  Include all required functions
 */

//  Define the struct to return the photons that result
//  from the raytracing process

struct s_Ray {
   double E(3);       // current position
   double R(3);       // current direction
   double angle_in1;  // ingoing grazing angle, first reflection
   double angle_out1; // outgoing grazing angle, first reflection
   double angle_in2;  // ingoing grazing angle, second reflection
   double angle_out2; // outgoing grazing angle, second reflection
   double rcoef;      // reflection coefficient
   double energy;     // photon energy
   long mirror;       // mirror number
   long status;       // status flag, zero for successful photon
   long bounce;       // bounce flag
// following are only for display purposes:
   double E1(3);      // position at entrance of first module
   double E2(3);      // position at entrance of second module
   double I1(3);      // position of first reflection
   double I2(3);      // position of second reflection
   double D1(3);      // direction before first reflection
   double D2(3);      // direction after first reflection
// for debugging:
   long flag;         // source number from mt_pre_def_photons
}

//  Define the struct to contain the events i.e. after
//  detection in a detector at the focal plane

struct s_MTEvent{
   int rawx;
   int rawy;
   float detx;
   float dety;
   int pha;
   float energy;
   int flag;
   long phs_index;
}

//  Define the struct to link the coating with the
//  appropriate scatter definition file

struct s_Coat_list {
   long id;
   string file;
}

Logflag = 0;

// Determine the OSTYPE
OSTYPE = get_env("OSTYPE");
if( strlen(OSTYPE) == 0 ) OSTYPE = "nonx";

/***************************************************************
 * External variables:
 *
 *    See list in PDB file : extvar.pdb
 *
 *
 *      Debugging
 *
 *   Logflag       :    Flag for saving logging information
 *   Logfilename   :    File to receive logging information
 ********************************************************************/

/* Function mt_log */

func mt_log( logfilename, logflag=, stop= )
/* DOCUMENT mt_log, logfilename, logflag=, stop=

   Initiates logging the session. Output in 'logfilename'
   Default name : mt_log_nnnn.txt
       where 'nnnn' is a serial number
   Keyword   stop   :  Stop logging to file
            logflag :  The higher the more output
                       (sets Logflag and mt_log_entry is only
                        operational if level <= Logflag)

   Version 1.7  2008-12-18/NJW
*/
{
   extern Logflag, Logfilename, Version;

  /*
   *  Every time an entry is made to the log file it is opened
   *  in append mode and closed afterwards so that the information
   *  is available even in case of a program crash
   */

   if( stop ) {
      Logflag = 0;
      write,format="Ended loggin%s\n","g";
      return;
   }

   // Define the name of the log file if none is given

   if( is_void(logfilename) ) {
      logfilename = get_next_filename("mt_log_????.txt");
   }
   Logfilename = logfilename;
   Logflag = 1; // Default value - minimal output to logfile
   if( !is_void(logflag) ) {
      // reject values <= 0
      if( logflag > 1 ) Logflag = logflag;
   }
   write,format="Logging in: %s\n", Logfilename;
   mt_log_entry,1,"MT_RAYOR-"+Version+" logfile started "+ndate(3), \
        swrite(format="level %i", Logflag), "";

}

/* Function mt_log_entry */

func mt_log_entry( level, str1, .. )
/* DOCUMENT mt_log_entry, level, str1, ..

   writes str1 and following strings to Logfilename
   in append mode if Logflag >= level

   Version 1.7   2008-12-18/NJW
*/
{
   extern Logflag, Logfilename;

   // Only output to log file if Logflag is true and
   // Logflag >= level

   if( !Logflag ) return;
   if( Logflag < level ) return;

   logstream = open( Logfilename, "a" );
   write,logstream,format="%s\n", str1;
   while( more_args() ) {
      text = next_arg();
      for( i = 1; i <= numberof(text); i++ ) {
         write,logstream,format="   %s\n", text(i);
      }
   }
   close, logstream;
}

/* Function mt_analysis */

func mt_analysis( phs, photon_file=, geom=, frac=, allbounce=, silent= )
/* DOCUMENT mt_analysis[,phs], photon_file=, geom=, frac=, allbounce=, silent=
        or  HPD (mm) = mt_analysis([,phs], photon_file=, geom=, frac=, allbounce=, \
                          silent= )

   Derives the HPD of the status==0  AND bounce==(2*Num_modules-1) photons
   and Rcoef accepted photons.
   If neither argument nor keyword 'photon_file' is given then the
   memory contents (array 'Phs') is used.

   If argument 'phs' is  given then data is taken from that.

   If keyword 'photon_file' is given (and no 'phs' argument )
   then this file is read and data used.
   If keyword 'geom' is set then the Rcoef will be set to one.

   Keyword 'frac' : The fraction of weighted counts inside the diameter
                    Defaults to 0.5 (HPD)
   Keyword 'allbounce' : Only Phs.status==0 condition is applied (i.e. ghosts are included)
   Keyword 'silent'    : Only active if called as a function

   The result is based on the current position of the photons
   (z = 0 in the focal plane). Calling 'mt_propagate' prior to
   'mt_analysis' can be used to investigate other z-planes.

   If called as a subroutine the result will be printed on the screen.

     2007-11-06/NJW, version 1.1
   Version 2.1   2010-04-16/NJW
*/
{

// ynclude = zaa
  extern  Focal_length,  Num_modules,   Phs,           Zfocus;
// yxclude =

   local cE;

   if( is_void(frac) ) frac = 0.5;

   if( !is_void(phs) ) {
      photon_file = []; // overriding keyword
   } else {
      eq_nocopy, phs, Phs;
   }
   if( silent && am_subroutine() ) silent = 0;

   if( is_void(photon_file) ) {

      eq_nocopy, cE, phs.E;
      good_bounce = 2*Num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      phs_bounce = phs.bounce;
      if( allbounce ) phs_bounce = phs.bounce * 0 + good_bounce;
      w = where( phs.status == 0 & phs_bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status (status 0 and bounce "+itoa(good_bounce)+")";
         return [];
      }
      detx = cE(1,w);
      dety = cE(2,w);
      rcoef = phs(w).rcoef;
      s1=swrite(format="Analysis based on Phs with %i status==0 and bounce==%i photons", nw, good_bounce);
      s2=swrite(format="   The focal length is %.2f m\n", Focal_length/1000.0);
      if( !silent ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      cur_focal_length = Focal_length;
      mt_log_entry,1,"mt_analysis",s1,s2;

   } else {

      if( !file_test(photon_file) ) {
         write,"Photon file: "+photon_file+" was not found - skip.";
         return [];
      }
      hdr = headfits(photon_file+"+1");
      detx = rdfitscol(photon_file+"+1","detx");
      dety = rdfitscol(photon_file+"+1","dety");
      rcoef = rdfitscol(photon_file+"+1","rcoef");
      status = rdfitscol(photon_file+"+1","status" );
      bounce = rdfitscol(photon_file+"+1","bounce" );
      cur_focal_length = fxpar(hdr,"FOCALLEN");
      num_modules = fxpar(hdr,"NUMMODLS");
      good_bounce = 2*num_modules - 1; // 1 if a single module
                                       // 3 if two modules
      if( allbounce ) bounce = bounce * 0 + good_bounce;
      w = where( status == 0 & bounce == good_bounce );
      nw = numberof(w);
      if( nw == 0 ) {
         write,"No photons with OK status and bounce";
         return [];
      }

      detx = detx(w);
      dety = dety(w);
      rcoef = rcoef(w);

      hdr = headfits( photon_file+"+1" );
     /*
      *  Get focal length from the Optical Module file
      *  If omfile2 keyword exists then use that
      */
      omfile = fxpar( hdr, "omfile2" );
      if( is_void(omfile) ) {
         omfile = fxpar( hdr, "omfile1" );
         if( is_void(omfile) ) error,"##16## OMFILE1/2 keyword does not exist";
      }
      thdr = headfits( omfile+"+1" );
      focal_length = fxpar( thdr, "fclength" );
      s1=swrite(format="Photon file: %s with %i status==0 and bounce==%i photons", \
             photon_file, nw, good_bounce);
      s1=swrite(format="   The focal length is %6.2f m", cur_focal_length/1000.0);
      if( am_subroutine() ) {
         write,format="%s\n", s1;
         write,format="%s\n", s2;
      }
      mt_log_entry,1,"mt_analysis",s1,s2;

   }

// Determine HPD = Half Power Diameter with Rcoef weighting

   if( geom ) rcoef() = 1.; // neutralize the Rcoef information
   n_photons = numberof(detx);
   // get best position
   xp = wavg(detx,rcoef);
   yp = wavg(dety,rcoef);
   if( am_subroutine() ) {
      write,format="Center with all %i photons: %7.3f %7.3f\n", n_photons, xp, yp;
   }
   xrms = wrms(detx,rcoef);
   yrms = wrms(dety,rcoef);
   w = where( abs(detx - xp) < 3. * xrms );
   xp = wavg(detx(w),rcoef(w));
   nwx = numberof(w);
   w = where( abs(dety - yp) < 3. * yrms );
   yp = wavg(dety(w),rcoef(w));
   nwy = numberof(w);
   s1=swrite(format="Improved center with %i, %i photons: %7.3f %7.3f", \
           nwx, nwy, xp, yp);

   r = sqrt((detx-xp)^2 + (dety-yp)^2);
   is = sort(r);
   r = r(is);
   rcoef = rcoef(is);
   hpd_mm = 2.*interp( r, arr_accum(rcoef,norm=1), frac )(1);
   hpd_arcsec = (hpd_mm / cur_focal_length) * 648000. / pi;

   if( frac == 0.5 ) {
      s2=swrite(format="HPD : %.3f mm <> %.2f arcsec", hpd_mm, hpd_arcsec);
   } else {
      iff = long(frac*100 + 0.5);
      s2=swrite(format="%0i%%D : %.3f mm <> %.2f arcsec", iff, hpd_mm, hpd_arcsec);
   }
   if( am_subroutine() ) {
      write,format="%s\n",s1;
      write,format="%s\n",s2;
   }
   mt_log_entry,1,"   "+s1,s2;

  /*
   *   FWHM determination
   */

 /**********    omitted for the time being  ...
   n_annuli = n_photons/200;
   if( n_annuli < 5 ) n_annuli = 5;
   if( n_annuli > 100 ) n_annuli = 100;
   rlim = array(double,n_annuli);
   // let the first (real) radius be the 100 cts radius
   rlim(2) = r(100);
   rlim(2:0) = spanl(rlim(2), 2*hpd_mm, n_annuli-1);

   parr = array(double,n_annuli-1);
   for( i = 2; i <= n_annuli; i++ ) {
      w = where( r >= rlim(i-1) & r < rlim(i) );
      area = pi*(rlim(i)^2 - rlim(i-1)^2);
      nw = numberof(w);
      if( i == 2 ) {
         write,format="FWHM 1 : counts in inner circle : %i\n", nw;
         peak = nw / area;
      }
      parr(i-1) = nw / area;
   }
   parr /= peak;
****************************/

   return hpd_mm;
}

/* Function mt_create_om_hyp2 */

func mt_create_om_hyp2( filename=, master= )
/* DOCUMENT mt_create_om_hyp2, filename=, master=

   Create Optical Module of type hyperboloide 2
   - constant length mirrors
   The mirror lengths and thicknesses are defined
   in the system definition file and set as external variables by
   'mt_setup_system'.

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the master module which
   by default is Om_files(1) (set by mt_setup_system). This
   can be overridden by keyword 'master' which may define
   the chosen master optical module.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   2007-10-01/NJW
   2008-04-04/NJW updated e.g. with keyword 'master'
   2011-08-25/NJW updated to version 4.0
*/
{
// ynclude = zab
  extern  Acoef,                   Mirror_thickness_files,  Z_reference, \
          Fcoef,Telescop,Instrume, Num_modules,             Zfocus, \
          Mirror_lengths,          Om_files,                Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_hyp_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

  /*
   *   Assume that the master and slave module have no gap between them
   *   so the r1_arr of the slave is equal to the r2_arr of the master
   */

   //  Read the master data
   r1_arr = rdfitscol( master+"+1", "R2" );

   //  Calculate the mirror thicknesses
   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   // The hyperbolic slave section is number 2

   Fcoef = 0.5*((Zfocusarr(2) - Zfocusarr(1)) + (Z_reference(2) - Z_reference(1)));

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   b2 = (z1 - Zfocus + Fcoef)^2 + Fcoef^2 + r1_arr^2; // array

   acoef_arr = sqrt(0.5*(b2 - sqrt(b2^2 - 4*(z1 - Zfocus + Fcoef)^2 * Fcoef^2)));

   r2_arr = r1_arr;
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      Acoef = acoef_arr(mir); // required for the 'rhyp' function
      r2_arr(mir) = rhyp( z2 );
   }
   coating = array(0,nmir);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","hyperbolic","Type of mirror module";
   kwds_set,"MODSTAT","slave","Mirror positions defined by other module";
   kwds_set,"MASTER", master,"Master optical module file";
   kwds_set,"FCOEF",Fcoef,"[mm] Half distance between foci";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of previous mirror
   *  at z = z1
   */
   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "ACOEF",acoef_arr,"MLENGTH",z1_arr-z2_arr,"MTHICK",mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The hyperbolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par1 */

func mt_create_om_par1( filename= )
/* DOCUMENT mt_create_om_par1, filename=

   Create Optical Module of type paraboloide 1 with constant mirror
   spacing but variable mirror lengths.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Takes R_outer, R_inner_design, Z_reference, Zfocus from system definition file,
   which is read by 'mt_setup_system'

   Update to version 4.0  2011-08-25/NJW
*/
{
// ynclude = zac
  extern  Dcoef,                   R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z_reference,             Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

  /*
   *   Get constants from external variables loaded by 'mt_setup_system'
   *   from system definition file
   */

   spacing = Om_parameters(1);

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

  /*
   *  Define mirrors from outside inwards, but they are numbered
   *  from the inside to the outside i.e. increasing with radius.
   *
   *  The photons meets first z1 at entrance and then z2 at exit.
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has longer and
   *  longer mirrors for decreasing radius. There is a constant
   *  spacing between the mirrors and the aperture is to be exploited
   *  as well as possible.
   *
   *   This is the proposal for the Gamma Ray Imager mission
   *   as of 2007-08-16
   *
   *   2007-09-21/NJW
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

   // Search r2 and hence the thickness of mirror 2 in two iterations

   r2_guess = r1;

   for( i = 1; i <= 2; i++ ) {
      mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
      open_space = spacing - mirror_thickness;

      // find where in z the radius, r2, is r1 - open_space

      z = z1;
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
      r = rpar(z);
      while( r > r1 - open_space ) {
         z -= 2.;
         r = rpar(z);
      }
      while( r < r1 - open_space ) {
         z += 0.05;
         r = rpar(z);
      }
      r2_guess = r;
   }


   r2 = r;
   z2 = z;
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z of reference plane in tel. syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coord. of focus point in opt.mod. syst.";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"SPACING",spacing,"[mm] Distance refl. surface to refl. surface";
   kwds_set,"DESIGN","I - constant spacing","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      z = z1;
      r1 = r2 - mirror_thickness; // mirror_thickness from prevous determination
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

     /*
      *   Start a search process in mirror length where the current
      *   mirror inner radius
      *   will intersect the next mirror's outer radius
      */

      // Search r2 and hence the thickness of mirror 2 in two iterations

      r2_guess = r1;

      for( i = 1; i <= 2; i++ ) {
         mirror_thickness = interp(mthick_thick,mthick_radius,r2_guess);
         open_space = spacing - mirror_thickness;

         r = rpar(z);
         while( r > r1 - open_space ) {
            z -= 2.;
            r = rpar(z);
         }
         while( r < r1 - open_space ) {
            z += 0.05;
            r = rpar(z);
         }
         r2_guess = r;
      }
      r2 = r;
      z2 = z;

      // when found, add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   *    (entrance and exit slits)
   */

   //+ rb1i_arr = r1_arr - open_space;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = shift(z2_arr,1);
   zb2i_arr(0) = zb2i_arr(-1);
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of all arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_par2 */

func mt_create_om_par2( filename= )
/* DOCUMENT mt_create_om_par2, filename=

   Create Optical Module of type paraboloide 2
   - constant length mirrors
   - leak for on-axis radiation determined by om_parameter

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zad
  extern  Dcoef,Telescop, Instrume,Om_parameters,           Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocus, \
          Mirror_thickness_files,  R_outer,                 Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_par_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);
   z2 = z1 - mirror_length;
   r2 = rpar(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   d_arr = [];
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, d_arr, Dcoef;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner design radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","parabolic","Type of mirror module";
   kwds_set,"MODSTAT","Master","This defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1), "Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","mm","Unit for column 5";
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      // "loose" packing with factor Om_parameters(1) [NuStar value is 1.33]
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Dcoef = sqrt( (z1-Zfocus)^2 + r1^2 ) - (z1-Zfocus);

      r2 = rpar(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, d_arr, Dcoef;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "DCOEF",d_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The parabolic system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_pre_def_photons */

func mt_pre_def_photons( fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum= )
/* DOCUMENT mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, dphot=, \
                         renorm=, labxoff=, labyoff=, eqillum=

   Calls mt_def_photons according to the input 'energy_or_file'.

   fraper     array [inner radius, outer radius, lower azimuth, upper azimuth]
                        [mm]         [mm]          [deg]           [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
           OR
              the name of a source flux file (photflux as from mk_photflux(.i))
           OR
              the name of a sky definition file (EXTNAME == SKY_DEFINITION)
           OR
              the name of a labsource definition file (EXTNAME == LABSOURCE_DEFINITION)

   src_offaxis   [arcmin] source off axis angle
   src_azimuth   [degrees] source azimuth

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   labxoff   Offset [mm] of lab source in X
   labyoff   Offset [mm] of lab source in Y
  (eqillum   set if equal mirror illumination is requested - unphysical and only for
             special investigations)

   2010-05-27/NJW
   2011-01-20/NJW Version 3.1

*/
{

// ynclude = zae
  extern  Dec_scx,   Exposure,  Phs,       Posang,    Ra_scx, \
          Focal_length, Z_reference, Z1arr;
// yxclude =

   local filepff, extno;


   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file) != "string" ) energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;

   mode = 0; // energy, offaxis, azimuth has been input
     //   1     a single photon_flux file, offaxis, azimuth has been input
     //   2     a sky definition file has been input


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   // src_offaxis in arcmin,  src_azimuth in degrees
   if( !is_void(src_offaxis) ) offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
   if( !is_void(src_azimuth) ) azimuth_rad = double(src_azimuth) * (pi/180.);

   // Then see if a filename has been given in 'energy_or_file'

   if( typeof(energy_or_file) == "string" ) { // Yes, a filename is given

      filename = energy_or_file;
      if( !file_test(filename) ) error,"MT_PRE_DEF_PHOTONS, an input file is missing!";
      dol = filename+"+1";
      hdr = headfits(dol);

      extname = fxpar(hdr,"extname");

      if( extname == "PHOTON_FLUX" || extname == "DXB_PHOTON_FLUX" ) {

         // single source with spectral distribution
         // only call 'mt_def_photons' and exit

         R = [cos(azimuth_rad)*sin(offaxis_rad), \
              sin(azimuth_rad)*sin(offaxis_rad), \
              -cos(offaxis_rad)];
         mt_def_photons, fraper, filename, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

      } else if( extname == "SKY_DEFINITION" ) {

         x_sky = rdfitscol(dol,"x_sky"); // Unit is arcmin
         y_sky = rdfitscol(dol,"y_sky"); // Unit is arcmin
         ener_arr = rdfitscol(dol,"energy"); // Unit is keV
         dphot_arr = rdfitscol(dol,"dphot"); // Unit is /mm2
         dol_arr = rdfitscol(dol,"dol");
         renorm_arr = rdfitscol(dol,"renorm");
         if( is_void(Exposure) ) Exposure = fxpar(hdr,"exposure"); // Unit is s
         Ra_scx = fxpar(hdr,"ra_scx"); // [deg] R.A. of boresight
         Dec_scx = fxpar(hdr,"dec_scx"); // [deg] Dec. of boresight
         Posang = fxpar(hdr,"posang"); // [deg] Position angle of satellite

         nsrc = numberof(x_sky);
         for( i = 1; i <= nsrc; i++ ) {
            src_offaxis = sqrt(x_sky(i)^2 + y_sky(i)^2);
            src_azimuth = anyof([x_sky(i),y_sky(i)]) ? atan(y_sky(i),x_sky(i))*180/pi : 0.0;
            // src_offaxis in arcmin,  src_azimuth in degrees
            offaxis_rad = double(src_offaxis) * (pi/180.) / 60.;
            azimuth_rad = double(src_azimuth) * (pi/180.);
            R = [cos(azimuth_rad)*sin(offaxis_rad), \
                 sin(azimuth_rad)*sin(offaxis_rad), \
                 -cos(offaxis_rad)];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               dphot = dphot_arr(i);
            } else { // We have a photon flux file (pff), check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               //  Changes with version 4.4.5
               //+ if( !file_test(filepff) ) error,"Not found: "+filepff;
               //+ fh = headfits( dolpff );
               //+ extnm = fxpar(fh,"extname");
               //+ if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
               //+            error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm_arr(i), flag=i, cont=i-1, eqillum=eqillum;
         }

      } else if( extname == "LABSOURCE_DEFINITION" ) {

         // find the source position (x,y,z), a single z value but there may be
         // several (many) x and y values (to desribe a non-point source)
         zposit = fxpar( hdr, "ZPOSIT" ); // mm
         x = rdfitscol( dol, "X" );  // mm
         y = rdfitscol( dol, "Y" );  // mm
         if( !is_void(labxoff) ) x += labxoff;
         if( !is_void(labyoff) ) y += labyoff;
         // ZPOSIT is defined relative to optic center hence a shift in z
         // must be included
         dz_from_optic_center = Z_reference(1) - Focal_length + Z1arr(1);
         z = zposit - dz_from_optic_center;

         ener_arr = rdfitscol( dol, "energy"); // Unit is keV
         strength_arr = rdfitscol( dol, "strength");
         if( !is_void(renorm) ) strength_arr *= renorm;
         dol_arr = rdfitscol( dol, "dol");
         nsrc = numberof(x);
         // loop over all the sub-sources
         for( i = 1; i <= nsrc; i++ ) {
            labsource_pos = [x(i), y(i), z];
            if( strtrim(dol_arr(i)) == "none" || strlen(strtrim(dol_arr(i))) == 0 ) {
               energy = ener_arr(i);
               strength = strength_arr(i);
            } else { // We have a photon flux file, check existence and header
               dolpff = dol_arr(i);
               get_exten_no, dolpff, filepff, extno;
               if( !file_test(filepff) ) error,"Not found: "+filepff;
               fh = headfits( dolpff );
               extnm = fxpar(fh,"extname");
               if( extnm != "PHOTON_FLUX" && extnm != "DXB_PHOTON_FLUX" ) \
                          error,filepff+" does not contain photon flux";
               energy = filepff;
            }
            // call with lab source position relative to outmost mirror edge
            mt_def_photons, fraper, energy, labsource_pos, \
                  dphot=strength, flag=i, cont=i-1, lab=1, eqillum=eqillum;
         }

      } else {
         error,"Unsupported EXTNAME: "+extname;
      }

   } else {

      // no filename, just real energy so
      // only call 'mt_def_photons' and exit

      R = [cos(azimuth_rad)*sin(offaxis_rad), \
           sin(azimuth_rad)*sin(offaxis_rad), \
           -cos(offaxis_rad)];
      mt_def_photons, fraper, energy, R, \
                  dphot=dphot, renorm=renorm, flag=1, eqillum=eqillum;

   }


   local loce; eq_nocopy, loce, Phs.E;
   r = sqrt(loce(1,)^2 + loce(2,)^2);
   isr = sort(r); // sort to increasing radii to minimize
                  // the reading of scattering files
   Phs = Phs(isr);
}


/* Function mt_def_photons */

func mt_def_photons( fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum= )
/* DOCUMENT mt_def_photons, fraper, energy_or_file, R_or_lab, \
                     dphot=, renorm=, flag=, cont=, lab=, eqillum=

   Defines photons in external array of struct 's_Ray' in Phs, arriving in
   a single specified direction.
   They will get a Z value = 0 (E(3) = 0) and be sorted with increasing
   radius. The energy distribution is evaluated here.

   fraper     Array of [inner radius, outer radius, lower azimuth, upper azimuth]
                          [mm]            [mm]         [deg]          [deg]
   energy_or_file     [keV] photon energy (monochromatic source)
                       OR
                      the name of the source flux file (photflux as from mk_photflux(.i))
   R_or_lab  directional vector of this bunch of photons
           OR
             position of laboratory source

   dphot=  is the photon density (default = 1.0) applies if energy_or_file is energy
   renorm= a factor multiplied on the source flux
   cont=   if set it will append to existing Phs
   flag=   for debugging
   lab=    set if 'R_or_lab' is lab source position
  (eqillum= set if equal mirror illumination is requested - unphysical and only for
            special investigations)

   SEE ALSO: mt_pre_def_photons  that deals with various photon directions

   2007-10-01/NJW
   Version 3.0   2011-01-05/NJW

*/
{

   extern Exposure, Phs;

   local energ_lo, energ_hi, photflux;

   if( is_void(dphot) ) dphot = 1.0;
   if(typeof(energy_or_file)!="string") energy = double(energy_or_file);
   if( is_void(renorm) ) renorm = 1.0;
   if( is_void(flag) ) flag = 1;


  /*
   *
   *     Define the X-ray source
   *
   */

   // First the position

   mt_log_entry,1,swrite(format="MT_DEF_PHOTONS flag = %i, R_or_lab(1,2,3) = %.6f %.6f %.6f",\
                         flag, R_or_lab(1), R_or_lab(2), R_or_lab(3));

   // Then see if there is a spectrum specification file

   if( typeof(energy_or_file) == "string" ) { // Yes, a spectrum should be used

      src_spec_file = energy_or_file;
      //  Changes with version 4.4.5
      //+ if( !file_test(src_spec_file) ) error,"MT_DEF_PHOTONS src file is missing!";
      //+ dol = src_spec_file+"+1";
      //+ hdr = headfits(dol);
      //+ energ_lo = rdfitscol( dol, "energ_lo" );
      //+ energ_hi = rdfitscol( dol, "energ_hi" );
      //+ photflux = rdfitscol( dol, "photflux" );

      // three new lines from version 4.4.5

      mem_restore,"ENERG_LO",energ_lo;
      mem_restore,"ENERG_HI",energ_hi;
      mem_restore, src_spec_file, photflux;

      if( is_void(Exposure) ) {
         write,"Notice! Exposure set to 100 s";
         Exposure = 100.;
      }
      // evaluate the photon density (include conversion to /mm2)
      dphot = 1.e-2 * Exposure * renorm * sum( photflux * (energ_hi-energ_lo));
      mt_log_entry,1,"MDP DOL of photflux: "+dol;

   } else mt_log_entry,1,swrite(format="MDP energy = %.3f keV",energy);

   kount = 0;



  /*
   *  Set the number of photons for the telescope in such a way
   *  that the average is kept correct, i.e. no systematic
   *  truncation
   */

   ang_span = (fraper(4) - fraper(3))*pi/180;
   fnphot = 0.5 * dphot * ang_span * (fraper(2)^2 - fraper(1)^2);
   ipart = long(floor(fnphot));
   fpart = fnphot - floor(fnphot);

   nphot = random() < fpart ? ipart+1 : ipart;
   n_injected = nphot;
   fn_expected = fnphot;

   mt_log_entry,1,swrite(format="MDP nphot = %i",nphot);

   if( !cont ) Phs = [];

   if( nphot ) {

      phs = array(s_Ray, nphot);

      // Define energies

      if( typeof(energy_or_file) == "string" ) {
        /*
         *  Lines from before 2010-08-04. The multiplication
         *  by (energ_hi-energ_lo) should not have been done
         *
         * phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
         *       photflux*(energ_hi-energ_lo), nphot );
         *
         *      Corrected from version 2.4
         */
         phs.energy = draw_from_dist( sqrt(energ_lo*energ_hi), \
               photflux, nphot );
      } else {
         phs.energy = energy;
      }

  /*
   *  Assign arrival positions at entrance aperture
   */

      phi = fraper(3) * pi/180 + random(nphot) * ang_span;
      rd22 = fraper(2)^2;
      rd12 = fraper(1)^2;
      // make uniform distribution on the aperture by
      // inverse of normalized integrated distribution of radii
      r    = sqrt(rd12 + random(nphot)*(rd22-rd12));

      if( eqillum ) { // change distribution
         // make uniform illumination of mirrors by choosing
         // a 1/r distribution of radii obtained by
         // inverse of normalized integrated distribution of radii

         write,"Using 1/r distribution ...";
         r = fraper(1) * (fraper(2)/fraper(1))^random(nphot);
      }

      //+ (version of before 2011-08-11) phs.E = transpose([r*cos(phi),r*sin(phi),array(0.0,nphot)]);
      phs.E = transpose([r*cos(phi),r*sin(phi),array(Z1arr(1),nphot)]);

      if( lab ) { // calculate individual directions
         local cE; eq_nocopy, cE, phs.E;
         for( i = 1; i <= nphot; i++ ) {
            R = cE(,i) - R_or_lab;
            R /= sqrt(sum(R^2)); // normalize
            phs(i).R = R;
            phs(i).D1 = R; // for display of track through telescope
         }
      } else {
     /*
      *  Define all photons with same direction (R) and positions (E)
      *  on aperture with z = 0
      */
         phs.R = R_or_lab(,-:1:nphot);
         phs.D1 = R_or_lab(,-:1:nphot); // for display of track through telescope
      }
      phs.rcoef = 1.0
      phs.status = 0;

      // assign the flag value

      phs.flag = flag;

      grow, Phs, phs;
   }

}




/* Function mt_eff_area_photons */

func mt_eff_area_photons( a, earr=, samp=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_photons( earr=, samp=, outfile= )

   Calculate the telescope effective area from the
   photons currently in memory in struct array 'Phs'.
   Go through all mirrors and sum the mirror contributions.
   The photons must be status==0 and bounce==2*Num_modules-1
   photons.

   Default energy array is 'E_uniq' (external variable)

   If keyword 'samp' is given then only 1 out of 'samp'
   photons are used. The process can take quite a long
   time.

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   Version 1.1     2007-11-06/NJW
   Version 3.3     2011-03-10/NJW
   update to version 4.0     2011-08-25/NJW
*/

{

// ynclude = zaf
  extern  Coat_list,       Mirror_coating,  R_inner,         Src_azimuth, \
          E_uniq,          Num_modules,     R_outer,         Src_offaxis, \
          Energy,          Phs,             Scatter_file,    Version, \
          Fraper_area, Telescope, Instrume;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }

   if( is_void(samp) ) samp = 1;
   if( samp < 1 ) samp = 1;

   n_inject = numberof(Phs);
   good_bounce = 2*Num_modules - 1;
   w = where(Phs.status == 0 & Phs.bounce == good_bounce);
   n_photons = numberof(w);
   loss_fraction = double(n_inject - n_photons) / n_inject;

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_photons of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( typeof(Energy) == "double" ) {
         kwds_set,"ENERGYIN", Energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if(!is_void(Src_offaxis))kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
      if(!is_void(Src_azimuth))kwds_set,"SRC_AZIM",Src_azimuth,"[degrees] Source azimuth angle";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      kwds_set,"NPHOT_IN", n_inject,"Number of injected photons";
      kwds_set,"NPHOTONS", n_photons,"Number of accepted photons";
      kwds_set,"SAMPLING", samp, "One out of this number of photons is used";
      kwds_set,"AP_AREA", Fraper_area,"[mm2] Aperture area";
   }


   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   if( !is_not_defined(Coat_list) ) {
      rcoef = array(0.0, n_earr);
      for( iev = 1; iev <= n_photons; iev += samp ) {
         coating = Mirror_coating(Phs(w(iev)).mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         angle1 = Phs(w(iev)).angle_in1;
         angle2 = Phs(w(iev)).angle_in2;

         for( iener = 1; iener <= n_earr; iener++ ) {
            ener = earr(iener);
            r = mt_get_rcoef( ener, angle1 );
            if( Num_modules > 1 ) {
               r *= mt_get_rcoef( ener, angle2 );
            }
            rcoef(iener) += r;
         }
      }
   } else rcoef = array( 1.0, n_earr );
   eff_area = (samp * rcoef / n_photons) * Fraper_area * (1 - loss_fraction);

   if( is_set(outfile) ) {
      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_eff_area_photons was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_eff_area_photons was: %.3f s\n", elapsed_time(1);

   return eff_area;
}

/* Function mt_fake_scatter_data */

func mt_fake_scatter_data( filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat= )
/* DOCUMENT mt_fake_scatter_data, filename, fwhm=, angle_max=, ener_min=, ener_max=, \
             n_ener=, n_angles=, dist_angle_max=, n_dist_angles=, coat=

   Produces a FITS scatter table as required by mt_run
   All angles (fwhm, angle_max, dist_angle_max) must be given in RADIANS
   Defaults:    fwhm     9.7e-5 rad (20 arcsec)
              angle_max  1.5e-2 rad (51 arcmin)  Maximal grazing angle covered
              ener_min      1   keV              Minimum of energy array
              ener_max     80   keV              Maximum of energy array
              n_ener       30                    Number of energy array elements
              n_angles     20                    Number of angle array elements
                coat        1                    Coating number
           dist_angle_max 5.818e-4 rad (2 arcmin) Limit of scattering distribution
           n_dist_angles  100                    Number of angles for distribution

   2007-10-05/NJW
   2012-03-01/NJW Version 4.2 updated with n_dist_angles
*/
{

   extern Version;

// Updated 2007-08-10/NJW to given angles in radians rather than relative values


   if( is_void(n_ener) ) n_ener = 30; // number of energy values
   if( is_void(n_angles) ) n_angles = 20; // number of angle values for scattering tables
   if( is_void(fwhm) ) fwhm = 9.7e-5; // radians = 20.0 arcsec
   if( is_void(angle_max) ) angle_max = 1.5e-2; // radians = 51 arcmin
   if( is_void(ener_min) ) ener_min =  1.0; // keV
   if( is_void(ener_max) ) ener_max = 80.0; // keV
   if( is_void(coat) ) coat = 1;

   // set maximal angle for the scattering angle i.e. away from specular direction
   if( is_void(dist_angle_max) ) dist_angle_max = 5.818e-4; // radians (2 arcmin)
      // define angular values for distribution:
   if( is_void(n_dist_angles) ) n_dist_angles = 100;
   angle_dist = span(-dist_angle_max,dist_angle_max,n_dist_angles);

   str = array(string,n_angles*n_ener+1);
   str(1) = "Angle values in radians";

   energy = span(ener_min,ener_max,n_ener)(,-:1:n_angles);
   angle_in = span(0,angle_max,n_angles)(-:1:n_ener,);
   energy = reform(energy,n_angles*n_ener);
   angle_in = reform(angle_in,n_angles*n_ener);
   grow,energy,-1.0;
   grow,angle_in,-1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);

   r_coef = array(double, n_angles*n_ener+1);
   r_coef(1) = -1.0;

   k = 0.12; // Constant product Ec * Acritical
   for( i = 2; i <= n_angles*n_ener+1; i++ ) {
      a = angle_in(i);
      e = energy(i);
      if( a == 0.0 ) {
         r_coef(i) = 1.0;
      } else {
         f = (2./pi)*atan(400.*a); // high energy suppression
         r_coef(i) = 1.0 - f * sost(e,k/a,5.);
      }
   }



   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian FWHM %10.3e rad (s=%10.3e rad)", fwhm, sigma);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_fake_scatter_data","produced this file";
   kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
   kwds_set,"ENERMIN", ener_min,"[keV] Minimum energy";
   kwds_set,"ENERMAX", ener_max,"[keV] Maximum energy";
   kwds_set,"ANGLEMAX", angle_max,"[rad] Maximum grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Maximum scatter angle";
   kwds_set,"COATING", coat, "Coating number";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   wrmfitscols, filename, "ENERGY", float(energy), "ANGLE_IN", float(angle_in), \
       "R_COEF", float(r_coef), \
       "DISTRIBUTION", float(distribution), "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", filename;

}


/* Function rpar */

/*************************************************************
 *   Functions for grazing incidence modular telescope raytracing
 *
 *   2007-08-02/NJW
 *   2007-08-13/NJW, update to apply 'rt_setup'
 *   2007-09-19/NJW, update to include Wolter I case
 *
 *   The mirror shape defining parameter 'Dcoef' must be defined
 *   externally since function 'rpar' expects it to be present.
 *   For a Wolter I system the parameters 'Fcoef' and 'Acoef'
 *   must similarly exist externally since functions 'rparw'
 *   and 'rhyp' expect them to be present.
 *
 *   Other variables expected as 'external':
 *     angles
 *     scatdist
 *
 *   3D vectors are represented as
 *   single character, upper case variable names
 *
 ****************************************************************/

func rpar( z, phi )
/* DOCUMENT radius = rpar( z, phi )

   returns the radius of a parabolic mirror with focus at
   (x,y,z) = (0,0,Zfocus) and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Dcoef and Zfocus must have been defined externally.

   If mirror deformations are to be included their value is sought
   in Mirror_deform_arr
*/
{
   extern Dcoef, Use_mdeform, Zfocus;
   r = sqrt(2*Dcoef*(z-Zfocus) + Dcoef^2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rhyp */

func rhyp( z, phi )
/* DOCUMENT radius = rhyp( z, phi )

   returns the radius of a hyperbolic mirror with focus at
   (x,y,z) = (0,0,0) (second focus in (0,0,-2*Fcoef)
   and expecting rays coming in with
   direction vectors ~ (0,0,-1)

   Acoef, Fcoef and Zfocus must have been defined externally
*/
{
   extern Acoef, Fcoef, Use_mdeform, Zfocus;
   fa = Fcoef^2 - Acoef^2;
   r2 = (z - Zfocus + Fcoef)^2 * fa / Acoef^2 - fa;
   r = sqrt(r2);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function rcon */

func rcon( z, phi )
/* DOCUMENT radius = rcon( z, phi )

   returns the radius of a conical mirror at position 'z'

   Mirror_angle, R1_mirror, and Z1_mirror must have been defined externally
*/
{
   extern Mirror_angle, R1_mirror, Use_mdeform, Z1_mirror;
   r = R1_mirror + (z - Z1_mirror)*tan(Mirror_angle);
   if( Use_mdeform ) r -= mt_mirror_deform( z, phi );
   return r;
}

/* Function mdist */

func mdist( funcname, C )
/* DOCUMENT distance = mdist( funcname, C )

   C defines a point in space that can be characterized
   by a z-value, a radius, and an azimuth angle.

   mdist returns the distance from this point to the mirror
   surface with same z and azimuth value. Under normal
   conditions this will to a very good approximation be
   the closest mirror point.
*/
{
   z = C(3);
   phi = atan( C(2), C(1) );
   r = funcname( z, phi ); // radius of mirror at this position
   // F becomes the mirror surface point at same z and azimuth
   F = [ r * cos(phi), r * sin(phi), z ];
   mdist_min = sqrt(sum((C - F)^2));
   rphot = sqrt(sum(C(1:2)^2));
   if( rphot > r ) mdist_min = -mdist_min;
   grow, F, mdist_min;
   return F;
}

/* Function impact */

func impact(funcname, z1, z2, S, R, step= )
/* DOCUMENT pos_dist = impact( funcname, z1, z2, S, R, step=  )

   calculates the interaction point of the ray defined by
   starting position S and direction vector R. The mirror
   is to be found between z1 (entrance) and z2 (exit,  z1 > z2 ).
   A vector of four elements: position plus final distance
   is returned.

   Keyword 'step' is the length step for detecting mirror surface
                  obstacles for the ray. Only active if mirror
                  deformations are applied. Defaults to 5 mm.
*/
{
   extern Use_mdeform;

   if( is_void(step) ) step = 5.0;

   // Advance photon to z1 (the start 'S2')
   t = (z1 - S(3))/R(3);
   S2 = S + t*R;
   if( mdist(funcname,S2)(4) < 0 ) return []; // Behind mirror to begin with

   u = (z2 - S2(3))/R(3); // required to get to end
   if( Use_mdeform ) {

      // Advance photon to z2 (exit) in steps of 5 mm

      upos = step;
      while( upos <= u ) {
         S1 = S2 + upos*R;
         if( mdist(funcname,S1)(4) < 0 ) { // hit the mirror at this position
                                           // or just before
         // try bisections to find the almost exact spot

            t1 = upos - step;
            t2 = upos;
            eps = 1.e29;

            while( eps > 0.0005 ) {
               t = 0.5*(t1 + t2);
               md = mdist(funcname, S2+t*R);
               if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
               eps = abs(md(4));
            }
            return md; // return the point of reflection
         }
         upos += step;
      }
      return []; // no hit, no reflection

   } else { // simple test - no deformations considered

      if( mdist(funcname,S2+u*R)(4) > 0 ) return []; // never hits mirror
      // OK, the mirror was hit, so do the binary search for the exact position

      t1 = 0.0;
      t2 = u;
      eps = 1.e29;

      while( eps > 0.0005 ) {
         t = 0.5*(t1 + t2);
         md = mdist(funcname, S2+t*R);
         if( md(4) > 0 ) {t1 = t;} else {t2 = t;}
         eps = abs(md(4));
      }
      return md; // return the point of reflection
   }
   return md;
}

/* Function deriv */

func deriv( funcname, x, phi )
/* DOCUMENT dfdx = deriv( funcname, x, phi )

   Very simple function, second argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dx = 1.;
   dfdx = (funcname(x+dx, phi)-funcname(x-dx, phi))/(2.*dx);
   return dfdx;
}

/* Function deriv2 */

func deriv2( funcname, x, phi )
/* DOCUMENT dfdphi = deriv2( funcname, x, phi )

   Very simple function, first argument is
   just a spectator, so it is rather a partial
   derivative.
*/
{
   dphi = 0.01745; // One degree
   dfdphi = (funcname(x, phi+dphi)-funcname(x, phi-dphi))/(2.*dphi);
   return dfdphi;
}

/* Function normal_vector */

func normal_vector( funcname, z, phi )
/* DOCUMENT n = normal_vector( funcname, z, phi )

   returns the normal vector to the surface given by
   'funcname' (rpar, rhyp, or rcon) that depends on the
   two variables: z and phi.
*/
{
   r = funcname(z, phi);
   drdz = deriv( funcname, z, phi );
   drdphi = deriv2( funcname, z, phi );
   sphi = sin(phi); cphi = cos(phi);
   v = [-drdphi*sphi/r - cphi, drdphi*cphi/r - sphi, drdz ];
   v /= sqrt(sum(v^2));
   return v;
}

/* Function spec_reflect */

func spec_reflect( R, N, &Q )
/* DOCUMENT angle = spec_reflect( R, N, Q )

   Calculates the specularly reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The returned value is the grazing angle [rad].
*/
{
   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;
   return asin(-dot);
}

/* Function scat_reflect */

func scat_reflect( R, N, scat_angle, &Q )
/* DOCUMENT angle = scat_reflect( R, N, scat_angle, Q )

   Calculates the scattered reflected ray as Q
   when the incoming ray is R and the surface normal is N.
   The scattering angle scat_angle [rad] is measured from the
   specular reflection with negative values towards the reflecting
   surface and with positive values away from the reflecting surface.
   The returned value is the grazing angle [rad].
*/
{
// first get the specular reflection

   N = N / sqrt(sum(N^2));
   dot = sum(R*N);
   Q = R - 2*dot*N;

// then the direction perpendicular to the specular reflection

   dot2 = dot^2;
   V = (N + dot*R - 2*dot2*N)/sqrt(1.0-dot2);

// The two vectors are added to make the scattered direction

   Q = Q*cos(scat_angle) + V*sin(scat_angle);

   return asin(-dot);
}


/* Function mt_get_rcoef */

func mt_get_rcoef( energy, angle_in )
/* DOCUMENT refl_coef = mt_get_rcoef( energy, angle_in )

   returns bi-linearly interpolated coefficient of reflection
   under current scatter data.

   Version 1.1    2007-09-25/NJW
*/
{

// ynclude = zag
  extern  Angle_inarr,  E_uniq,       Earr,         Num_warn,     R_coefarr, \
          Angle_uniq,   Scatter_type;
// yxclude =

   if( is_void(Num_warn) ) Num_warn = 0;

   // don't let a small difference stop the process
   if( E_uniq(1) - energy > 0.0 && E_uniq(1) - energy < 0.1 ) energy = E_uniq(1);
   if( energy - E_uniq(0) > 0.0 && energy - E_uniq(0) < 1.0 ) energy = E_uniq(0);
   if( energy < E_uniq(1) || energy > E_uniq(0) ) {
      write,format="##18## Energy %13.4e exceeds table range\n", energy;
      if( energy < E_uniq(1) ) {
         write,"because energy span begins at "+ftoa(E_uniq(1),ndec=4);
      } else write,"because energy span ends at "+ftoa(E_uniq(0),ndec=4);
      return [];
   }

   if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
      Num_warn++;
      if(Num_warn<11)write,format="##19## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
      if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
      if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
   }

   neu = numberof(E_uniq);
   nea = numberof(Angle_uniq);

   i1 = where(E_uniq <= energy)(0);
   if( i1 == neu ) i1--;
   e1 = E_uniq(i1);
   e2 = E_uniq(i1+1);
   f_e = (energy - e1)/(e2 - e1);

   j1 = where(Angle_uniq <= angle_in)(0);
   if( j1 == nea ) j1--;
   angle1 = Angle_uniq(j1);
   angle2 = Angle_uniq(j1+1);
   f_angle = (angle_in - angle1)/(angle2 - angle1);

   if( Scatter_type == 1 ) { // use TYPE1 method
      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
   } else { // use TYPE2 method introduced with version 4.0.1
      // R_coefarr is 2D (angle,energy)
      d1 = (1.0 - f_e) * R_coefarr(j1,i1)   + f_e * R_coefarr(j1,i1+1);
      d2 = (1.0 - f_e) * R_coefarr(j1+1,i1) + f_e * R_coefarr(j1+1,i1+1);
   }
   rcoef = (1.0 - f_angle) * d1 + f_angle * d2;

   return rcoef;

}


/* Function mt_load */

func mt_load( scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master= )
/* DOCUMENT mt_load, scatfile=, omfile=, mdeffile=, detfile=, gbend=, chat=, master=

   Loads 1) scattering      data     by      keyword 'scatfile'
         2) the optical    module  data  by  keyword 'omfile'
         3) the mirror deformation file  by  keyword 'mdeffile'
         4) the detector description file by keyword 'detfile'
   to the memory.

   The keyword 'master' applies only for loading an optical module file
   and it ensures that R_inner will be set.

   The keyword 'gbend' (Gravitational bending) applies only for loading
   a mirror deformation file. The function mt_gravity_bend is called.

   The corresponding external variables are updated as well.

     2007-09-21/NJW
   Updated to version 4.0   2011-08-25/NJW
   Updated to version 4.4.2   2012-09-14/NJW
*/
{

// ynclude = zah
  extern  Acoefarr,             Mirror_coating,       Rb1oarr, \
          Angle_inarr,          Mirror_deform_arr,    Rb2iarr, \
          Angle_uniq,           Mirror_thicknessarr,  Rb2oarr, \
          Anglesarr,            Modtype,              Rdm, \
          Coating_scat,         N_mirrors,            Rmf_file, \
          Dcoefarr,             Ne_mnx,               Scatter_file, \
          Distributionarr,      Num_pixels1,          Xpixlims, \
          Dxb_bkg_file,         Num_pixels2,          Xpixlo, \
          E_max,                Opt_module_file,      Ypixlims, \
          E_min,                Pixel_size1,          Ypixlo, \
          E_mnx,                Pixel_size2,          Z1arr, \
          E_uniq,               Q_ener,               Z2arr, \
          Earr,                 Qeff,                 Zb1iarr, \
          Energ_hi,             R1arr,                Zb1oarr, \
          Energ_lo,             R2arr,                Zb2iarr, \
          Fcoef,                R_coefarr,            Zb2oarr, \
          Instr_bkg_file,       R_inner,              Zfocus, \
          Mirror_anglearr,      Rb1iarr,              Scatter_type, Dead_pixel_map;
// yxclude =

   local fh, nrows;


   if( is_void(chat) ) chat = 0;

   if( !is_void(omfile) ) {

      Opt_module_file = omfile;

      if( !file_test(Opt_module_file) ) {
         write,format="The expected optical module file: %s does not exist\n", Opt_module_file;
         write,"Resolve the question and run mt_load again";
      } else {

         //  Get optical module information

         omdol = Opt_module_file+"+1";
         hdr = headfits(omdol);
         Modtype = fxpar( hdr, "MODTYPE" );

         ptr = rdfitsbin( omdol, fh, nrows );
         Z1arr = *ptr(fits_colnum(fh,"z1"));
         Z2arr = *ptr(fits_colnum(fh,"z2"));
         R1arr = *ptr(fits_colnum(fh,"r1"));
         R2arr = *ptr(fits_colnum(fh,"r2"));
         Zb1iarr = *ptr(fits_colnum(fh,"zb1i"));
         Zb2iarr = *ptr(fits_colnum(fh,"zb2i"));
         Rb1iarr = *ptr(fits_colnum(fh,"rb1i"));
         Rb2iarr = *ptr(fits_colnum(fh,"rb2i"));
         Zb1oarr = *ptr(fits_colnum(fh,"zb1o"));
         Zb2oarr = *ptr(fits_colnum(fh,"zb2o"));
         Rb1oarr = *ptr(fits_colnum(fh,"rb1o"));
         Rb2oarr = *ptr(fits_colnum(fh,"rb2o"));
         Mirror_thicknessarr = *ptr(fits_colnum(fh,"mthick"));
         fits_copy_keys, fh, tokwds=1; // Save keywords for mt_upd_om
         if( Modtype == "parabolic" ) {
            Dcoefarr = rdfitscol(omdol,"dcoef");
         } else if( Modtype == "hyperbolic" ) {
            Acoefarr = rdfitscol(omdol,"acoef");
            Fcoef = fxpar( hdr, "FCOEF" );
         } else if( Modtype == "conical" ) {
            Mirror_anglearr = rdfitscol(omdol,"mirror_angle");
         } else error,"Unrecognized type of module";
         Mirror_coating = rdfitscol(omdol,"coating");
         N_mirrors = numberof(R1arr); // avoid innermost mirror, no, not after version 3.2
         Zfocus = fxpar( hdr, "ZFOCUS" );
         if( master ) R_inner = Rb1iarr(1); // Setting R_inner to true inner radius
         if( chat > 0 ) {
            write,format="Using optical module %s\n", Opt_module_file;
            write,format="   with %i mirrors and Zfocus = %10.0f mm\n", N_mirrors, Zfocus;
         }

      }

   }

   if( !is_void(scatfile) ) {

      Scatter_file = scatfile;

      // Get scattering distribution

      if( !file_test(Scatter_file) ) {
         write,format="The expected scatter file: %s does not exist\n", Scatter_file;
         write,"Resolve the question and run mt_load again";
      } else {

         scatdol = Scatter_file+"+1";
         hdr = headfits( scatdol );
         if( is_void((extname = fxpar( hdr, "extname"))) ) error,"Missing EXTNAME in scatter file";
         if( extname != "SCATTER_TYPE1" && extname != "SCATTER_TYPE2" ) \
             error,"Bad EXTNAME of scatter file: "+Scatter_file;
         Coating_scat = fxpar( hdr, "coating" );
         if( is_void(Coating_scat) ) error,"Missing COATING keyword in scatter file";
         nrows = fxpar( hdr, "naxis2" );
         if( nrows <= 1 ) {
            write,format="Found %i rows in %s; insufficient so skip\n", \
                nrows, Scatter_file;
            write,"Resolve the question and run mt_load again";
         } else {
            if( extname == "SCATTER_TYPE1" ) {
               Scatter_type = 1;
               ptr = rdfitsbin( scatdol, hdr, nrows );
               //+ Distributionarr = rdfitscol( scatdol, "DISTRIBUTION" );
               Distributionarr = transpose(*ptr(fits_colnum( hdr, "DISTRIBUTION" )));
               Anglesarr = Distributionarr(,1);
               Distributionarr = Distributionarr(,2:0)/Distributionarr(sum,2:0)(-:1:0,);
               //+ Earr = rdfitscol( scatdol, "ENERGY" )(2:0);
               Earr = (*ptr(fits_colnum( hdr, "ENERGY" )))(2:0);
               //+ Angle_inarr = rdfitscol( scatdol, "ANGLE_IN" )(2:0);
               Angle_inarr = (*ptr(fits_colnum( hdr, "ANGLE_IN" )))(2:0);
               //+ R_coefarr = rdfitscol( scatdol, "R_COEF" )(2:0);
               R_coefarr = (*ptr(fits_colnum( hdr, "R_COEF" )))(2:0);
               // Get energy array without changing the order of Earr
               ise = sort( Earr );
               E_uniq = Earr(ise(uniq(Earr(ise))));
               // Get angle array without changing the order of Angle_inarr
               isa = sort( Angle_inarr );
               Angle_uniq = Angle_inarr(isa(uniq(Angle_inarr(isa))));
            } else { // We have a TYPE2 scatter file
               Scatter_type = 2;
               E_uniq = rdfitscol( scatdol, "energy" )(2:0); // first value is a dummy
               R_coefarr = rdfitscol( scatdol, "matrix_rcoef" );
               Angle_uniq = R_coefarr(,1); // first vector is the angle array
               R_coefarr = R_coefarr(,2:0);
               Distributionarr = rdfitscol( Scatter_file+"+2","distribution");
               Anglesarr = rdfitscol( Scatter_file+"+2","angle");
            }

            if( chat>2 ) {
               write,format="Using scatterfile %s\n", Scatter_file;
               write,format="    with %i energies and %i angles\n", \
                   numberof(E_uniq), numberof(Angle_uniq);
               write,format="  Coating type: %i\n", Coating_scat;
            }
         }
      }
   }

   if( !is_void(mdeffile) ) {

      if( !file_test(mdeffile) ) {
         write,format="The expected mirror deformation file: %s does not exist\n", mdeffile;
         write,"Resolve the question and run mt_load again";
      } else {
         Mirror_deform_arr = readfits(mdeffile+"+1");
         /*
          * Gravitational sag is introduced if requested. The phase is rotated like the optic
          * is rotated.
          */
         if( !is_void(gbend) ) mt_gravity_bend, gbend;
         dms = dimsof(Mirror_deform_arr);
         if( dms(1) != 3 ) error,"Mirror_deform_arr is not a 3D array";
         if( dms(2) < 2 ) error,"Mirror_deform_arr has too few azimuth values";
         if( dms(3) < 2 ) error,"Mirror_deform_arr has too few z values";
         if( dms(4) != N_mirrors ) error,"Mirror_deform_arr does not conform with number of mirrors";
         write,"Has loaded "+mdeffile;
         write,"      into external Mirror_deform_arr";
      }
   }

   if( !is_void(detfile) ) {

      if( !file_test(detfile) ) \
          error,"MT_LOAD did not find detector description file";

      Qeff = []; // to include a flag value
      qeff_file = comgets(detfile,"qeff_file");
      if( is_void(qeff_file) ) {
         write,"No qeff_file keyword found, assume that RMF contains the quantum efficiency";
      } else {
         if( !file_test(qeff_file) ) error,"MT_LOAD did not find QEFF file";

         Q_ener = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","ENERGY");
         Qeff   = rdfitscol(qeff_file+"[QUANTUM EFFICIENCY]","QUANTEFF");
         if( is_void(Q_ener) || is_void(Qeff) ) \
                error,"Extension QUANTUM EFFICIENCY or column missing";
      }

      Rmf_file = comgets(detfile,"rmf_file");
      if( is_void(Rmf_file) ) error,"MT_LOAD missing rmf_file keyword";
      if( !file_test(Rmf_file) ) error,"MT_LOAD did not find RMF file";

      Energ_lo = rdfitscol(Rmf_file+"[MATRIX]","ENERG_LO");
      Energ_hi = rdfitscol(Rmf_file+"[MATRIX]","ENERG_HI");
      Rdm      = rdfitscol(Rmf_file+"[MATRIX]","MATRIX");
      if( is_void(Energ_lo) || is_void(Energ_hi) || is_void(Rdm) ) \
             error,"Extension MATRIX or column missing";
      E_min    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MIN");
      E_max    = rdfitscol(Rmf_file+"[EBOUNDS]","E_MAX");
      if( is_void(E_min) || is_void(E_max) ) \
             error,"Extension EBOUNDS or column missing";
      E_mnx    = 0.5*(E_min + E_max);
      Ne_mnx = numberof(E_mnx);

      if( is_void(Qeff) ) { // assume that the quantum efficiency information
                            // is contained in the RDM
         Qeff = Rdm(sum,);
         Q_ener = 0.5*(Energ_lo+Energ_hi);
      }

      // first dimension of Rdm is over detector bins, E_min,E_max
      // second dimension of Rdm is test energies, Energ_lo, Energ_hi

      Num_pixels1 = comget(detfile,"num_pixels1",lng=1);
      if(is_void(Num_pixels1)) error,"MT_LOAD missing num_pixels1 keyword";
      Num_pixels2 = comget(detfile,"num_pixels2",lng=1);
      if(is_void(Num_pixels2)) error,"MT_LOAD missing num_pixels2 keyword";
      Pixel_size1 = comget(detfile,"pixel_size1");
      if(is_void(Pixel_size1)) error,"MT_LOAD missing pixel_size1 keyword";
      Pixel_size2 = comget(detfile,"pixel_size2");
      if(is_void(Pixel_size2)) error,"MT_LOAD missing pixel_size2 keyword";

      // Load the dead pixel map if found else set to 'all active'
      //    A pixel value of 1 (one) signals that the pixel is dead
      //    A pixel value of 0 (zero) signals that the pixel is active

      dol_dead_pixel_map = comgets(detfile,"dead_pixel_map");
      if( is_void(dol_dead_pixel_map)) {
         Dead_pixel_map = array(short,Num_pixels1,Num_pixels2);
      } else {
         local file_dead_pixel_map, extno_dpm;
         get_exten_no, dol_dead_pixel_map, file_dead_pixel_map, extno_dpm;
         if( !file_test(file_dead_pixel_map) ) error,"MT_LOAD did not find "+file_dead_pixel_map;
         Dead_pixel_map = readfits(dol_dead_pixel_map);
         dms = dimsof(Dead_pixel_map);
         if( Num_pixels1 != dms(2) || Num_pixels2 != dms(3) ) error,"MT_LOAD inconsistency in dead pixel map dimensions";
      }

      Xpixlo = (-Num_pixels1/2. + indgen(0:Num_pixels1-1))*Pixel_size1;
      Ypixlo = (-Num_pixels2/2. + indgen(0:Num_pixels2-1))*Pixel_size2;
      Xpixlims = 0.5*Pixel_size1*Num_pixels1*[-1,1];
      Ypixlims = 0.5*Pixel_size2*Num_pixels2*[-1,1];

      Dxb_bkg_file = comgets( detfile, "dxb_bkg_file" );
      if( is_void(Dxb_bkg_file) ) error,"MT_LOAD missing dxb_bkg_file";
      Instr_bkg_file = comgets( detfile, "instr_bkg_file" );
      if( is_void(Instr_bkg_file) ) error,"MT_LOAD missing instr_bkg_file";

   }
}


/* Function mt_mirror_fig */

/*
 *   This is rather a macro to sketch the mirror configuration
 */

func mt_mirror_fig( mirror_number )
/* DOCUMENT mt_mirror_fig, mirror_number

    Make a sketch of the mirror configuration around the given mirror
*/
{
// ynclude = zkk
   extern Om_files, Z_reference;
// yxclude =

   om_par_dol = Om_files(1)+"+1"
   om_hyp_dol = Om_files(2)+"+1"

   Zavg = avg(Z_reference);

   mir = mirror_number;

   R1arr = rdfitscol( om_par_dol, "r1" );
   R2arr = rdfitscol( om_par_dol, "r2" );
   Z1arr = rdfitscol( om_par_dol, "z1" );
   Z2arr = rdfitscol( om_par_dol, "z2" );
   Zb1iarr = rdfitscol( om_par_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_par_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_par_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_par_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_par_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_par_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_par_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_par_dol, "rb2o" );

   R1p = R1arr(mir);
   R2p = R2arr(mir);
   Z1p = Z1arr(mir) + Z_reference(1) - Zavg;
   Z2p = Z2arr(mir) + Z_reference(1) - Zavg;
   Zb1ip = Zb1iarr(mir) + Z_reference(1) - Zavg;
   Zb1op = Zb1oarr(mir) + Z_reference(1) - Zavg;
   Zb2ip = Zb2iarr(mir) + Z_reference(1) - Zavg;
   Zb2op = Zb2oarr(mir) + Z_reference(1) - Zavg;
   Rb1ip = Rb1iarr(mir);
   Rb1op = Rb1oarr(mir);
   Rb2ip = Rb2iarr(mir);
   Rb2op = Rb2oarr(mir);



   R1arr = rdfitscol( om_hyp_dol, "r1" );
   R2arr = rdfitscol( om_hyp_dol, "r2" );
   Z1arr = rdfitscol( om_hyp_dol, "z1" );
   Z2arr = rdfitscol( om_hyp_dol, "z2" );
   Zb1iarr = rdfitscol( om_hyp_dol, "zb1i" );
   Zb1oarr = rdfitscol( om_hyp_dol, "zb1o" );
   Zb2iarr = rdfitscol( om_hyp_dol, "zb2i" );
   Zb2oarr = rdfitscol( om_hyp_dol, "zb2o" );
   Rb1iarr = rdfitscol( om_hyp_dol, "rb1i" );
   Rb1oarr = rdfitscol( om_hyp_dol, "rb1o" );
   Rb2iarr = rdfitscol( om_hyp_dol, "rb2i" );
   Rb2oarr = rdfitscol( om_hyp_dol, "rb2o" );

   R1h = R1arr(mir);
   R2h = R2arr(mir);
   Z1h = Z1arr(mir) + Z_reference(2) - Zavg;
   Z2h = Z2arr(mir) + Z_reference(2) - Zavg;
   Zb1ih = Zb1iarr(mir) + Z_reference(2) - Zavg;
   Zb1oh = Zb1oarr(mir) + Z_reference(2) - Zavg;
   Zb2ih = Zb2iarr(mir) + Z_reference(2) - Zavg;
   Zb2oh = Zb2oarr(mir) + Z_reference(2) - Zavg;
   Rb1ih = Rb1iarr(mir);
   Rb1oh = Rb1oarr(mir);
   Rb2ih = Rb2iarr(mir);
   Rb2oh = Rb2oarr(mir);

   r_arr = [R1p,R2p,Rb1ip,Rb1op,Rb2ip,Rb2op,R1h,R2h,Rb1ih,Rb1oh,Rb2ih,Rb2oh];
   z_arr = [Z1p,Z2p,Zb1ip,Zb1op,Zb2ip,Zb2op,Z1h,Z2h,Zb1ih,Zb1oh,Zb2ih,Zb2oh];

   xr = [min(r_arr)-1, max(r_arr)+1];
   yr = [min(z_arr)-20, max(z_arr)+20];

   plot,[R1p,R2p],[Z1p,Z2p],xr=xr,yr=yr;
   oplot,[xr(1),Rb1ip],[Zb1ip,Zb1ip],thick=7;
   oplot,[Rb1op,xr(2)],[Zb1op,Zb1op],thick=7;
   oplot,[xr(1),Rb2ip],[Zb2ip,Zb2ip],thick=7;
   oplot,[Rb2op,xr(2)],[Zb2op,Zb2op],thick=7;

   oplot,[R1h,R2h],[Z1h,Z2h];
   oplot,[xr(1),Rb1ih],[Zb1ih,Zb1ih],thick=7;
   oplot,[Rb1oh,xr(2)],[Zb1oh,Zb1oh],thick=7;
   oplot,[xr(1),Rb2ih],[Zb2ih,Zb2ih],thick=7;
   oplot,[Rb2oh,xr(2)],[Zb2oh,Zb2oh],thick=7;
}

/* Function mt_qimage */

func mt_qimage( z, size=, dim=, offset=, cen=, win=, lg=, rcoef=, bsel=, pal=, title= )
/* DOCUMENT im = mt_qimage( z_value )
       or   mt_qimage, z_value

   Returns image of status==0 photon positions in extern 'Phs'
   if 'z_value' is not given, else all photons will be propagated to
   plane at z = z_value.

   Keyword 'size' defines the image edge size [mm] (default: extreme values).
   Keyword 'dim'  defines the dimensionality im(dim,dim) (default: 251).
   Keyword 'offset' or 'cen'  is only active when 'size' is set and it can be:
                    1) a 2-element array defining the (x,y) image center in mm
                    2) a scalar 0 (zero) to center on (0,0) [shorthand]
                    3) a scalar 1 (one) to center on the average position
   Keyword 'win'  number of display window (default is 0)
   Keyword 'lg'   display in log-color-scale
   Keyword 'rcoef' will cause a weighting with the reflection coefficients
   Keyword 'bsel'  will make a selection on the 'bounce' value
   Keyword 'pal'   will change the default palette ("yarg.gp") with the given one
   Keyword 'title'  Like for 'plot'

   If called as a subroutine the image will be displayed by function 'disp'

   2007-10-04/NJW
   Version 1.7   2008-12-18/NJW
   Version 4.3   2012-06-01/NJW
*/
{
   extern Phs;
   local cE, cR;

   if( is_void(win) ) win = 0;

   nphots = numberof(Phs);
   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;
   if( is_void(bsel) ) {
      w = where( Phs.status == 0 );
   } else {
      w = where( Phs.status == 0 & Phs.bounce == bsel );
   }
   if( numberof(w) == 0 ) {
      write,"Sorry, no status==0 photons present";
      return [];
   }
   cE = cE(,w);
   cR = cR(,w);
   //  propagate to requested z-plane
   if( !is_void(z) ) {
      t = (z - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
   }

   if( is_void(cen) && !is_void(offset) ) cen = offset;

   if( is_void(cen) ) {
      cen = array(0.0,2);
   } else {
      if( numberof(cen) == 1 ) {
         if( cen == 0 ) {
            cen = array(0.0,2);
         } else {
            cen = [avg(cE(1,)),avg(cE(2,))];
         }
      }
   }

   if( dim ) {
      dims = [dim,dim];
   } else {
      dims = [251,251];
   }

   if( size ) {
      xrg = size*[-0.5,0.5] + cen(1);
      yrg = size*[-0.5,0.5] + cen(2);
   } else {
      xrg = yrg = array(double,2);
      xrg(2) = max(cE(1,));
      xrg(1) = min(cE(1,));
      yrg(2) = max(cE(2,));
      yrg(1) = min(cE(2,));
   }
   //+ write,format="Xrange: %10.4f %10.4f\n", xrg(1), xrg(2);
   //+ write,format="Yrange: %10.4f %10.4f\n", yrg(1), yrg(2);

   weight = rcoef ? Phs(w).rcoef : [];
   im = makeimageu( dims, cE(1,), cE(2,), xr=xrg, yr=yrg, weight=weight );

   if( am_subroutine() ) {
      xax = span(xrg(1),xrg(2),dims(1));
      yax = span(yrg(1),yrg(2),dims(2));
      window,win,style="boxed.gs";
      if( typeof(pal) == "string" ) {
         if( strpart(pal,-2:0) != ".gp" ) pal += ".gp";
         palette,pal;
      } else palette,"yarg.gp";
      if( lg ) {
         disp, log(1 + im), xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      } else {
         disp, im, xtitle="mm", ytitle="mm", title=title, xax=xax, yax=yax;
      }
   } else {

      return im;
   }

}

/* Function mt_raytrace_module */

func mt_raytrace_module( no_scatter=, no_mdeform=, gbend=, chat= )
/* DOCUMENT mt_raytrace_module, no_scatter=, gbend=, chat=

   Updates the external array 'Phs' of structs (s_Ray) that contains the information:
      E   : endpoint (array of 3)
      R   : direction at endpoint (array of 3)
      angle_in1  : First module, grazing angle of incoming ray (rad)
      angle_out1 : First module, grazing angle of outgoing ray (rad)
      angle_in2  : Second module, grazing angle of incoming ray (rad)
      angle_out2 : Second module, grazing angle of outgoing ray (rad)
      energy : photon energy
      rcoef : reflection coefficient
      status : photon status, > 0 if obstructed, == 0 if OK
      mirror : mirror number
      bounce : bounce flag

   The photon starts at E, has direction R, will interact with
   ingoing angle 'angle_in' and outgoing angle 'angle_out'.

   Keywords:
        no_scatter=1  will disable scattering (but include Rcoef).
        no_deform=1   will disable mirror deformations.
        chat          puts info on terminal
        gbend         defines the amount of gravitational bending [mm]

   Assume that an optical module has been loaded.

   Upon exit from this function Phs.E is the point of reflection and
   Phs.R the direction of the reflected ray.

   Version 1.0   2007-10-01/NJW
   Version 3.3   2011-02-18/NJW
   Updated for version 4.0  2011-08-25/NJW
*/
{

// ynclude = zai
  extern  Acoef,                Mirror_number,        Rb2oarr, \
          Acoefarr,             Mirror_thicknessarr,  Scatter_file, \
          Anglesarr,            Modtype,              Spoke_define_files, \
          Coat_list,            Module_num,           Use_mdeform, \
          Coating_scat,         Phs,                  Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Mirror_angle,         R2arr,                Zb1iarr, \
          Mirror_anglearr,      Rb1iarr,              Zb1oarr, \
          Mirror_coating,       Rb1oarr,              Zb2iarr, \
          Mirror_deform_files,  Rb2iarr,              Zb2oarr, \
          Mirror_length,        Full_length_spokes1;
// yxclude =

   local Q;

   if( is_void(chat) ) chat = 0;

   if( Modtype == "parabolic" ) {
      mty = 0;
      rfunction = rpar;
   } else if( Modtype == "hyperbolic" ) {
      mty = 1;
      rfunction = rhyp;
   } else if( Modtype == "conical" ) {
      mty = 2;
      rfunction = rcon;
   } else error,"Unrecognized type of module";

   nphots = numberof( Phs );
   scat_angle = 0.0; // covers case for no_scatter==1
   rcoef = 1.0;      // initialization
   mmod = (Module_num - 1)*100;

  /*
   *  See if mirror deformations should be used and load them
   *  if required
   */

   Use_mdeform = 0;
   if( !no_mdeform ) {
      if( Mirror_deform_files(Module_num) != "none" ) {
         mt_load, mdeffile=Mirror_deform_files(Module_num),gbend=gbend;
         Use_mdeform = 1;
      }
   }

  /*
   *  See if spokes have been defined and load the data
   *  if required. Check both for entrance and exit spokes
   *  and read the data if required.
   */

   include_spokes_entrance = 0;
   if( Spoke_define_files(2*Module_num-2+1) != "none" ) {
      mt_spoke_read,pos=1;
      include_spokes_entrance = 1;
   }
   include_spokes_exit = 0;
   if( Spoke_define_files(2*Module_num-2+2) != "none" ) {
      mt_spoke_read,pos=2;
      include_spokes_exit = 1;
   }

  /*
   *  Analyze z values for baffles and mirrors. If there is little
   *  variation for the entrance (exit) values then a simple
   *  and fast algorithm can be applied.
   */

   zvar = 0;
   zb1i_var = max(Zb1iarr) - min(Zb1iarr) < 1.0 ? 0 : 1;
   zb1o_var = max(Zb1oarr) - min(Zb1oarr) < 1.0 ? 0 : 1;
   z1_var = max(Z1arr) - min(Z1arr) < 1.0 ? 0 : 1;
   z2_var = max(Z2arr) - min(Z2arr) < 1.0 ? 0 : 1;
   if( anyof([zb1i_var,zb1o_var]) ) {
      write,"NOTICE: Due to variations in entrance aperture the more";
      write,"elaborate search for mirror number is applied.";
      zvar = 1;
      zb1avg = avg(0.5*(Zb1iarr+Zb1oarr));
   }

  /*
   *  All photons must be propagated to the aperture plane
   *  defined by the inner slit edge of the baffles:
   *       z = max(Zb1iarr)
   *
   *  Note: If the entrance aperture is not close to being a
   *  plane then finding the correct mirror number requires an
   *  iteration that was introduced with version 3.3 [2011-02-18/NJW]
   */

   if( !zvar ) mt_propagate, max(Zb1iarr);

   for( iphot = 1; iphot <= nphots; iphot++ ) {

      // skip if photon has already been blocked before calling this function

      if( Phs(iphot).status != 0 ) continue;

      if( Phs(iphot).mirror <= 0 ) { // then it is the first module
         Phs(iphot).E1 = Phs(iphot).E;
      } else {
         Phs(iphot).E2 = Phs(iphot).E;
      }

     /*
      *   Test for passage between spokes
      */

      if( include_spokes_entrance ) {
         res_spokes = mt_spoke_blocking( Phs(iphot).E(1:2), pos=1 );
         if( res_spokes(1) ) Phs(iphot).status = mmod + 1;
      }

      // test status
      if( Phs(iphot).status != 0 ) continue;

      r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);

     /*
      *  If in a slave module then the mirror number is already
      *  defined (Phs.mirror > 0)
      *  else it must be found by the entrance baffle slit
      */

      if( Phs(iphot).mirror <= 0 ) { // mirror number is not known
         // so this must be first optical module.
         // Locate the first slit where the inner baffle radius is less than photon radius
         //  - remember that Rb1iarr decreases with index==Mirror_number
         if( zvar ) { // an iteration must be performed to assign the relevant radius
            mt_propagate, zb1avg, iphot; // propagate to average z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
            zb1i_ipol = interp( Zb1iarr, Rb1iarr, r );
            zb1o_ipol = interp( Zb1oarr, Rb1oarr, r );
            mt_propagate, 0.5*(zb1i_ipol+zb1o_ipol), iphot; // propagate to local z
            r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         }
         if( r <= min(Rb1iarr) ) {
            Phs(iphot).status = 2;
            continue;
         }
        /*
         * Assign mirror number (in first module)
         */
         //+ Mirror_number = where( Rb1iarr < r )(1);
         Mirror_number = where( Rb1iarr < r )(0);
         // if the radius is too small, then set mirror to one
         // and note in the status value
         if( numberof(Mirror_number) == 0 ) {
            Mirror_number = 1;
            Phs(iphot).status = mmod + 2;
            continue;
         }
         Phs(iphot).mirror = Mirror_number;
      } else {
         Mirror_number = Phs(iphot).mirror;
         // test entrance slit inner edge
         if( Rb1iarr(Mirror_number) > r ) {
            Phs(iphot).status = mmod + 2;
            continue;
         }
      }
      // test entrance slit outer edge
      if( Rb1oarr(Mirror_number) < r ) {
         Phs(iphot).status = mmod + 3;
         continue;
      }

     /*
      *  Now the photon has been tested against the baffle slit
      *  Test the mirror edges if not the innermost mirror
      */

      if( Mirror_number > 1 ) {
         mt_propagate, Z1arr(Mirror_number), iphot;
         r = sqrt(Phs(iphot).E(1)^2 + Phs(iphot).E(2)^2);
         if( r < R1arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 4;
            continue;
         }
         if( r > R1arr(Mirror_number) ) {
            Phs(iphot).status = mmod + 5;
            continue;
         }
      }

      //+ if( !no_scatter )
      if( !is_not_defined(Coat_list) ) {
         // Make sure that the correct scatter file has been loaded - else do
         w = where( Coat_list.id == Mirror_coating(Mirror_number) );
         if( numberof(w) == 0 ) {
            ss = swrite(format="%i", Mirror_coating(Mirror_number));
            error,"##20## Scatter file not present for coating "+ss;
         }
         requested_scatfile = Coat_list(w(1)).file;
         if( Scatter_file != requested_scatfile ) {
            mt_load,scatfile=requested_scatfile,chat=chat;
         }

         // Extra check
         if( Coating_scat != Mirror_coating(Mirror_number) ) {
            error,"##21## problem with coating match";
         }
      }

      // Update Mirror_length for use in rhyp, rpar, or rcon
      Mirror_length = Z1arr(Mirror_number) - Z2arr(Mirror_number);

      // Dcoef, Acoef, Mirror_angle, or R1_mirror
      //      (extern) is used by function 'impact'
      if( mty == 1 ) { // hyperbolic
         Acoef = Acoefarr(Mirror_number);
      } else if( mty == 0 ) {    // parabolic
         Dcoef = Dcoefarr(Mirror_number);
      } else {                   // conical
         Mirror_angle = Mirror_anglearr(Mirror_number);
         R1_mirror = R1arr(Mirror_number);
         Z1_mirror = Z1arr(Mirror_number);
      }

      // find point 'I' of mirror impact

      z1 = Z1arr(Mirror_number);
      z2 = Z2arr(Mirror_number);
      // first reflection by using a step size of 5 mm
      I = impact( rfunction, z1, z2, Phs(iphot).E, Phs(iphot).R, step=5. );
      if( is_void(I) ) { // No impact on reflecting surface

         if( Module_num == 1 ) {
            Phs(iphot).D2 = Phs(iphot).R; // direction after first reflection
            Phs(iphot).I1 = Phs(iphot).E; // place for first (pseudo-) reflection
         }
         I = Phs(iphot).E; // place for pseudo-reflection
         Q = Phs(iphot).R; // same direction after pseudo-reflection

      } else { // the mirror was hit on the reflecting surface

         // update the bounce flag

         Phs(iphot).bounce += Module_num;

         // Get surface normal (N) as derivative of surface function

         phi = atan( I(2), I(1) );
         N = normal_vector( rfunction, I(3), phi );

         // The exit direction from reflection is Q

         angle = spec_reflect( Phs(iphot).R, N, Q );
         if( !no_scatter ) {
            // get the scattering distribution based on energy and angle
            scatdist = mt_sel_scatter( Phs(iphot).energy, angle, rcoef );
            scat_angle = draw_from_dist( Anglesarr, scatdist, 1)(1);
            angle = scat_reflect( Phs(iphot).R, N, scat_angle, Q );
         } else if( !is_not_defined(Coat_list) ) {
            rcoef = mt_get_rcoef( Phs(iphot).energy, angle );
         }
         if( Module_num == 1 ) {
            Phs(iphot).I1 = I(1:3);
            Phs(iphot).D2 = Q;
         } else {
            Phs(iphot).I2 = I(1:3);
            // third direction will be Phs(iphot).R, see later
         }

         Phs(iphot).E = I(1:3);
         Phs(iphot).R = Q;
         if( Module_num == 1 ) {
            Phs(iphot).angle_in1 = angle;
            Phs(iphot).angle_out1 = angle + scat_angle;
         } else {
            Phs(iphot).angle_in2 = angle;
            Phs(iphot).angle_out2 = angle + scat_angle;
         }
         Phs(iphot).rcoef *= rcoef;

        /*
         *   Test for a second reflection the same mirror
         *   (which is treated as an absorption i.e. photon loss)
         */

         // finer resolution with step = 2. mm
         //+ newI = impact( rfunction, I(3), z2, I(1:3), Q, step=2. );
         //+ if( !is_void( newI ) ) { // a second reflection did occur - reject the photon
         //+    Phs(iphot).status = mmod + 7; // error 'behind the mirror'
         //+    continue;
         //+ }

      }

      // test lower edge of next mirror if not innermost mirror
      if( Mirror_number > 1 ) {
         t = (Z2arr(Mirror_number-1) - I(3))/Q(3);
         A = I(1:3) + t*Q;
         r = sqrt(A(1)^2 + A(2)^2);
         if( r < R2arr(Mirror_number-1) + Mirror_thicknessarr(Mirror_number-1) ) {
            Phs(iphot).status = mmod + 6;
            continue;
         }
      }
      // test lower edge of mirror
      t = (Z2arr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > R2arr(Mirror_number) ) {
         Phs(iphot).status = mmod + 8;
         continue;
      }

      // test inner edge of exit slit
      t = (Zb2iarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r < Rb2iarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 9;
         continue;
      }
      // test outer edge of exit slit
      t = (Zb2oarr(Mirror_number) - I(3))/Q(3);
      A = I(1:3) + t*Q;
      r = sqrt(A(1)^2 + A(2)^2);
      if( r > Rb2oarr(Mirror_number) ) {
         Phs(iphot).status = mmod + 10;
         continue;
      }

     /*
      *   Test for spokes at exit
      */

      if( include_spokes_exit ) {
         res_spokes_exit = mt_spoke_blocking( A(1:2), pos=2 );
         if( res_spokes_exit(1) ) {
            Phs(iphot).status = mmod + 11;
            continue;
         }
         if( Full_length_spokes1 ) {
            if( res_spokes(2) != res_spokes_exit(2) ) {
               Phs(iphot).status = mmod + 11;
               continue;
            }
         }
      }

   }

}

/* Function mt_reflplot */

func mt_reflplot( win=, atten=, angle=, unit= )
/* DOCUMENT mt_reflplot, win=, atten=, angle=, unit=

   plots the reflection coefficients of the scattering
   data currently loaded.
   Keyword      win   indicates the plot window number (0 - 7)
                      defaults to current window.
                atten only one curve for this many angles
                angle Plot only for this angle (overrides 'atten')
                unit  Unit of 'angle'. Can be "deg", "rad" (default), "mrad",
                                       "mdeg", "arcsec", or "arcmin"

   2007-10-31/NJW, updated 2012-10-29/NJW
*/
{

// ynclude = zaj
  extern  Angle_inarr,   Coating_scat,  Earr,          R_coefarr,     Scatter_file, \
          Angle_uniq,    E_uniq;
// yxclude =

   if( is_void(win) ) win = window();
   if( is_void(atten) ) atten = 1;

   n_error = 0;
   if( Scatter_type == 1 && is_void(Earr) ) { n_error++; write,"Extern Earr is missing";}
   if( is_void(E_uniq) ) { n_error++; write,"Extern E_uniq is missing";}
   if( Scatter_type == 1 && is_void(Angle_inarr) ) { n_error++; write,"Extern Angle_inarr is missing";}
   if( is_void(Angle_uniq) ) { n_error++; write,"Extern Angle_uniq is missing";}
   if( is_void(R_coefarr) ) { n_error++; write,"Extern R_coefarr is missing";}
   if( is_void(Scatter_file) ) { n_error++; write,"Extern Scatter_file is missing";}
   if( is_void(Coating_scat) ) { n_error++; write,"Extern Coating_scat is missing";}

   if( n_error > 0 ) {
      write,"Cannot continue";
      return [];
   }

   na = numberof( Angle_uniq );

   window,win,style="boxed.gs";

   if( is_void(angle) ) {

      if( Scatter_type == 1 ) {
         plot, E_uniq, R_coefarr(where(Angle_uniq(1) == Angle_inarr)), \
            title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      } else { // must be of type 2
         plot, E_uniq, R_coefarr(1,), \
            title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      }
   
      if( na > 1 ) {
         for( i = 2; i <= na; i += atten ) {
            if( Scatter_type == 1 ) {
               oplot, E_uniq, R_coefarr(where(Angle_uniq(i) == Angle_inarr));
            } else {
               oplot, E_uniq, R_coefarr(i,);
            }
         }
      }
      str = swrite(format="Coating type : %i",Coating_scat);
      xyouts,0.2,0.83,str,ndc=1,align=0,charsize=1.1;
      str = swrite(format="Min. angle: %9.2e rad = %8.1f mdeg", \
           Angle_uniq(2), Angle_uniq(2)*(180/pi)*1000.);
      xyouts,0.2,0.80,str,ndc=1,align=0,charsize=1.1;
      str = swrite(format="Max. angle: %9.2e rad = %8.1f mdeg", \
           Angle_uniq(-1), Angle_uniq(-1)*(180/pi)*1000.);
      xyouts,0.2,0.77,str,ndc=1,align=0,charsize=1.1;

   } else {

      if( typeof(unit) == "string" ) {
         if( unit == "deg" ) angle *= pi/180.;
         if( unit == "mrad" ) angle /= 1000.;
         if( unit == "mdeg" ) angle *= pi/180000.;
         if( unit == "arcsec" ) angle *= pi/(180.*3600.);
         if( unit == "arcmin" ) angle *= pi/(180.*60.);
      }
      ne = numberof(E_uniq);
      r = array(double,ne);
      for(i = 1; i <= ne; i++ ) r(i) = mt_get_rcoef(E_uniq(i),angle);
      plot, E_uniq, r, title=esc_uscore(Scatter_file), \
            xtitle="Energy [keV]",ytitle="R coef",yr=[0,1.5];
      str = swrite(format="Coating type : %i",Coating_scat);
      xyouts,0.2,0.83,str,ndc=1,align=0,charsize=1.1;
      str = swrite(format="Angle: %9.2e rad = %8.1f mdeg", \
           angle, angle*(180/pi)*1000.);
      xyouts,0.2,0.80,str,ndc=1,align=0,charsize=1.1;
   }

}

/* Function mt_run */

func mt_run( energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend= )
/* DOCUMENT mt_run, energy_or_file, src_offaxis, src_azimuth, dphot=, renorm=, \
             exposure=, no_scatter=, no_mdeform=, chat=, flag=, fraper=, \
             labxoff=, labyoff=, roll=, eqillum=, no_par=, gbend=

   energy_or_file   is either the photon energy in keV (scalar number),
                    a name of a source flux file e.g.
                    'photon_flux_????.fits' (e.g. made by mk_photflux(.i))
                    or a sky definition file with extension SKY_DEFINITION
   src_offaxis is source off axis angle in arcmin
   src_azimuth    is source azimuth in degrees

   dphot      is the photon density in units of /mm2   (default = 1.0)
                  Is only applicable if first argument is energy.
   renorm     the photon spectrum will be multiplied with this factor
                  Is only applicable if first argument is source flux file.
   exposure  defines the exposure time (in seconds) and creates the
                external variable 'Exposure' that will be used in subsequent
                calls of e.g. mt_run and mt_det_add_bkg.
   no_scatter=1 will disable the scattering; if no scattering files
               have been defined then this is the default choice.
               If not set: value will be taken from PFILES/mt_rayor.par
   no_mdeform=1 will disable the mirror deformations
               If not set: value will be taken from PFILES/mt_rayor.par
   chat=0      will stop screen messages
   chat=5      will produce a lot of screen messages
   flag=1      will stop processing after first module
   fraper      "front aperture" - a four-element array with [r1,r2,phi1,phi2]
               (in mm and degrees), default: [R_inner, R_outer, 0., 360.]
   labxoff     Offset [mm] of laboratory source in X direction
   labyoff     Offset [mm] of laboratory source in Y direction
                  These two only apply if a lab source is used
   roll        Roll angle [deg] around the z-axis of the optic in the counterclock
                  direction when viewed from the X-ray source towards the aperture.
  (eqillum     set if equal mirror illumination is requested - unphysical and only for
               special investigations)
   no_par      Avoid using parameter file for no_scatter and no_mdeform
   gbend       Amplitude of gravitational bending [mm] of optic

   Version 1.0       2007-10-02/NJW
   Version 2.6       2010-12-09/NJW
   Version 3.0       2011-01-17/NJW
   Version 3.1       2011-01-20/NJW
   Version 3.2       2011-01-26/NJW

*/
{

// ynclude = zak
  extern  Dphot,         Num_modules,   R_inner,       Scatter_file,  Z_reference, \
          Energy,        Num_warn,      R_outer,       Src_azimuth,   Zb1iarr, \
          Exposure,      Om_files,      Scatter_files,    Src_offaxis,   Zb1oarr, \
          Module_num,    Phs,           Use_scatter,   Use_mdeform,   Fraper, Fraper_area;
// yxclude =

   time_keeper = elapsed_time = array(double,3);
   timer, time_keeper;


   if( is_void(chat) ) chat = 0;
   if( is_void(dphot) ) dphot = 1.0;
   if( is_void(energy_or_file) ) error,"First argument is void";
   if( typeof(energy_or_file) != "string" ) {
      energy = double(energy_or_file);
   } else {
      if( !file_test(energy_or_file) ) error,"Missing file: "+energy_or_file;
   }
   if( is_void(src_offaxis) ) src_offaxis = 0.0;
   if( is_void(src_azimuth) ) src_azimuth = 0.0;
   if( !is_void(exposure) ) Exposure = exposure;
   if( is_void(renorm) ) { renorm = 1.; } else { renorm = double(renorm); }
   if( typeof(energy) == "double" ) Energy = energy;
   if( !is_void(fraper) ) {
      if( numberof(fraper) == 2 ) {
         grow, fraper, [0., 360.];
      } else if( numberof(fraper) != 4 ) error,"Invalid keyword 'fraper'";
   }
   if( is_void(roll) ) roll = 0.0;
   Src_offaxis = double(src_offaxis);
   Src_azimuth = double(src_azimuth);
   Dphot = double(dphot);

   if( is_void(flag) ) flag = 0;

   if( typeof(energy_or_file) == "string" ) {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="%s, src_offaxis %.2f arcmin", energy_or_file, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot), \
         //+ swrite(format="renorm = %.4f, exposure = %.2f s", renorm, Exposure);
         swrite(format="renorm = %.4f", renorm);
   } else {
      mt_log_entry, 1, "mt_run  **********************************", \
         swrite(format="Energy %.3f keV, src_offaxis %.2f arcmin", energy, Src_offaxis), \
         swrite(format="src_azimuth = %.1f deg, dphot = %.4f", Src_azimuth, Dphot);
   }
   if( !no_par ) { 
      //  By not defining 'no_scatter' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_scatter) ) {
         no_scatter = get_par( "mt_rayor.par","no_scatter" );
      } else {
         set_par, "mt_rayor.par","no_scatter", no_scatter;
      }
   } else {
      if( is_void(no_scatter) ) no_scatter = 0;
   }
   mt_log_entry, 1, "Keyword: no_scatter="+itoa(no_scatter);
   if( !no_par ) { 
      //  By not defining 'no_mdeform' means that the value should be taken from the mt_rayor.par file
      if( is_void(no_mdeform) ) {
         no_mdeform = get_par( "mt_rayor.par","no_mdeform" );
      } else {
         set_par, "mt_rayor.par","no_mdeform", no_mdeform;
      }
   } else {
      if( is_void(no_mdeform) ) no_mdeform = 0;
   }
   mt_log_entry, 1, "Keyword: no_mdeform="+itoa(no_mdeform);


  /*
   *   flag == 1 : stop after first module
   */

   Use_scatter = 1; // default condition
   if( is_void(Scatter_files) ) no_scatter = 1;
        // disable use of scatter data when none is present
   if( no_scatter ) Use_scatter = 0;

   // Generate array of struct (s_Ray) in external 'Phs' with photons

   // Load the first module in order to set the R_inner extern variable
   mt_load,omfile=Om_files(1),chat=chat,master=1; // setting the 'master' keyword
                           // ensures that R_inner will be set to Rb1iarr(0)

   if( is_void(fraper) ) {
      fraper = [R_inner, R_outer, 0., 360. ]; // default setting
   } else {  // adjust to R_inner and R_outer
      if( fraper(1) < R_inner ) fraper(1) = R_inner;
      if( fraper(2) > R_outer ) fraper(2) = R_outer;
   }
   if( fraper(3) > fraper(4) ) fraper(4) += 360.;

   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

  /*
   *      GENERATE THE PHOTONS
   */
   mt_pre_def_photons, fraper, energy_or_file, src_offaxis, src_azimuth, \
                dphot=dphot,renorm=renorm,labxoff=labxoff,labyoff=labyoff,eqillum=eqillum;

   if( chat ) write,format="%i photons have been started\n", numberof(Phs);
   if( chat ) write,format="Rotation of the optic %.3f deg around z\n", roll;
   mt_roll, -roll*pi/180; // convert to radians, mt_roll rotates the photons
      // so the roll angle must have opposite sign

   Scatter_file = "None";

   m1 = 1;
   m2 = (flag == 1) ? 1 : Num_modules;

   for( Module_num = m1; Module_num <= m2; Module_num++ ) {

      // Load optical module

      mt_load,omfile=Om_files(Module_num),chat=chat;

      if( Module_num == 1 ) { // change z-coordinate of photons to
                              // aperture plane
         z_aperture = max(max(Zb1iarr),max(Zb1oarr));
         Phs.E(3) = z_aperture;
      }

     /*
      *  mt_raytrace_module uses a coordinate system with origin at
      *  the reference plane. The function mt_pre_def_photons produces photons
      *  with z = 0. However, mt_raytrace_module, leaves the photon
      *  with z at the impact point (reflection point) in the local
      *  coordinate system.
      *  To prepare for next module the photons must be propagated
      *  to the aperture plane and the z value reset to zero.
      */

      if( Module_num > 1 ) {

         // Propagate all photons to the reference plane of the actual module
         // and change coordinate system

         cE = Phs.E; // relative to Z_reference(Module_num-1)
         cR = Phs.R;
         znew = Z_reference(Module_num) - Z_reference(Module_num-1);
         t = (znew - cE(3,)) / cR(3,);
         cE += t(-:1:3,)*cR;
         cE(3,) = 0.0; // reset 'z' to present module system
         Phs.E = cE;

      }

      // Raytrace through optical module

      Num_warn = 0;
      mt_raytrace_module,no_scatter=no_scatter,no_mdeform=no_mdeform,gbend=gbend,chat=chat;
      if( Num_warn > 0 ) write,format="%i off-range angle warnings for module\n", Num_warn;

   }

   // Print statistics
   if( chat>0 ) write,format="%8i  photons in total\n", numberof(Phs);
   if( chat>1 ) {
      mt_stat;
   }

   // Propagate to focal plane at z = 0.0

   if( flag == 0 ) {

      cE = Phs.E;
      cR = Phs.R;
      if( Num_modules == 2 ) {
         cE(3,) += Z_reference(2); // coordinate transformation
      } else {
         cE(3,) += Z_reference(1); // coordinate transformation
      }
      t = (0.0 - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;

   }

   //  Rotate photons back, remember the photon rotation is opposite the
   //    rotation of the optic
   mt_roll, roll*pi/180;

   timer, time_keeper, elapsed_time;
   mt_log_entry,1,swrite(format="CPU time for mt_run was: %.3f s", elapsed_time(1));
   write,format="CPU time for mt_run was: %.3f s\n", elapsed_time(1);

}

/* Function mt_restore */

func mt_restore( filenumber )
/* DOCUMENT mt_restore, filenumber

   Restores an MT_RAYOR session previously saved by 'mt_save'.
   The filename is 'ysession_nnnn.ysav' where 'nnnn' is the
   filenumber.

*/
{
    nnnn = swrite(format="%04i", filenumber);
    fname = "ysession_"+nnnn+".ysav";
    f = openb( fname );
    restore, f;
    close, f;
    write,"Session has been restored ...";
}

/* Function mt_save */

func mt_save( mode=, samp=, chat=, outfile=, dir=, nokwdsinit= )
/* DOCUMENT mt_save, mode=, samp=, chat=, outfile=, dir=, nokwdsinit=

   Save current content of memory (e.g. Phs) to one or more of:

       focal_plane_ssss.fits
       photons_ssss.fits
       events_ssss.fits
       session_ssss.ysav (Yorick 'save')
   ('ssss' is a serial number)

   unless 'outfile' (see below) has been given as a string.

   Keywords:
      mode   :  String with one or more of the letters
                    f  -  focal plane (image file)
                    p  -  photons (binary table)
                    e  -  events (binary table)
                    s  -  Yorick save of Phs (save file format)
                Default is all of those.
      samp   :  Only one of 'samp' photons will be written to
                      photons_ssss.fits
      chat   :  Degree of verbosity
      outfile:  Is interpreted as the name basis, the final name will become:
                     f<outfile>.fits, p<outfile>.fits, e<outfile>.fits, and y<outfile>.ysav
      dir    :  Directory where output file will be placed
      nokwdsinit : Will inhibit initialization of keywords

   2007-10-02/NJW
   2007-12-20/NJW updated with keyword 'mode'
   Version 1.7  2008-12-18/NJW now saves specified extern variables

*/
{

// ynclude = zal
  extern  Dec_scx,       Exposure,      Num_pixels2,   Posang,        Scatter_file, \
          Dim_focp,      Focal_length,  Om_files,      Ra_scx,        Src_azimuth, \
          Dphot,         Use_mdeform,   Phs,           Rmf_file,      Src_offaxis, \
          Energy,        Num_modules,   Pix_focp,      Scatter_files,    Version, \
          Evlist,        Num_pixels1,   Pixel_size1,   Use_scatter,   Fraper_area, \
          Telescop, Instrume, Fraper;
// yxclude =

   local ser_str;

   if( is_void(chat) ) chat = 0;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash(dir);

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111];
   nstatarr = numberof(statarr);
   nval = array(long,nstatarr);

   if( is_void(samp) ) samp = 1;
   if( is_void(mode) ) {
      mode = "fpes";
   } else {
      if( structof(mode) != string ) error,"mode must be a string";
      if( !strmatch( mode, "f") && !strmatch( mode, "p") && !strmatch( mode, "e") \
             && !strmatch( mode, "s") ) error,"mode must include one or more of fpes";
   }

   if( typeof(outfile) == "string" ) {
      use_std = 0;
   } else {
      use_std = 1;
      if( file_test("mt_serial.txt") ) {
         ser_num = atoi(rdfile("mt_serial.txt")(1));
         ser_num++;
      } else { // start over
         ser_num = 0;
      }
      ser_str = swrite(format="%04i",ser_num);
      write_slist,"mt_serial.txt",ser_str;
   }

//  define arrays to display and output results

   focp = array(double,Dim_focp,Dim_focp);
   a_focp = double(Dim_focp+1)/2;
   focp_spill = 0;

   nall = numberof(Phs);

   for(i = 1; i <= nstatarr; i++ ) {
      nval(i) = numberof(where(Phs.status==statarr(i)));
      if(chat>1)write,format="Status %4i: %9i\n", statarr(i), nval(i);
   }

   if( !nokwdsinit ) kwds_init;
   kwds_set,"N_INJECT",nall,"Number of photons injected";
   if( !is_void(Fraper_area) ) kwds_set,"FRAPAREA", Fraper_area,"[mm2] Front aperture area";
   for( i = 1; i <= nstatarr; i++ ) {
      kw = swrite(format="NSTAT%03i", statarr(i));
      kwds_set,kw,nval(i),"Number of photons with status=="+itoa(statarr(i));
   }
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software used";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   if( !is_void(Dphot) ) kwds_set,"PHOTDENS",Dphot,"[/mm2] Input photon surface density";
   if( typeof(Energy) == "double" ) kwds_set,"ENERGY",Energy,"[keV] Energy set in latest run of mt_run";
   if( !is_void(Src_offaxis)) kwds_set,"SRC_OFAX",Src_offaxis,"[arcmin] Source off axis angle";
   if( !is_void(Src_azimuth)) kwds_set,"SRC_AZIM",Src_azimuth,"[deg] Source azimuth axis angle";
   kwds_set,"FRAPER1",Fraper(1),"[mm] Inner radius of fraper";
   kwds_set,"FRAPER2",Fraper(2),"[mm] Outer radius of fraper";
   kwds_set,"FRAPER3",Fraper(3),"[deg] Lower angle of fraper";
   kwds_set,"FRAPER4",Fraper(4),"[deg] Upper angle of fraper";
   for(i=1;i<=Num_modules;i++) {
      knam = swrite(format="OMFILE%i",i);
      kwds_set,knam,Om_files(i),"Name of opt. mod. defining file";
   }
   kwds_set,"MDEFORM", Use_mdeform,"0: No mirror deformations, 1: included";
   if( Use_mdeform ) {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         knam = swrite(format="MDFILE%i",i);
         kwds_set,knam,Mirror_deform_files(i),"Name of mirror deformation file";
      }
   }
   //+ scatflag = Scatter_file != "None";
   //+ kwds_set,"SCATTER",scatflag,"0: No scatter, 1: with scatter";
   kwds_set,"SCATTER",Use_scatter,"0: No scatter, 1: with scatter";
   if( Use_scatter ) {
      nscat = numberof(Scatter_files);
      for(i=1;i<=nscat;i++) {
         knam = swrite(format="SCFL%i",i);
         kwds_setlongstr,knam,Scatter_files(i),"Name of scattering defining file";
      }
   }
   if( is_void(Exposure) ) {
      kwds_set,"EXPOSURE",1.0,"[s] Exposure time - default value";
   } else {
      kwds_set,"EXPOSURE",Exposure,"[s] Exposure time";
   }
   if( !is_void(Focal_length) ) kwds_set,"FOCALLEN",Focal_length,"[mm] Focal length";
   kwds_set,"SAMPLING",samp,"Sampling period";
   kwds_set,"NUMMODLS", Num_modules, "Number of optical modules in system";
   kwds_set,"TUNIT1","mm","Unit of DETX";
   kwds_set,"TUNIT2","mm","Unit of DETY";
   kwds_set,"TUNIT6","rad","Unit of ANGLE_IN1";
   kwds_set,"TUNIT7","rad","Unit of ANGLE_OUT1";
   kwds_set,"TUNIT8","rad","Unit of ANGLE_IN2";
   kwds_set,"TUNIT9","rad","Unit of ANGLE_OUT2";
   kwds_set,"TUNIT10","rad","Unit of AZIMUTH";
   kwds_set,"TUNIT12","keV","Unit of ENERGY";

   idx = indgen(1:nall:samp);
   //+ cE = Phs(idx).E;
   local cE; eq_nocopy, cE, Phs(idx).E;
   //+ cR = Phs(idx).R;
   local cR; eq_nocopy, cR, Phs(idx).R;
   local cE1; eq_nocopy, cE1, Phs(idx).E1; // for the azimuth calculation
   local cI1; eq_nocopy, cI1, Phs(idx).I1; // for saving (pos of first refl.)
   local cI2; eq_nocopy, cI2, Phs(idx).I2; // for saving (pos of second refl.)
   azimuth = zero2pi(atan(cE1(2,),cE1(1,)));
   if( strpos( mode, "p", 1 ) ) {
      if( use_std ) {
         photon_file = dir+"photons_"+ser_str+".fits";
      } else {
         photon_file = dir+"p"+outfile+".fits";
      }
      wrmfitscols,photon_file,"DETX",cE(1,),"DETY",cE(2,), \
            "RAYX",cR(1,), "RAYY",cR(2,), "RAYZ",cR(3,), \
            "ANGLE_IN1", Phs(idx).angle_in1, \
            "ANGLE_OUT1", Phs(idx).angle_out1, \
            "ANGLE_IN2", Phs(idx).angle_in2, \
            "ANGLE_OUT2", Phs(idx).angle_out2, \
            "AZIMUTH", azimuth, \
            "MIRROR", Phs(idx).mirror, \
            "ENERGY", Phs(idx).energy, \
            "RCOEF", Phs(idx).rcoef, "STATUS", Phs(idx).status, \
            "BOUNCE", Phs(idx).bounce, \
            "I1Z", cI1(3,), "I2Z", cI2(3,), extname="MT_EVENTS",clobber=1;
      write,format="Name of photon file: %s\n", photon_file;
      write,format="Number of rows in photon file : %8i\n", numberof(idx);
   }

   write,format="Number of injected photons      : %8i\n", nall;

   if( strpos( mode, "e", 1 ) ) {
      nEvlist = numberof(Evlist);
      if( nEvlist ) {
         if( use_std ) {
            event_list_file = dir+"events_"+ser_str+".fits";
         } else {
            event_list_file = dir+"e"+outfile+".fits";
         }
         kwds_del,"TUNIT1";
         kwds_del,"TUNIT2";
         kwds_set,"TUNIT3","mm","Unit of DETX";
         kwds_set,"TUNIT4","mm","Unit of DETY";
         kwds_del,"TUNIT5";
         kwds_set,"TUNIT6","keV","Unit of ENERGY";
         kwds_del,"TUNIT7";
         kwds_del,"TUNIT8";
         kwds_del,"TUNIT9";
         kwds_del,"TUNIT10";
         kwds_del,"TUNIT12";
         kwds_set,"RESPONSE", Rmf_file,"Path for response (RMF)";

         // Bring information on the coordinate system if defined

         kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
         kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
         kwds_set,"CRPIX1",Num_pixels1/2.,"Reference pixel coordinate 1";
         crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
         kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
         kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
         kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
         kwds_set,"CRPIX2",Num_pixels2/2.,"Reference pixel coordinate 2";
         crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
         kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
         kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
         pix1 = (Pixel_size1/Focal_length)*(180./pi);
         rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
         kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
         kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
         kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

         wrmfitscols, event_list_file,"RAWX", Evlist.rawx,"RAWY",Evlist.rawy, \
            "DETX",Evlist.detx,"DETY",Evlist.dety,"PHA",Evlist.pha, \
            "ENERGY",Evlist.energy,"FLAG",Evlist.flag,extname="MT_EVENTS",\
            clobber=1;
         write,format="Name of event list file: %s\n", event_list_file;
         write,format="Number of events : %8i\n", nEvlist;
      } else {
         write,"Sorry, no events in list, skip ...";
      }
   }

   if( strpos( mode, "f", 1 ) ) {
      for(k = 1; k <= nall; k++ ) {
         if( Phs(k).status != 0 ) continue;

         i = long(floor(Phs(k).E(1)/Pix_focp + a_focp + 0.5));
         j = long(floor(Phs(k).E(2)/Pix_focp + a_focp + 0.5));
         if( i >= 1 && i <= Dim_focp && j >= 1 && j <= Dim_focp ) {
            focp(i,j) += Phs(k).rcoef;
         } else focp_spill++;
      }

      if( use_std ) {
         focal_plane_file = dir+"focal_plane_"+ser_str+".fits";
      } else {
         focal_plane_file = dir+"f"+outfile+".fits";
      }
      kwds_set,"CRPIX1",a_focp,"Reference pixel";
      kwds_set,"CRVAL1",0.,"Reference value";
      kwds_set,"CDELT1",Pix_focp,"[mm] Pixel size";
      kwds_set,"CRPIX2",a_focp,"Reference pixel";
      kwds_set,"CRVAL2",0.,"Reference value";
      kwds_set,"CDELT2",Pix_focp,"[mm] Pixel size";
      kwds_set,"NOUTSID", focp_spill, "Number of photons outside focal image";
      kwds_set,"EXTNAME","MFOCAL_PLANE","Name of this extension";
      kwds_del,"TUNIT1";
      kwds_del,"TUNIT2";
      kwds_del,"TUNIT6";
      kwds_del,"TUNIT7";

      writefits,focal_plane_file, focp, clobber=1;
      write,format="Name of focal plane file: %s\n", focal_plane_file;
      write,format="Number of counts in focal plane : %8.1f\n", sum(focp);
   }

   if( strpos( mode, "s", 1 ) ) {
   // Save contents of Phs
      if( use_std ) {
         yorick_save_name = dir+"mt_session_"+ser_str+".ysav";
      } else {
         yorick_save_name = dir+"y"+outfile+".ysav";
      }

      f = createb(yorick_save_name);

      save,f,Phs;

      close,f;
      write,format="Saved Yorick session file: %s\n", yorick_save_name;
   }

}


/* Function mt_scatter_data_file */

func mt_scatter_data_file( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table in type 1 format from text files with two
   clumns: energy [keV] and coefficient of reflection.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 4.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   energy = [];
   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      pd  = strpos(nam,".ysav",rev=1);
      if( pd == 0 ) pd = 1;
      angle_deg = atof(strpart(nam,pus+1:pd-1));
      angle_rad = angle_deg * pi / 180.;

// **********   NB    NB    NB   Check following lines carefully!!!!!

      //+ ener = rscol( nam, 1, silent=1 )(6:-6:3); // only use 1 of 3
      //+ rcoef = rscol( nam, 2, silent=1 )(6:-6:3);
      //+ ener  = rscol( nam, 1, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      //+ rcoef = rscol( nam, 2, silent=1, nomem=1 )(1:0:5); // only use 1 of 5
      // - the two following lines apply to finns_data_101008
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
              // and reject the first 'skip' values

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, energy, ener;
            grow, angle_in, array(0.0,n_ener);
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, energy, ener;
      grow, angle_in, array(angle_rad,n_ener);
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   grow, energy, ener;
   grow, angle_in, array(graze_angle_max,n_ener);
   grow, rcoefarr, rcoef; // repeat latest
   n_angles++;

   // Add first row values (dummy -1)

   grow, energy, -1.0;
   grow, angle_in, -1.0;
   grow, rcoefarr, -1.0;
   energy = shift(energy,-1);
   angle_in = shift(angle_in,-1);
   rcoefarr = shift(rcoefarr,-1);

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   str = "Angle values in radians -1 -> 1 arcmin  ";
   s = "                    ";
   str += s+s+s+s;
   str = array(str,n_angles*n_ener+1);


   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:n_angles*n_ener+1);
   distribution(,1) = angle_dist;

   str(2:0) = swrite(format="Gaussian with FWHM of%10.3e rad (sigma =%10.3e rad)", fwhm, sigma);


   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   wrmfitscols, outfile, "ENERGY", energy, "ANGLE_IN", angle_in, \
       "R_COEF", rcoefarr, \
       "DISTRIBUTION", distribution, "DATA_ORIGIN", str, \
       clobber=1, extname="SCATTER_TYPE1";
   write,format="Has written scatter file %s\n", outfile;

}

/* Function mt_scatter_data_file_type2 */

func mt_scatter_data_file_type2( dir, template, coating, fwhm=, dist_angle_max=, \
                  unit=, outfile=, skip=, attenuate=, graze_angle_max=, gunit= )
/* DOCUMENT mt_scatter_data_file_type2, dir, template, coating, fwhm=, \
                  dist_angle_max=, unit=, outfile=, skip=, attenuate=, \
                  graze_angle_max=, gunit=

   Produces a FITS scatter table of type 2.

   Convention for the text filenames:    TTTTTTTNN_x.xxx
    where TTTTTT is the template (any number of characters)
              NN is the coating number (must be two digits)
           x.xxx is the grazing angle in degrees
   Two columns are expected, the first one with energies in keV and the
   second one the coefficient of reflection.

   Arguments:
       dir     :   Directory name where to find the text scatter files
    template   :   Characterizing part of text scatter file names (TTTTTTT)
    coating    :   Coating number requested

   Keywords:
       fwhm    :   The FWHM of the scattering distribution
                        (default 1.38e-4 radians =  28.3 arcsec).
       dist_angle_max : The scattering distribution will be given from
                           -dist_angle_max to +dist_angle_max in 100 steps
                         (default is 1 arcmin).
       unit    :   The angular unit of 'fwhm' AND 'dist_angle_max'.
                   Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").
     outfile   :   The output filename (will be overwritten if it exists beforehand).
        skip   :   Number of starting energy/coefficient values to skip. Defaults to 3.
   attenuate   :   Use only 1 out of 'attenuate' energy/coefficient values
                    E.g. attenuate=3 implies that only every third value is used
                    (useful to avoid creating too large files). Defaults to 3.
   graze_angle_max : The maximum grazing angle to be entered into the scattering data file.
                         Should be larger than the outer mirror angle plus the largest
                         source off-axis angle. Default is 0.05 rad (2.86 deg).
         gunit  :   The angular unit of 'graze_angle_max'.
                    Can be "arcsec", "arcmin", "deg", or "rad" (default "rad").

   Version 4.0      2011-09-02/NJW cloned from mt_scatter_data_file.
*/
{

   if( is_void(outfile) ) outfile = get_next_filename("scatter_???.fits");

   coatstr = swrite(format="%02i", coating);
   list = file_search(template+coatstr+"_*", dir);
   nlist = numberof(list);
   if( nlist == 0 ) {
      write,"No files found by name of "+template+coatstr+"_*";
      return;
   }

   list = list(sort(list));

   angle_in = [];
   rcoefarr = [];

   if( is_void(skip) ) skip = 3;
   if( is_void(attenuate) ) attenuate = 3;

   // apply the proper conversion for 'graze_angle_max'

   conv_fac = 1.0;
   if( is_void(graze_angle_max) ) {
      graze_angle_max = 0.05; // radians,  equals 2.86 degrees
   } else {
      if( !is_void(gunit) ) {
         if( gunit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( gunit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( gunit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( gunit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal gunit keyword";
            return [];
         }
      }
      graze_angle_max *= conv_fac;
   }

   first = 1;
   n_angles = 0;
   for( i = 1; i <= nlist; i++ ) {
      nam = list(i);

      write,format="Doing %s ...\n", list(i);

      // find the angle value from the file name
      pus = strpos(nam,"_",rev=1);
      angle_deg = atof(strpart(nam,pus+1:0));
      angle_rad = angle_deg * pi / 180.;

      // - the two following lines apply to finns_data_101008
      // and reject the first 'skip' values
      ener  = rscol( nam, 1, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'
      rcoef = rscol( nam, 2, silent=1, nomem=1 )(skip+1:0:attenuate); // only use 1 of 'attenuate'

      // Check that energy values are the same throughout

      if( first ) {
         first = 0;
         ener_ref = ener;
         write,format="Using %s as energy reference\n", nam;
         n_ener = numberof(ener);
         // extra angle = 0 if not already present
         if( angle_rad != 0.0 ) {
            grow, angle_in, 0.0;
            grow, rcoefarr, array(1.0,n_ener);
            n_angles++;
         }
      } else {
         dev = abs(ener_ref - ener);
         w = where(dev > 1.e-3);
         if( numberof(w) > 0 ) error,"Wrong e-table in "+nam;
      }

      grow, angle_in, angle_rad;
      grow, rcoefarr, rcoef;
      n_angles++;

   }

   // expand table to cover largest possible angle
   // 1 arcmin = 2.90888e-4 rad
   // 3 arcmin = 8.72665e-4 rad
   // 5 arcmin = 1.45444e-3 rad
   //10 arcmin = 2.90888e-3 rad
   //30 arcmin = 8.72665e-3 rad
   // 1 deg    = 1.74533e-2 rad
   // 2 deg    = 3.49066e-2 rad

   if( graze_angle_max > max(angle_in) ) {
      grow, angle_in, graze_angle_max;
      grow, rcoefarr, rcoef; // repeat latest
      n_angles++;
   }

   // Change rcoefarr to matrix  n_angles x n_ener

   rcoefarr = transpose(reform(rcoefarr,n_ener,n_angles));
   // Add first row values (dummy -1)

   grow, ener_ref, -1.0;
   grow, rcoefarr, angle_in;
   ener_ref = shift(ener_ref,-1); // Shift last element to be the first one
   rcoefarr = shift(rcoefarr,0,-1); // Shift last element to be the first one

   //+ rcoefarr = transpose( rcoefarr ); // reorganize for the file writing

   conv_fac = 1.0;
   if( is_void(fwhm) ) {
      fwhm = 1.38e-4; // radians = 28.3 arcsec
   } else {
      if( !is_void(unit) ) {
         if( unit == "arcsec" ) {
            conv_fac = pi/(180.*60.*60.);
         } else if( unit == "arcmin" ) {
            conv_fac = pi/(180.*60.);
         } else if( unit == "deg" ) {
            conv_fac = pi/(180.);
         } else if( unit == "rad" ) {
            conv_fac = 1.0;
         } else {
            write,"Illegal unit keyword";
            return [];
         }
      }
      fwhm *= conv_fac;
   }
   if( is_void(dist_angle_max) ) {
      dist_angle_max = 2.90888e-4; // radians = 1 arcmin
   } else {
      dist_angle_max *= conv_fac;
   }

   // define angular values for distribution
   angle_dist = span(-dist_angle_max,dist_angle_max,100);

   sigma = fwhm/2.35482;
   distribution = exp(-0.5*(angle_dist/sigma)^2);

   kwds_init;
   kwds_set,"DATE",ndate(3),"Time of file creation";
   kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
   kwds_set,"SITE","NSI/DTU","Institution";
   kwds_set,"ORIGIN","mt_scatter_data_file_type2-"+Version,"produced this file";
   kwds_set,"TUNIT1","keV","Photon energy";
   kwds_set,"TUNIT2","radian","Incoming angle";
   kwds_set,"NUM_ENER",n_ener,"Number of energies";
   kwds_set,"NUM_ANGL",n_angles,"Number of angles";
   kwds_set,"COATING", coating,"Coating number (coating type identifier)";
   kwds_set,"GRAZEMAX", graze_angle_max,"[rad] Max of grazing angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   kwds_set,"SKIP", skip, "Number of energies/coefficients to skip";
   kwds_set,"ATTENUAT", attenuate, "Attenuation of energies/coefficients";
   for( i = 1; i <= nlist; i++ ) {
      kwds_set,"COMMENT",list(i);
   }

   write,"##1## going to write first extension:";

   fh = wrmfitscols( outfile, "ENERGY", ener_ref, "MATRIX_RCOEF", rcoefarr, \
       clobber=1, extname="SCATTER_TYPE2", cont=1);
   kwds_init;
   kwds_set,"TUNIT1","radian","Reference angle";
   kwds_set,"DISTAMAX", dist_angle_max,"[rad] Max of distribution angle";
   write,"##2## going to write second extension:";
   wrmfitscols, fh, "ANGLE", angle_dist, "DISTRIBUTION", distribution, \
         extname="SCATTER_TYPE2B";
   write,format="Has written type 2 scatter file %s\n", outfile;

}


/* Function mt_sel_scatter */

func mt_sel_scatter( energy, angle_in, &rcoef )
/* DOCUMENT distribution = mt_sel_scatter( energy, angle_in, >rcoef )

   returns bi-linearly interpolated scatter distribution, normalized to sum = 1

   Version 1.1     2007-08-13/NJW
*/
{

// ynclude = zam
  extern  Angle_inarr,      Distributionarr,  Earr,             Num_warn, \
          Angle_uniq,       E_uniq,           Logflag,          R_coefarr, \
          Anglesarr,        Scatter_type;
// yxclude =

   if( Scatter_type == 1 ) { // apply TYPE1 method (from before version 3.5)

      if( energy < E_uniq(1) || energy > E_uniq(0) ) {
         write,format="##22## Energy %13.4e exceeds table range\n", energy;
         return [];
      }

      if( angle_in < Angle_uniq(1) || angle_in > Angle_uniq(0) ) {
         Num_warn++;
         if(Num_warn<11)write,format="##23## Warning: Angle %13.4e rad exceeds table range\n", angle_in;
         if( angle_in < Angle_uniq(1) ) angle_in = Angle_uniq(1) == 0.0 ? 1.e-5 : 1.01*Angle_uniq(1);
         if( angle_in > Angle_uniq(0) ) angle_in = 0.99*Angle_uniq(0);
      }

      i1 = where(E_uniq < energy)(0);
      e1 = E_uniq(i1);
      e2 = E_uniq(i1+1);
      f_e = (energy - e1)/(e2 - e1);

      j1 = where(Angle_uniq < angle_in)(0);
      angle1 = Angle_uniq(j1);
      angle2 = Angle_uniq(j1+1);
      f_angle = (angle_in - angle1)/(angle2 - angle1);

      idx11 =  where( angle1 == Angle_inarr & e1 == Earr )(1);
      idx12 =  where( angle2 == Angle_inarr & e1 == Earr )(1);
      idx21 =  where( angle1 == Angle_inarr & e2 == Earr )(1);
      idx22 =  where( angle2 == Angle_inarr & e2 == Earr )(1);

      d1 = (1.0 - f_e) * Distributionarr(,idx11) + f_e*Distributionarr(,idx21);
      d2 = (1.0 - f_e) * Distributionarr(,idx12) + f_e*Distributionarr(,idx22);
      distri = (1.0 - f_angle) * d1 + f_angle * d2;

      d1 = (1.0 - f_e) * R_coefarr(idx11) + f_e * R_coefarr(idx21);
      d2 = (1.0 - f_e) * R_coefarr(idx12) + f_e * R_coefarr(idx22);
      rcoef = (1.0 - f_angle) * d1 + f_angle * d2; // returned in argument

   } else { // Scatter data was TYPE2 so just no interpolation is needed

      distri = Distributionarr;
      rcoef = mt_get_rcoef( energy, angle_in ); // returned in argument

   }

   if( Logflag > 4 ) {
      coef = gaussfit(Anglesarr, \
        distri+random_n(numberof(distri))*1.e-5,[max(distri),0.,1.e-4]);
      write,format="From gaussian fit: FWHM = %10.2e radians\n",coef(3)*2.3548;
      mt_log_entry, 5, \
         swrite(format="mt_sel_scatter energy: %5.1f, angle_in: %11.3e", \
            energy, angle_in), \
         swrite(format="i1 j1 : %4i%4i, idx11 12 21 22 : %4i%4i%4i%4i", \
             i1, j1, idx11, idx12, idx21, idx22), \
         swrite(format="f_e: %6.3f, f_angle: %6.3f, FWHM: %11.3e", \
             f_e, f_angle, coef(3)*2.3548);
   }

   return distri;

}

/* Function mt_setup_system */

func mt_setup_system( system_filename )
/* DOCUMENT mt_setup_system, system_filename

   Reads the telescope system defining file (e.g. system_nustar.scm)
   and defines the external variables and the scattering files.
   Optical module files are tested for existence and for consistency
   with the requested system

   Version 1.1   2007-10-05/NJW
   Version 1.7   2008-12-18/NJW
   Version 1.8   2010-02-09/NJW with mirror deformations
   Version 2.3   2010-06-21/NJW with detector definition
   Version 4.4.2 2012-09-14/NJW with dead pixel detector map
*/
{

// ynclude = zan
  extern  Coat_list,               Num_modules,             Scatter_files, \
          Detector_descr_file,     Om_files,                Spoke_define_files, \
          Dim_focp,                Om_functions,            Z1_setups, \
          Focal_length,            Om_parameters,           Z2_setups, \
          Mirror_deform_files,     Pix_focp,                Z_reference, \
          Mirror_lengths,          R_inner_design,          Zfocusarr, \
          Mirror_thickness_files,  R_outer, Telescop, Instrume, System_filename;
// yxclude =

   mt_log_entry, 1, "mt_setup_system", system_filename;
   if( !file_test(system_filename) ) error,system_filename+" not found";
   System_filename = system_filename;

/**************************************************************

      GENERAL INFORMATION

**************************************************************/

   warn = 0;
   erro = 0;

   Focal_length = comget(system_filename,"focal_length");
   if( is_void(Focal_length) ) {
      write,"Error: Keyword focal_length is missing in "+system_filename;
      erro += 1;
   }

   Num_modules = comget(system_filename,"num_modules",lng=1);
   if( is_void(Num_modules) ) {
      write,"Error: Keyword num_modules is missing in "+system_filename;
      erro += 1;
   }

   om_types = comgets(system_filename,"om_type");
   if( is_void(om_types) ) {
      write,"Error: Keyword om_types is missing in "+system_filename;
      erro += 1;
   }

   if( erro ) {
      write,"Very important keywords are missing!";
      return;
   }

/**************************************************************

      OPTICAL  MODULES

**************************************************************/

   Om_files = comgets(system_filename,"om_file");
   if( is_void(Om_files) ) {
      write,"Error: Keyword om_file is missing in "+system_filename;
      erro += 1;
   }

   Om_functions = comgets(system_filename, "om_function");
   if( is_void(Om_functions) ) {
      write,"Error: Keyword om_function is missing in "+system_filename;
      erro += 1;
   }

   Om_parameters = comget(system_filename, "om_parameter");
   if( is_void(Om_parameters) ) {
      write,"Error: Keyword om_parameter is missing in "+system_filename;
      erro += 1;
   }

   Z_reference = comget(system_filename,"z_reference");
   if( is_void(Z_reference) ) {
      write,"Error: Keyword z_reference is missing in "+system_filename;
      erro += 1;
   }

   Zfocusarr = comget(system_filename,"Zfocus");
   if( is_void(Zfocusarr) ) {
      write,"Error: Keyword Zfocus is missing in "+system_filename;
      erro += 1;
   }

   Mirror_lengths = comget(system_filename,"mirror_length");
   if( is_void(Mirror_lengths) ) {
      write,"Error: Keyword mirror_length is missing in "+system_filename;
      erro += 1;
   }

   Mirror_thickness_files = comgets(system_filename,"mirror_thickness_file");
   if( is_void(Mirror_thickness_files) ) {
      write,"Error: Keyword mirror_thickness_file is missing in "+system_filename;
      erro += 1;
   } else {
      for( i = 1; i <= numberof(Mirror_thickness_files); i++ ) {
         if( !file_test(Mirror_thickness_files(i)) ) {
            write,"Error: Missing file: "+Mirror_thickness_files(i);
            erro += 1;
         }
      }
   }

   Mirror_deform_files = comgets(system_filename,"mirror_deform_file");
   if( is_void(Mirror_deform_files) ) {
      Mirror_deform_files = array("none",Num_modules);
   } else {
      for( i = 1; i <= numberof(Mirror_deform_files); i++ ) {
         if( Mirror_deform_files(i) == "none" ) continue;
         if( !file_test(Mirror_deform_files(i)) ) {
            write,"Error: Missing file: "+Mirror_deform_files(i);
            erro += 1;
         }
      }
   }

   if( erro ) {
      write,"Missing keywords or missing files!";
      return;
   }

  /*
   *   Either none, a single, or 2*Num_modules occurrences of keyword
   *   'spoke_define_file'
   *   A single is expanded to 2*Num_modules:
   *          Entrance   of first module
   *          Exit       of first module
   *          Entrance   of second module
   *          Exit       of second module
   */

   Spoke_define_files = comgets(system_filename,"spoke_define_file");
   if( is_void(Spoke_define_files) ) {
      Spoke_define_files = array("none",2*Num_modules);
   }
   if( numberof(Spoke_define_files) == 1 ) { // expand to use everywhere
      Spoke_define_files = array(Spoke_define_files,2*Num_modules);
   }

   Z1_setups = comget(system_filename,"z1_setup");
   Z2_setups = comget(system_filename,"z2_setup");

   write,format="Number of modules in system :  %i\n",Num_modules;

   warn = 0;
   if( Num_modules != numberof(Om_files) ) {
      write,"Non matching number of OM files";
      warn += 1;
   }
   if( Num_modules != numberof(om_types) ) {
      write,"Non matching number of om_type keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_lengths) ) {
      write,"Non matching number of mirror length keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_thickness_files) ) {
      write,"Non matching number of mirror_thickness_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Mirror_deform_files) ) {
      write,"Non matching number of mirror_deform_file keywords";
      warn += 1;
   }
   if( 2*Num_modules != numberof(Spoke_define_files) ) {
      write,"Non matching number of spoke_define_file keywords";
      warn += 1;
   }
   if( Num_modules != numberof(Z_reference) ) {
      write,"Non matching number of reference plane coordinates";
      warn += 1;
   }
   if( Num_modules != numberof(Zfocusarr) ) {
      write,"Non matching number of Zfocus values";
      warn += 1;
   }

   R_inner_design = comget(system_filename,"r_inner");
   if( numberof(R_inner_design) != 1 ) {
      write,"Missing r_inner value";
      warn += 1;
   }
   R_outer = comget(system_filename,"r_outer");
   if( numberof(R_outer) != 1 ) {
      write,"Missing r_outer value";
      warn += 1;
   }

   for(i=1;i<=Num_modules;i++) {
      if( om_types(i) != "parabolic" &&
          om_types(i) != "hyperbolic" &&
          om_types(i) != "conical" ) {
         write,format="Illegal optical module type: %s\n", om_types(i);
         warn += 10;
      }
   }

   for(i=1;i<=Num_modules;i++) {
      write,format="Optical module file :  %s\n",Om_files(i);
      if( !file_test(Om_files(i)) ) {
         write,format="                %s!\n", "not found";
         write,format="You may want to create it by '%s,filename=\"%s\"'\n", \
                  Om_functions(i), Om_files(i);
         warn += 100;
      } else { // Check consistency
         hdr = headfits( Om_files(i)+"+1" );
         if( !near(Mirror_lengths(i), -999.0, 1.e-3) ) {
            f_mirror_length = fxpar( hdr, "mirlngth" );
            if( !near(f_mirror_length, Mirror_lengths(i), 1.e-3) ) {
               write,format="Mismatching mirror length vs. %s\n", Om_files(i);
               warn += 100;
            }
         }
         f_zfocus = fxpar( hdr, "zfocus" );
         if( !near(f_zfocus, Zfocusarr(i), 1.e-2) ) {
            write,format="Mismatching Zfocus value vs. %s\n", Om_files(i);
            warn += 100;
         }
         f_r_inner = fxpar( hdr, "r_inner" );
         f_r_outer = fxpar( hdr, "r_outer" );
         if( i == 1 ) { // avoid this test for slave modules
            if( numberof(R_inner_design) == 1 ) {
               if( !near( f_r_inner, R_inner_design, 1.e1) ) {
                  write,format="Mismatching r_inner value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
            if( numberof(R_outer) == 1 ) {
               if( !near( f_r_outer, R_outer, 1.e-4) ) {
                  write,format="Mismatching r_outer value vs. %s\n", Om_files(i);
                  warn += 100;
               }
            }
         }
      }

      // Reporting and checking mirror thickness file

      write,format="Mirror thickness file: %s\n", Mirror_thickness_files(i);

      if( file_test(Mirror_thickness_files(i)) ) {
         dummy = rscol(Mirror_thickness_files(i),"radius",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","radius";
            warn += 5;
         }
         dummy = rscol(Mirror_thickness_files(i),"mirror_thickness",nomem=1,silent=1);
         if( is_void(dummy) )  {
            write,format="Column %s not found in mirror thickness file\n","mirror_thickness";
            warn += 5;
         }
      }

      // Reporting mirror deformation file

      if( Mirror_deform_files(i) == "none" ) {
         write,format="No mirror deformation to be used for module %i\n", i;
      } else {
         write,format="Mirror deformation file : %s\n", Mirror_deform_files(i);
         if( !file_test(Mirror_deform_files(i)) ) {
            write,format="                %s!\n", "not found";
            ttx = "You may want to create it by 'mt_mk_mdeform_file,";
            write,format=ttx+"\"%s\",mode,param,naz=,nz='\n", \
                     Mirror_deform_files(i);
            warn += 100;
         } else { // Check integrity
            fh = headfits(Mirror_deform_files(i)+"+1");
            if( fxpar(fh,"naxis") != 3 ) {
               write,"Data in mirror deformation file are not a 3D array!";
               warn += 100;
            }
         }
      }

      // Reporting spoke definition file

      for( j = 1; j <= 2; j++ ) {
         ii = (i-1)*2 + j;
         if( Spoke_define_files(ii) == "none" ) {
            write,format="No spoke definition is to be used for module %i\n", i;
         } else {
            write,format="Spoke definition file : %s\n", Spoke_define_files(ii);
            if( !file_test(Spoke_define_files(ii)) ) {
               write,format="             %s!\n","not found";
               warn += 100;
            }
         }
      }
   }

/**************************************************************

      SCATTERING INFORMATION

**************************************************************/

   Scatter_files = comgets(system_filename,"scat_file");
   nscat = numberof(Scatter_files);
   n_missing = 0;

   if( nscat > 0 ) { /* only if scatter files have been requested */

      Coat_list = array(s_Coat_list, nscat);

      for( i = 1; i <= nscat; i++ ) {
         // Scatter_files may be links, the target names are preferred
         if( OSTYPE != "nonx" ) Scatter_files(i) = rdline(popen("targetname "+Scatter_files(i),0));
         write,format="Scatter file :  %s",Scatter_files(i);
         Coat_list(i).file = Scatter_files(i);
         if( file_test(Scatter_files(i)) ) {
            hdr = headfits( Scatter_files(i)+"+1" );
            coating = fxpar( hdr, "coating");
            if( is_void(coating) ) error,"FITS keyword COATING is missing in "+Scatter_files(i);
            Coat_list(i).id = coating;
            write,format="  coating %i\n", coating;
         } else {
            write,format="%sdoes not exist\n", " ";
            n_missing++;
            if(n_missing < 9 ) warn += 10000;
         }
      }

   } else Coat_list = []; // Flagging no scatter files included

/**************************************************************

      FOCAL PLANE STANDARD DEFINITION

**************************************************************/

   Dim_focp = comget(system_filename,"Dim_focp",lng=1);
   Pix_focp = comget(system_filename,"Pix_focp");
   if( numberof(Dim_focp) != 1 ) {
      write,"Bad definition of 'Dim_focp'";
      warn += 100000;
   }
   if( numberof(Pix_focp) != 1 ) {
      write,"Bad definition of 'Pix_focp'";
      warn += 100000;
   }

/**************************************************************

      FOCAL PLANE DETECTOR DEFINITION

**************************************************************/

   Detector_descr_file = comgets(system_filename,"detector_descr_file");
   if( !is_void(Detector_descr_file) ) {
      if( file_test(Detector_descr_file) ) {
         mt_load,detfile=Detector_descr_file;
         write,format="Has loaded detector file: %s\n", Detector_descr_file;
      } else {
         warn += 1000000;
         write,"Did not find detector_descr_file: "+Detector_descr_file;
      }
   } else write,format="%s detector has been loaded\n","No";

/**************************************************************

      OPTIONAL INFORMATION ON TELESCOP AND INSTRUME

**************************************************************/

   // Turn out void if not defined in 'system_filename'
   Telescop = comgets(system_filename,"telescop");
   Instrume = comgets(system_filename,"instrume");

/***********************************************************/

   write,format="Warning level %i\n", warn;
   if( nscat == 0 ) {
      write,"Note that the use of scattering is excluded.";
   }
   if( warn > 0 ) {
      if(warn>=1000000) write,"Detector info is erroneous!";
      warn -= (warn/1000000)*1000000;
      if(warn>=100000) write,"Focal plane info is erroneous!";
      warn -= (warn/100000)*100000;
      if(warn>=10000) write,"One or more scatter files are missing!";
      warn -= (warn/10000)*10000;
      if(warn>=1000) write,"Problematic scattering file(s)!";
      warn -= (warn/1000)*1000;
      if(warn>=100) write,"An optical module file is missing!";
      warn -= (warn/100)*100;
      if(warn>=10) write,"An illegal system type has been specified!";
      warn -= (warn/10)*10;
      if(warn>=1) write,"Problem with basic information!";
   } else {
      write,"System OK!";
   }

}

/* Function mt_upd_om_coating */

func mt_upd_om_coating( coat_table, opt_module_file )
/* DOCUMENT mt_upd_om_coating, coat_table, opt_module_file

     coat_table is an Sformat file with two columns:
           // colname = mirror
           // colname = coating

     OR

     a single number (same coating for all mirrors)

     'opt_module_file' is the Optical Module FITS description file

     2007-10-05/NJW
*/
{
   if( typeof(coat_table) == "string" ) {
      if( !file_test(coat_table) ) {
         write,"Could not find: "+coat_table;
         return;
      }
      mirror = rscol(coat_table,"mirror",lng=1,silent=1,nomem=1);
      coat = rscol(coat_table,"coating",lng=1,silent=1,nomem=1);
   } else { // assume single value for all mirrors
      mirror = 1;
      coat = long(coat_table);
   }

   omdol = opt_module_file+"+1";
   nlines = numberof(mirror);
   hdr = headfits(omdol);
   nrows = fxpar(hdr,"naxis2"); // this is the number of mirrors
   allcoat = array(long, nrows);

   if( mirror(1) != 1 ) {
      write,"Error! First mirror in table must be 1!";
      return [];
   }

   if( nlines > 1 ) {
      for( i = 2; i <= nlines; i++ ) {
         if( mirror(i) <= mirror(i-1) ) {
            write,"Error! Mirror numbers are not in increasing order!";
            return [];
         }
      }
   }

   iline = 1;
   nextline = 2;
   grow, mirror, 99999; // make sure that index is within limits
   grow, coat, 0;
   for( i = 1; i <= nrows; i++ ) {
      if( i == mirror(nextline) ) {
         iline++;
         nextline++;
      }
      allcoat(i) = coat(iline);
   }


   fits_bintable_poke, omdol, 0, "coating", allcoat;

   write,format="%s has been updated\n", omdol;

}

/* Function get_alpha */

func get_alpha( zf, r1, mlen, &abc, &roots )
/* DOCUMENT  alpha = get_alpha( zf, r1, mlen, >abc, >roots )

   Return angle of mirror that reflects a boresight ray from
   the midpoint to an onaxis point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{
   // 1 alpha section

   //+ zf = -6000.0; // mm
   //+ r1 = 200.0; // mm
   //+ mlen = 250.0; // mm - mirror length

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   a = -t2/t3;
   b = -(t3 + 2*t1)/t3;
   c = t2/t3;

   abc = [a,b,c]; // returned as argument

   roots = cubic_eq( a, b, c ); // returned as argument
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   alpha = atan(roots(im(1)).re);

   return alpha;

}

/* Function get_beta */

func get_beta( alpha, zf, r1, mlen, &abc, &roots )
/* DOCUMENT  beta = get_beta( alpha, zf, r1, mlen, >abc, >roots )

   Return angle exceeding 2*alpha of mirror that reflects a ray
   coming at an angle 'alpha' from the midpoint to an onaxis
   point at position 'zf' (focal point).

   See NJW notebook 29/3 2008

   2008-03-29/NJW
*/
{

   // 3 alpha section (or beta section)

   //+ zf = -3000.0; // mm
   //+ r1 = r1 - mlen*tan(alpha); // mm
   //+ mlen = 250.0; // mm

   t1 = -mlen/2 - zf;
   t2 = r1;
   t3 = mlen/2;

   g = tan(2*alpha);

   div = g*g*t1 - g*t2 - t3;
   a = (-3*g*t1 + t2 - 2*g*g*t2 - 3*g*t3)/div;
   b = (2*t1 - g*g*t1 + 3*g*t2 + t3 - 2*g*g*t3)/div;
   c = (g*t1 - t2 + g*t3)/div;

   abc = [a,b,c];

   roots = cubic_eq( a, b, c );
   moduli = sqrt(double(roots*conj(roots)));
   im = where( moduli == min(moduli) );

   beta = atan(roots(im(1)).re);

   return beta;

}

/* Function mt_create_om_con2 */

func mt_create_om_con2( filename= )
/* DOCUMENT mt_create_om_con2, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - adjustable leak by Om_parameter(1)

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zao
  extern  Mirror_angle,            R1_mirror,               Z_reference, \
          Mirror_lengths,          R_outer,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Om_parameters, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(1);

  /*
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0; // mm, aperture is reference plane
   r1 = R_outer;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // for the benefit of 'rcon'
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      // Dcoef: parabolic constant; required for function 'rpar'
      Mirror_angle = get_alpha( Zfocus, r1, mirror_length );
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}


/* Function mt_create_om_con3 */

func mt_create_om_con3( filename=, master= )
/* DOCUMENT mt_create_om_con3, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the 'R2' array of the first module.
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zap
  extern  Mirror_angle,            Num_modules,             Z_reference, \
          Mirror_anglearr,         Om_files,                Zfocus, \
          Mirror_lengths,          R1_mirror,               Zfocusarr, \
          Mirror_thickness_files, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   *   2008-03-31/NJW
   */

  /*
   *   There is no gap between the master module and the slave module
   *   so r1_arr of the slave is equal to the r2_arr of the master
   */

   // Reading the r2_arr of the master
   r1_arr = rdfitscol( master+"+1", "R2" );
   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = 0.0;              // mm, aperture is reference plane
   z2 = z1 - mirror_length;

   // Mirrors are characterized by constant length

   r1_arr = double(r1_arr);

   r2_arr = r1_arr; // just array definition
   Mirror_anglearr = r1_arr; // just array definition
   nmir = numberof( r1_arr );
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      beta = get_beta( alpha, Zfocus, r1_arr(mir), mirror_length );
      Mirror_anglearr(mir) = 2*alpha + beta;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r1_arr(mir); // required by 'rcon'
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_mirdiag */

func mt_mirdiag( om_file, rr=, zr=, gl=, over=, z_offset=, phi= )
/* DOCUMENT mt_mirdiag, om_file, rr=, zr=, gl=, over=, z_offset=, phi=

   "Mirror Diagram" showing placements of mirrors and baffles

   Reads data from 'om_file'; if it is not given then data
   from memory will be used.

   Keywords: rr    Range in radius, a two element array
             zr    Range in z-direction, defaults to 10% outside mirrors
             gl    Show guide lines as well
             over  'Overplot' disregard 'rr' and 'zr' and plot on
                       existing frame and window
             z_offset Additive change of Z
             phi   azimuth angle [rad] - required if mirror deformations
                      are to be included  as indicated in 'Use_mdeform'

   2008-12-03/NJW
   2008-12-09/NJW, keywords zr, over, and z_offset
*/
{
// ynclude = zaq
  extern  Acoef,                N_mirrors,            Use_mdeform, \
          Acoefarr,             Opt_module_file,      Z1_mirror, \
          Dcoef,                R1_mirror,            Z1arr, \
          Dcoefarr,             R1arr,                Z2arr, \
          Fcoef,                R2arr,                Zb1iarr, \
          Mirror_angle,         Rb1iarr,              Zb1oarr, \
          Mirror_anglearr,      Rb1oarr,              Zb2iarr, \
          Mirror_number,        Rb2iarr,              Zb2oarr, \
          Mirror_thicknessarr,  Rb2oarr,              Zfocus, \
          Modtype;
// yxclude =

   local fh, nrows;

   if( typeof(om_file) == "string" ) {
      if( !file_test(om_file) ) {
         write,format="Opt mod file: %s does not exist\n", om_file;
         return;
      }
      dol = om_file+"+1";
      ptr = rdfitsbin( dol, fh, nrows );
      Modtype = fxpar(fh,"MODTYPE");
      r1 = *ptr(fits_colnum(fh,"r1"));
      r2 = *ptr(fits_colnum(fh,"r2"));
      z1 = *ptr(fits_colnum(fh,"z1"));
      z2 = *ptr(fits_colnum(fh,"z2"));
      rb1i = *ptr(fits_colnum(fh,"rb1i"));
      rb1o = *ptr(fits_colnum(fh,"rb1o"));
      rb2i = *ptr(fits_colnum(fh,"rb2i"));
      rb2o = *ptr(fits_colnum(fh,"rb2o"));
      zb1i = *ptr(fits_colnum(fh,"zb1i"));
      zb1o = *ptr(fits_colnum(fh,"zb1o"));
      zb2i = *ptr(fits_colnum(fh,"zb2i"));
      zb2o = *ptr(fits_colnum(fh,"zb2o"));
      mthick_arr = *ptr(fits_colnum(fh,"mthick"));
      if( Modtype == "parabolic" ) {
         Dcoefarr = *ptr(fits_colnum(fh,"dcoef"));
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "hyperbolic" ) {
         Acoefarr = *ptr(fits_colnum(fh,"acoef"));
         Fcoef = fxpar( fh, "FCOEF" );
         Zfocus = fxpar( fh, "ZFOCUS" );
      } else if( Modtype == "conical" ) {
         Mirror_anglearr = *ptr(fits_colnum(fh,"mirror_angle"));
      } else error,"Unrecognized type of module";
   } else {
      om_file = Opt_module_file;
      r1 = R1arr;
      r2 = R2arr;
      z1 = Z1arr;
      z2 = Z2arr;
      rb1i = Rb1iarr;
      rb1o = Rb1oarr;
      rb2i = Rb2iarr;
      rb2o = Rb2oarr;
      zb1i = Zb1iarr;
      zb1o = Zb1oarr;
      zb2i = Zb2iarr;
      zb2o = Zb2oarr;
      mthick_arr = Mirror_thicknessarr;
      nrows = N_mirrors;
   }

   if( Use_mdeform && is_void(phi) ) {
      write,"MT_MIRDIAG Warning: phi set to zero!";
      phi = 0.0;
   }
   if( is_void(z_offset) ) z_offset = 0.0;
   rmin = min(r2);
   rmax = max(r1);
   if( is_void(rr) ) rr = [rmin - 0.05*(rmax-rmin), rmax + 0.05*(rmax-rmin)];
   zmin = min(min(zb2i),min(zb2o));
   zmax = max(max(zb1i),max(zb1o));
   if( is_void(zr) ) zr = [zmin - 0.05*(zmax-zmin), zmax + 0.05*(zmax-zmin)];
   if( !over ) {
      //+ window,0,style="boxed.gs";
      ttl = esc_underscore(om_file);
      if( Use_mdeform ) ttl += swrite(format=", phi = %5.3f",zero2pi(phi));
      plot,[0],xr=rr, yr=zr+z_offset, title=ttl, \
             xtitle="Radius [mm]", ytitle="Z-coordinate [mm]";
   }

   if( Use_mdeform ) { // set the name of the radius function
      if( Modtype == "parabolic" ) {
         funcname = rpar;
      } else if( Modtype == "hyperbolic" ) {
         funcname = rhyp;
      } else if( Modtype == "conical" ) {
         funcname = rcon;
      } else error,"Bad Modtype string";
   }

   for( mir = 1; mir <= nrows; mir++ ) {
      Mirror_number = mir; // for communication with rpar, rhyp, or rcon functions
      // The nominal mirror itself:
      oplot,[r1(mir),r2(mir),r2(mir)+mthick_arr(mir),r1(mir)+mthick_arr(mir),r1(mir)], \
            [z1(mir),z2(mir),z2(mir),z1(mir),z1(mir)]+z_offset,li=1+Use_mdeform;
      xyouts,r1(mir)+0.5*mthick_arr(mir),z1(mir)+z_offset+0.02*(z1(mir)-z2(mir)),itoa(mir),align=0.5,charsize=0.5;
      if( Use_mdeform ) { // Add the 'real' mirror
         if( Modtype == "parabolic" ) {
            Dcoef = Dcoefarr(mir);
         } else if( Modtype == "hyperbolic" ) {
            Acoef = Acoefarr(mir);
         } else if( Modtype == "conical" ) {
            Mirror_angle = Mirror_anglearr(mir);
            R1_mirror = r1(mir);
            Z1_mirror = z1(mir);
         }
         zarr = span(z1(mir),z2(mir),200);
         rarr = array(double,200);
         for( j = 1; j <= 200; j++ ) rarr(j) = funcname( zarr(j), phi );
         oplot,rarr,zarr+z_offset;
      }
      if( gl ) { // add guidelines
         oplot,[r2(mir),r2(mir)],[z1(mir),z2(mir)]+z_offset,li=2,color="yellow";
         oplot,[r1(mir),r1(mir)]+mthick_arr(mir),[z1(mir),z2(mir)]+z_offset,li=2,color="magenta";
      }
      // Upper baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb1i(mir)],[zb1i(mir),zb1i(mir)]+z_offset,thick=3,color="red";
      }
      //+ oplot,[rb1o(mir-1),rb1i(mir)],[zb1o(mir-1),zb1i(mir)]+z_offset,thick=3,color="red";
      if( mir < nrows ) {
         oplot,[rb1o(mir),rb1i(mir+1)],[zb1o(mir),zb1i(mir+1)]+z_offset,thick=3,color="red";
      } else {
         oplot,[rb1o(mir),r1(mir)+mthick_arr(mir)],[zb1o(mir),zb1o(mir)],thick=3,color="red";
      }
      // Lower baffle for current mirror
      if( mir == 1 ) { // add one if first mirror
         oplot,[0,rb2i(mir)],[zb2i(mir),zb2i(mir)]+z_offset,thick=3,color="blue";
      }
      //+ oplot,[rb2o(mir-1),rb2i(mir)],[zb2o(mir-1),zb2i(mir)]+z_offset,thick=3,color="blue";
      if( mir < nrows ) {
         oplot,[rb2o(mir),rb2i(mir+1)],[zb2o(mir),zb2i(mir+1)]+z_offset,thick=3,color="blue";
      } else {
         oplot,[rb2o(mir),r2(mir)+mthick_arr(mir)],[zb2o(mir),zb2o(mir)],thick=3,color="blue";
      }

   }
}

/* Function mt_upd_om */

func mt_upd_om( void )
/* DOCUMENT mt_upd_om

   Update data for an optical module in memory after
   a call of 'mt_load'

   2008-12-03/NJW
*/
{
// ynclude = zar
  extern  N_mirrors,  R2arr,      Rb1oarr,    Rb2oarr,    Zb1oarr,    Zb2oarr, \
          R1arr,      Rb1iarr,    Rb2iarr,    Zb1iarr,    Zb2iarr;
// yxclude =

   write,"Commands: czu - change z for upper baffles";
   write,"          czl - change z for lower baffles";
   write,"          csu - change slits for upper baffles";
   write,"          csl - change slits for lower baffles";

   command = "";
   read,prompt="Enter command : ... ", command;

   if( command == "czu" ) {
      delta = 0.0;
      read,prompt="Enter delta for upper baffles [mm] : ... ", delta;
      Zb1iarr += delta;
      Zb1oarr += delta;
      kwds_set,"CZU_PAR", delta,"[mm] Change Z of upper baffles";
   } else if( command == "czl" ) {
      delta = 0.0;
      read,prompt="Enter delta for lower baffles [mm] : ... ", delta;
      Zb2iarr += delta;
      Zb2oarr += delta;
      kwds_set,"CZL_PAR", delta,"[mm] Change Z of lower baffles";
   } else if( command == "csu" ) {
      write,"Define a slit opening width as a fraction in percent of the";
      write,"mirror separation and the position of the slit again as a";
      write,"percentage fraction of the mirror separation";
      frac = 0.0;
      pos  = 0.0;
      read,prompt="Enter percentage opening for upper baffles : ... ", frac;
      frac /= 100.;
      read,prompt="Enter percentage slit position upper baffles : ... ", pos;
      pos /= 100.;
      d = R1arr - R2arr;
      p = R2arr + pos*d;
      Rb1oarr = p + 0.5*frac*d;
      Rb1iarr = p - 0.5*frac*d;
      kwds_set,"CSU_PAR1", frac,"Fractional opening of upper baffle slits";
      kwds_set,"CSU_PAR2", pos,"Fractional position of upper baffle slits";
   } else if( command == "csl" ) {
      frac = 0.0;
      read,prompt="Enter percentage for lower baffles : ... ", frac;
      frac /= 100.;
      for( mir = 1; mir < N_mirrors; mir++ ) {
         opening = Rb2oarr(mir) - Rb2iarr(mir);
         Rb2iarr(mir) += frac*opening/2;
         Rb2oarr(mir) -= frac*opening/2;
      }
      kwds_set,"CSU_PAR", frac,"Fractional change upper baffle slits";
   } else {
      write,"Unknown command - quit";
      return;
   }
   kwds_set,"HISTORY","Updated with mt_upd_om";

}
/* Function mt_write_om */

func mt_write_om( out_file, updn= )
/* DOCUMENT mt_write_om, out_file, updn=

   Get data for an optical module in memory after
   a call of 'mt_load' and write to a (new) optical
   module file keeping the original keywords.

   If 'out_file' is not given then a (suitable) name
   will be constructed.

   Keyword 'updn' (Update name) will update external variable
                  'Om_files(updn)' with name of new file.

   2008-12-03/NJW
*/
{

// ynclude = zas
  extern  Mirror_anglearr,  R1arr,            Rb2iarr,          Zb1iarr, \
          Mirror_coating,   R2arr,            Rb2oarr,          Zb1oarr, \
          Om_files,         Rb1iarr,          Z1arr,            Zb2iarr, \
          Opt_module_file,  Rb1oarr,          Z2arr,            Zb2oarr;
// yxclude =

   if( is_void(out_file) ) {
      pos = strpos( Opt_module_file, ".fits", 0, rev=1 );
      if( pos ) {
         if( is_digit(strpart( Opt_module_file,pos-3:pos-1)) \
              && strpart(  Opt_module_file,pos-4:pos-4 ) == "_" ) pos -= 4;
         out_file = get_next_filename( \
          strpart(Opt_module_file,1:pos-1)+"_???.fits");
      } else out_file = get_next_filename( Opt_module_file+"_???" );
   }

   kwds_set,"HISTORY","Written by mt_write_om";
   kwds_set,"DATE",ndate(3),"Date/time of file creation";
   wrmfitscols, out_file, "R1",R1arr,"R2",R2arr,"Z1",Z1arr,"Z2",Z2arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",Z1arr-Z2arr,"COATING", \
        Mirror_coating, \
       "RB1I", Rb1iarr, "RB1O", Rb1oarr, "RB2I", Rb2iarr, "RB2O", Rb2oarr, \
       "ZB1I", Zb1iarr, "ZB1O", Zb1oarr, "ZB2I", Zb2iarr, "ZB2O", Zb2oarr, \
        clobber=1;
   write,format="Memory OM content written to: %s\n", out_file;
   if( updn ) {
      Om_files(updn) = out_file;
      write,format="Om_files(%i) changed to: %s\n", updn, out_file;
   }
}

/* Function mt_propagate */

func mt_propagate( znew, iphot )
/* DOCUMENT mt_propagate, znew, iphot

   Propagates photon number 'iphot' to the new z-value
   if 'iphot' is given, else it will propagate all
   photons in memory i.e. struct Phs to a plane
   with given z value (znew).

   2008-12-03/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      cR = Phs.R;
      t = (znew - cE(3,)) / cR(3,);
      cE += t(-:1:3,)*cR;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      cR = Phs(iphot).R;
      t = (znew - cE(3)) / cR(3);
      cE += t*cR;
      Phs(iphot).E = cE;
   }
}

/* Function _propa */

func _propa( startpos, direc, endz )
/* DOCUMENT endpos = _propa( startpos, direc, endz )

     startpos is a 3-elem array with initial position
     direc    is a 3-elem array with direction
     endz     is a scalar with final z position (3. dim)

     Note that backwards movement is silently accepted.

*/
{
   if( direc(3) == 0.0 ) return []; // never going to make it
   t = (endz - startpos(3))/direc(3);
   return startpos + t*direc;
}

/* Function mt_drayplot */

func mt_drayplot( iphot, over= )
/* DOCUMENT mt_drayplot, iphot, over=

   Plots the ray on both modules

   Keyword 'over' for overplotting

   Version 1.3 2008-12-04/NJW
   Version 3.3 2011-03-10/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zat
  extern  N_mirrors,    R1arr,        Rb2iarr,      Z_reference,  Zb2iarr, \
          Num_modules,  R2arr,        Z1arr,        Zb1iarr,      Zb2oarr, \
          Om_files,     R2arr,        Z2arr,        Zb1oarr,      Zfocusarr, \
          Phs;
// yxclude =
  /*
   *   The coordinate system issue
   *   Presented (?) in the telescope system
   */

   if( Num_modules != 2 ) {
      write,"This function only works when there are two modules defined.";
      return;
   }
   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }
   mir = phs.mirror;

   // Deal with upper optical module

   mt_load,omfile=Om_files(1);
   // define the plotting range upper value
   step = mir == N_mirrors ? R1arr(mir) - R1arr(mir-1) : R1arr(mir+1) - R1arr(mir);
   rr = array(double,2);
   rr(2) = R1arr(mir) + 0.5*step;
   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   // set the local maximum in Z
   zmax = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir)) + z_offset;
   // set the local minimum in Z
   zmin_local = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir));
   exit_aperture = Z_reference(1) + zmin_local;

   // Deal with lower optical module

   mt_load,omfile=Om_files(2);
   // define the plotting range lower value
   rr(1) = Rb2iarr(mir) - 0.5*step;
   z_offset =  - Zfocusarr(2);
   // set the local minimum in Z
   zmin = min(Zb2iarr(mir),Zb2oarr(mir),Z2arr(mir)) + z_offset;
   // set the local maximum in Z
   zmax_local = max(Zb1iarr(mir),Zb1oarr(mir),Z1arr(mir));
   dz = zmax - zmin;
   zr = [zmin-0.05*dz, zmax+0.05*dz];
   entrance_aperture = Z_reference(2) + zmax_local;

   gap = exit_aperture - entrance_aperture;
   xtend = gap > 0.5 ? 0.5*gap : 0.0;

   if( !over ) {
      //+ window,0,style="boxed.gs";
      plot,[0],xr=rr,yr=zr,xtitle="Radius [mm]", ytitle="Z from focal plane [mm]";
   }


   z_offset = Z_reference(1) - Z_reference(2) - Zfocusarr(2);
   mt_rayplot, iphot, 1, z_offset=z_offset, over=1, xtend=-xtend;


   z_offset =  - Zfocusarr(2);
   mt_rayplot, iphot, 2, z_offset=z_offset, over=1, xtend=xtend;

}

/* Function mt_rayplot */

func mt_rayplot( iphot, mod_num, over=, z_offset=, xtend= )
/* DOCUMENT mt_rayplot, iphot, mod_num, over=, z_offset=, xtend=

   Plots the ray on the appropriate module section

   Keyword  'over' : Overplot
            'z_offset' : Additive coordinate change in Z
            'xtend' : Extend the ingoing (xtend > 0) or outgoing ray (xtend < 0)

   Version 1.5 2008-12-04/NJW
   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zau
  extern  Mirror_deform_files,  Om_files,             R1arr, \
          N_mirrors,            Phs,                  Use_mdeform;
// yxclude =

   phs = Phs(iphot);
   if( phs.mirror == 0 ) {
      write,"No mirror has been selected - quit";
      return;
   }

   if( is_void(z_offset) ) z_offset = 0.0;

   status = phs.status;
   bounce = phs.bounce;
   mir = phs.mirror;
   mt_load,omfile=Om_files(mod_num);
   if( Use_mdeform ) mt_load,mdeffile=Mirror_deform_files(mod_num);
   rr = mir == 1 ? [R1arr(mir) - 3, R1arr(mir) + 2] : [R1arr(mir-1) - 2, R1arr(mir) + 2];
   // determine azimuth, use E1 if no bounce, I1 if bounce
   x = phs.E1(1); y = phs.E1(2);
   if( bounce%2 == 1 ) { x = phs.I1(1); y = phs.I1(2); }
   phi = zero2pi(atan(y,x));
   xyouts,0.2,0.87,swrite(format="Phi: %8.5f rad",phi),charsize=1.,ndc=1;
   mt_mirdiag, rr=rr, over=over, z_offset=z_offset, phi=phi;

   if( mod_num == 1 ) { // first optical module
     /*
      *    Did it bounce ?
      */
      if( bounce%2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E1, phs.D1, phs.I1(3), z_offset=z_offset;

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            error,"##24##";
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            error,"##25##";
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            error,"##26##";
         } else if( status == 4 ) { // blocked by next mirror edge
            error,"##27##";
         } else if( status == 5 ) { // blocked by mirror edge
            error,"##28##";
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) { // blocked by second reflection on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##29##";

      } else {  //    No bounce situation

         if( status == 0 || status > 100 ) { // valid path through first module
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 1 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 2 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 3 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 4 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 5 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E1(1)^2+phs.E1(2)^2)],[phs.E1(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 6 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 7 ) {
            error,"##29##";
         } else if( status == 8 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 9 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 10 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 11 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E1, phs.D2, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##30##";

      }


   } else if( mod_num == 2 ) { // second optical module
     /*
      *    Did it bounce ?
      */
      if( bounce/2 == 1 ) { // yes - it did

         // General: draw from entrance to interaction
         _odraw_ab, phs.E2, phs.D2, phs.I2(3), z_offset=z_offset;

         if( status == 0 ) { // valid path through second module
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            error,"##31##";
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            error,"##32##";
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            error,"##33##";
         } else if( status == 104 ) { // blocked by next mirror edge
            error,"##34##";
         } else if( status == 105 ) { // blocked by mirror edge
            error,"##35##";
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflections on same mirror
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from interaction to exit
            _odraw_ab, phs.I2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else error,"##36##";

      } else {  //    No bounce situation

         if( status == 0 ) { // valid path through second module
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.D2, Zb2oarr(mir), z_offset=z_offset;

         } else if( status == 101 ) { // blocked by entrance spoke
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=22,symsize=0.5;
         } else if( status == 102 ) { // blocked by entrance baffle, inner
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=23,symsize=0.5;
         } else if( status == 103 ) { // blocked by entrance baffle, outer
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=24,symsize=0.5;
         } else if( status == 104 ) { // blocked by next mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=25,symsize=0.5;
         } else if( status == 105 ) { // blocked by mirror edge
            oplot,[sqrt(phs.E2(1)^2+phs.E2(2)^2)],[phs.E2(3)]+z_offset,ps=26,symsize=0.5;
         } else if( status == 106 ) { // blocked by next mirror's backside
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 107 ) { // blocked by second reflection on same mirror
            // should not happen
            error,"##33##";
         } else if( status == 108 ) { // blocked by "behind the mirror"
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 109 ) { // blocked by exit baffle, inner
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 110 ) { // blocked by exit baffle, outer
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } else if( status == 111 ) { // blocked by exit spoke
            // draw from entrance to exit
            _odraw_ab, phs.E2, phs.R, Zb2oarr(mir), z_offset=z_offset;
         } // else draw nothing since it never entered the second module

      }

   } else error,"##38##";



}

/* Function _odraw_ab */

func _odraw_ab( startpos, direc, endz, z_offset=, mark= )
/* DOCUMENT _odraw_ab, startpos, direc, endz, z_offset=, mark=

     Overdraw from start position to end position. The latter is found
     by the interception pos(3) == endz.
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   endpos = _propa( startpos, direc, endz );
   // rotate around z-axis
   rotangle = atan(endpos(2),endpos(1));
   rotmat = [[cos(rotangle),-sin(rotangle),0.],[sin(rotangle),cos(rotangle),0.],[0.,0.,1.]];
   prot = rotmat(,+)*endpos(+);
   r2 = prot(1);
   z2 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=13,symsize=0.5;
   prot = rotmat(,+)*startpos(+);
   r1 = prot(1);
   z1 = prot(3);
   if(mark)oplot,[r2],[z2]+z_offset,ps=22,symsize=0.5;
   oplot, [r1,r2],[z1,z2]+z_offset,color="green";
}

/* Function _odraw_ray */

func _odraw_ray( p_refl, ray1, ray2, z_offset=, xtend=, mark= )
/* DOCUMENT _odraw_ray, p_refl, ray1, ray2, z_offset=, xtend=, mark=
*/
{
   if( is_void(xtend) ) xtend = 0.0;
   if( is_void(z_offset) ) z_offset = 0.0;
   p = p_refl; // point of reflection or absorption in 3D
   rotangle = atan(p(2),p(1));
   rotmat = [[cos(rotangle),-sin(rotangle)],[sin(rotangle),cos(rotangle)]];
   pxy = p(1:2); // reduced to 2D for matrix multiplication
   prot = rotmat(,+)*pxy(+);
   r = prot(1);
   z = p(3);
   if(mark)oplot,[r],[z]+z_offset,ps=13,symsize=0.5;

   // vector pointing back

   z1 = xtend > 0.0 ? Z1arr(m) + xtend : Z1arr(m);
   t = (z1 - z)/(-ray1(3));
   p1 = p + t*(-ray1); // point at aperture, original coord. syst.
   pxy = p1(1:2);
   prot = rotmat(,+)*pxy(+);
   r1 = prot(1);
   z1 = p1(3);
   oplot,[r,r1],[z,z1]+z_offset,color="green";

   // vector pointing forward

   if( !is_void(ray2) ) {

      z2 = xtend < 0.0 ? Z2arr(m) + xtend : Z2arr(m);
      t = (z2 - z)/ray2(3);
      p2 = p + t*ray2;
      pxy = p2(1:2);
      prot = rotmat(,+)*pxy(+);
      r2 = prot(1);
      z2 = p2(3);
      oplot,[r,r2],[z,z2]+z_offset,color="green";

   }
}

/* Function mt_create_om_con4 */

func mt_create_om_con4( a, filename= )
/* DOCUMENT mt_create_om_con4, filename=

   Create Optical Module of type conical 1-alpha
   - constant length mirrors
   - Om_parameter controlled leak for on-axis radiation

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   The reference surface (origin of z-axis) is at module
   entrance plane.

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zav
  extern  Mirror_angle,            R1arr,                   Z1_setups, \
          Mirror_lengths,          R2arr,                   Z2_setups, \
          Mirror_thickness_files,  R_outer,                 Z_reference, \
          Om_parameters,           Version,                 Zfocus, \
          R1_mirror, Telescop,     Z1_mirror, Instrume,     Zfocusarr;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con4_???.fits");

   mirror_length = Mirror_lengths(1);
   if( is_void(Z1_setups) ) error,"mt_create_om_con4: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con4: Z2_setups is missing";
   z1_setup = Z1_setups(1);
   z2_setup = Z2_setups(1);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con4: mismatch";

  /*
   * The reference plane is placed inside the module
   * so that z1_setup > 0 and z2_setup < 0. Mirror length = z1_setup - z2_setup
   *
   * Define mirrors from outside inwards
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant
   *  mirror lengths.
   *  The aperture is to be exploited
   *  as well as possible.
   *
   */

   Zfocus = Zfocusarr(1); // mm, z-coordinate of focal point in module coord. syst.
   Z1_mirror = z1_setup; // mm, relative to reference plane
   r1 = R_outer;
   z1 = Z1_mirror;

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(1),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(1),"mirror_thickness",nomem=1,silent=1);

   // Mirrors are characterized by constant length

   a = r1; b = z1; c = abs(Zfocus);
   Mirror_angle = solvealpha( a, b, c);
   R1_mirror = r1;
   z2 = z1 - mirror_length;
   r2 = rcon(z2);
   r1_arr = [];
   r2_arr = [];
   z1_arr = [];
   z2_arr = [];
   mthick_arr = [];
   ma_arr = []; // for Mirror_angle
   coating = [];
   grow, r1_arr, r1;
   grow, r2_arr, r2;
   grow, z1_arr, z1;
   grow, z2_arr, z2;
   mirror_thickness = interp(mthick_thick,mthick_radius,r1);
   grow, mthick_arr, mirror_thickness;
   grow, ma_arr, Mirror_angle;
   grow, coating, 0;
   n_mirrors = 1;

   kwds_init;
   kwds_set,"ZREFRNCE",Z_reference(1),"[mm] Z coord. of refr. plane in tel.syst.";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point in opt.mod. syst.";
   kwds_set,"R_INNER",R_inner_design,"[mm] Inner radius";
   kwds_set,"R_OUTER",R_outer,"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper edge of mirrors";
   kwds_set,"MTCKFILE",Mirror_thickness_files(1),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"MODSTAT","Master","Defines the mirror positions";
   kwds_set,"PACKFACT", Om_parameters(1),"Loose packing factor, 1.0 means dense";
   kwds_set,"CREATOR","mt_create_om_con4","Function that created this file";
   kwds_set,"VERSION", Version, "Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";


   while( r1 > R_inner_design ) {

      n_mirrors++;

      //+ r1 = r2 - mirror_thickness;
      //+ "loose" packing with factor Om_parameters(1)
      r1 = r1 - Om_parameters(1)*(r1 - r2) - mirror_thickness;
      a = r1; b = z1; c = abs(Zfocus);
      Mirror_angle = solvealpha( a, b, c);
      R1_mirror = r1;

      r2 = rcon(z2);

      // add to arrays

      grow, r1_arr, r1;
      grow, r2_arr, r2;
      grow, z1_arr, z1;
      grow, z2_arr, z2;
      mirror_thickness = interp(mthick_thick,mthick_radius,r1);
      grow, mthick_arr, mirror_thickness;
      grow, ma_arr, Mirror_angle;
      grow, coating, 0;
   }

  /*
   *  Create the baffle parameters
   */

   //+ rb1i_arr = r2_arr;
   rb1i_arr = shift(r1_arr,1) + shift(mthick_arr,1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(-1) - rb1i_arr(-1);
   rb1i_arr(0) = r1_arr(0) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,1) + shift(mthick_arr,1);
   open_space = r2_arr(-1) - rb2i_arr(-1);
   rb2i_arr(0) = r2_arr(0) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table while reversing the order of the arrays
   */

   n = numberof(r1_arr);
   i = indgen(n:1:-1);
   wrmfitscols, filename, "R1",r1_arr(i),"R2",r2_arr(i),"Z1",z1_arr(i),"Z2",z2_arr(i), \
       "MIRROR_ANGLE",ma_arr(i),"MLENGTH",z1_arr(i)-z2_arr(i),"MTHICK",mthick_arr(i), "COATING",coating(i), \
       "RB1I", rb1i_arr(i), "RB1O", rb1o_arr(i), "RB2I", rb2i_arr(i), "RB2O", rb2o_arr(i), \
       "ZB1I", zb1i_arr(i), "ZB1O", zb1o_arr(i), "ZB2I", zb2i_arr(i), "ZB2O", zb2o_arr(i), \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", n_mirrors;
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function mt_create_om_con5 */

func mt_create_om_con5( filename=, master= )
/* DOCUMENT mt_create_om_con5, filename=, master=

   Create Optical Module of type conical 3-alpha (or rather 2alpha+beta)
   - constant length mirrors

   This is a 'slave'-module so the mirror radii at entrance
   are defined by the the first module (the master module).
   The master module is by default given in Om_files(1) as set up
   by 'mt_setup_system' from a system defining file.
   It can be overridden by giving another one in keyword 'master'.

   The photons move almost along the z-axis in the
   'negative direction' i.e. direction vector ~(0,0,-1).

   Updated to version 4.0  2011-08-25/NJW
*/
{

// ynclude = zaw
  extern  Mirror_angle,            Om_files,                Z2_setups, \
          Mirror_anglearr,         R1_mirror,               Z_reference, \
          Mirror_lengths,          Version,                 Zfocus, \
          Mirror_thickness_files,  Z1_mirror,               Zfocusarr, \
          Num_modules,             Z1_setups, Telescop, Instrume;
// yxclude =

   if( is_void(filename) ) filename = get_next_filename("om_con_???.fits");

   mirror_length = Mirror_lengths(2);
   if( is_void(Z1_setups) ) error,"mt_create_om_con5: Z1_setups is missing";
   if( is_void(Z2_setups) ) error,"mt_create_om_con5: Z2_setups is missing";
   z1_setup = Z1_setups(2);
   z2_setup = Z2_setups(2);
   if( abs(mirror_length-(z1_setup-z2_setup)) > 0.2 ) error,"mt_create_om_con5: mismatch";

  /*
   *   Consistency check
   */

   if( is_void(Num_modules) ) {
      write,"External Num_modules not set - did you run mt_setup_system ?";
      return [];
   }
   if( numberof(Z_reference) != Num_modules ) {
      write,"Inconsistency between externals Z_reference and Num_modules";
      return [];
   }
   if( is_void(master) ) master = Om_files(1);
   if( ! file_test( master ) ) {
      write,format="Master opt. mod. file: %s was not found\n", master;
      return [];
   }

  //  Read arrays in mirror thickness file

   mthick_radius = rscol(Mirror_thickness_files(2),"radius",nomem=1,silent=1);
   mthick_thick  = rscol(Mirror_thickness_files(2),"mirror_thickness",nomem=1,silent=1);

  /*
   *! Define mirrors from inside outwards
   *
   *
   *  The photons meets first z1 at entrance and then z2 at exit
   *
   *    r1 is the radius of the reflecting surface at z1
   *    r2 is the radius of the reflecting surface at z2
   *    Therefore: z2 < z1 and r2 < r1
   *
   *  Baffle slits. Conditions are:
   *          At z = zb1i :  r > rb1i
   *      and at z = zb1o :  r < rb1o
   *      and at z = zb2i :  r > rb2i
   *      and at z = zb2o :  r < rb2o
   *
   *
   *  The mirror section defined with this code has constant mirror lengths.
   *  The aperture is to be exploited as well as possible.
   *
   */

   alpha1_arr = rdfitscol( master+"+1", "MIRROR_ANGLE" );

   // The conical 3-alpha optical module is number 2

   Zfocus = Zfocusarr(2); // mm, z-coordinate of focal point in module coord. syst.
   z1 = z1_setup;         // mm
   z2 = z1 - mirror_length;
   Z1_mirror = z1; // required by 'rcon'

   // Mirrors are characterized by constant length

   nmir = numberof( alpha1_arr );
   r1_arr = array(double,nmir);

   dz_ref_first_focus = -Zfocusarr(1) - (Z_reference(1) - Z_reference(2));

   r2_arr = array(double, nmir);
   Mirror_anglearr = array(double, nmir);
   z1_arr = array(z1, nmir);
   z2_arr = array(z2, nmir);
   for( mir = 1; mir <= nmir; mir++ ) {
      alpha = alpha1_arr(mir);
      r3 = dz_ref_first_focus*tan(2*alpha); // Radius where pilot ray at reference plane hits the mirror
      twoema = atan(r3/abs(Zfocus));
      eps = 0.5*twoema + alpha;
      Mirror_anglearr(mir) = eps;
      Mirror_angle = Mirror_anglearr(mir); // required by 'rcon'
      R1_mirror = r3 + z1*tan(eps); // required by 'rcon'
      r1_arr(mir) = R1_mirror;
      r2_arr(mir) = rcon( z2 );
   }
   coating = array(0,nmir);

   mthick_arr = interp(mthick_thick,mthick_radius,r1_arr);

   kwds_init;
   kwds_set,"FCLENGTH",abs(Zfocus),"[mm] Focal length";
   kwds_set,"ZFOCUS",Zfocus,"[mm] Z coordinate of focus point";
   kwds_set,"R_INNER",r1_arr(0),"[mm] Inner radius";
   kwds_set,"R_OUTER",r1_arr(1),"[mm] Outer radius";
   kwds_set,"Z1SETUP",z1_setup,"[mm] Position of upper mirror edges";
   kwds_set,"MODSTAT","Slave","This is dependent on the first (master) module";
   kwds_set,"MASTER", master,"The opt-mod. that acts as master";
   kwds_set,"MTCKFILE",Mirror_thickness_files(2),"Mirror thickness table file";
   kwds_set,"MIRLNGTH",mirror_length,"[mm] mirror length";
   kwds_set,"DESIGN","Constant mirror length","Telescope design type";
   kwds_set,"MODTYPE","conical","Type of mirror module";
   kwds_set,"CREATOR","mt_create_om_con5","Function that make this file";
   kwds_set,"VERSION", Version,"Version of mt_rayor package";
   kwds_set,"DATE",ndate(3),"Time of file creation";
   if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
   if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
   kwds_set,"TUNIT1","mm","Unit for column 1";
   kwds_set,"TUNIT2","mm","Unit for column 2";
   kwds_set,"TUNIT3","mm","Unit for column 3";
   kwds_set,"TUNIT4","mm","Unit for column 4";
   kwds_set,"TUNIT5","rad","Unit for column 5"; // mirror angle
   kwds_set,"TUNIT6","mm","Unit for column 6";
   kwds_set,"TUNIT7","mm","Unit for column 7";
    // column 8 is the coating number (dimensionless)
   kwds_set,"TUNIT9","mm","Unit for column 9";
   kwds_set,"TUNIT10","mm","Unit for column 10";
   kwds_set,"TUNIT11","mm","Unit for column 11";
   kwds_set,"TUNIT12","mm","Unit for column 12";
   kwds_set,"TUNIT13","mm","Unit for column 13";
   kwds_set,"TUNIT14","mm","Unit for column 14";
   kwds_set,"TUNIT15","mm","Unit for column 15";
   kwds_set,"TUNIT16","mm","Unit for column 16";

  /*
   *  Create the baffle parameters
   */

  /*
   *  Standard definition of rb1i is backside of next mirror
   *  at z = z1
   */
   rb1i_arr = shift(r1_arr,-1) + shift(mthick_arr,-1);
   // Special action for innermost baffle slit that is
   // assumed to have the same opening as its neighbor
   open_space = r1_arr(2) - rb1i_arr(2);
   rb1i_arr(1) = r1_arr(1) - open_space;
   rb1o_arr = r1_arr;
   zb1i_arr = z1_arr;
   zb1o_arr = z1_arr;

   rb2i_arr = shift(r2_arr,-1) + shift(mthick_arr,-1);
   open_space = r2_arr(2) - rb2i_arr(2);
   rb2i_arr(1) = r2_arr(1) - open_space;
   rb2o_arr = r2_arr;
   zb2i_arr = z2_arr;
   zb2o_arr = z2_arr;

  /*
   *  create the FITS binary table
   */

   wrmfitscols, filename, "R1",r1_arr,"R2",r2_arr,"Z1",z1_arr,"Z2",z2_arr, \
       "MIRROR_ANGLE",Mirror_anglearr,"MLENGTH",z1_arr-z2_arr,"MTHICK", mthick_arr, "COATING",coating, \
       "RB1I", rb1i_arr, "RB1O", rb1o_arr, "RB2I", rb2i_arr, "RB2O", rb2o_arr, \
       "ZB1I", zb1i_arr, "ZB1O", zb1o_arr, "ZB2I", zb2i_arr, "ZB2O", zb2o_arr, \
        clobber=1;
   write,format="The conical system optical module file: %s has just been created\n", filename;
   write,format="It has %i mirrors\n", numberof(r1_arr);
   write,format="and it might need a coating update: %s\n","mt_upd_om_coating,...";

}

/* Function solvealpha */

func solvealpha ( a, b, c )
/* DOCUMENT alpha = solvealpha( a, b, c )

   Solve the equation:

   tan(2alpha) = (a - b tan(alpha))/c
      where c >> a  and c >> b

   by iterations and return the value of alpha

   2008-12-05/NJW
*/
{
   alpha = 1.0;
   alpha_prev = 0.0;

   while( abs(alpha - alpha_prev) > 1.e-10 ) {
      alpha_prev = alpha;
      tan2a = (a - b*tan(alpha_prev))/c;
      alpha = 0.5*atan(tan2a);
   }

   return alpha;
}

/* Function mt_stat */

func mt_stat( status, w= )
/* DOCUMENT s = mt_stat( status, w= )

   status is void: print statistics and return total
                         number of photons
   else
     w is void returns number of photons with given status
     else returns 'where' array

   Version 1.6   2008-12-17/NJW
   Version 3.0   2011-01-17/NJW
*/
{
   extern Phs;

   statarr = [0,1,2,3,4,5,6,7,8,9,10,11, \
              101,102,103,104,105,106,107,108,109,110,111,201];
   nstatarr = numberof(statarr);

   wstatus = Phs.status;
   s = [];
   for( i = 1; i <= nstatarr; i++ ) {
      if( numberof(where(wstatus==statarr(i))) ) grow, s, statarr(i);
   }
   statarr = s;
   nstatarr = numberof(statarr);

   if( is_void(status) ) {
      // Make condensed printout for the log file.
      s = "Stat ";
      for(i = 1; i <= (nstatarr+1)/2; i++ ) {
         s += swrite(format="%i:%i", statarr(i), numberof(where(wstatus==statarr(i))));
         if( i < (nstatarr+1)/2 ) s += ", ";
      }
      t = "Stat ";
      for(j = i; j <= nstatarr; j++ ) {
         t += swrite(format="%i:%i", statarr(j), numberof(where(wstatus==statarr(j))));
         if( j < nstatarr ) t += ", ";
      }
      mt_log_entry,2,s,t;

      // Make overview for terminal output.
      for(i = 1; i <= nstatarr; i++ ) {
         w = where(wstatus==statarr(i));
         n = numberof(w);
         write,format="Status %4i: %9i\n", statarr(i), n;
         if( statarr(i) == 0 && n > 0 ) {
            write,format="         Of these%s\n",":";
            n = numberof(where(Phs(w).bounce == 0));
            write,format="            %9i with no bounces\n", n;
            n = numberof(where(Phs(w).bounce == 1));
            write,format="            %9i with only OM1 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 2));
            write,format="            %9i with only OM2 bounce\n", n;
            n = numberof(where(Phs(w).bounce == 3));
            write,format="            %9i with two bounces\n", n;
         }
      }
      return numberof(Phs);
   } else {
      if( is_void(w) ) {
         return numberof(where(Phs.status == status));
      } else {
         return where(Phs.status == status);
      }
   }
}

/* Function mt_mirror_deform */

func mt_mirror_deform( z, phi )
/* DOCUMENT  delta_r = mt_mirror_deform( z, phi )

   Returns the perturbation of the mirror due to deformations
   away from the deal shape.
   Assuming that 'z' is expressed in the local optical module
   coordinate system with origin in the reference plane.

   Computing the radius of the mirror surface

   r = r_ideal - delta_r

   2010-02-08/NJW
*/
{
// ynclude = zll
   extern Mirror_deform_arr, Mirror_length, Mirror_number;
// yxclude =

   dms = dimsof(Mirror_deform_arr);
   // Dim 1 is azimuth
   // Dim 2 is z (normalized to Mirror_length)
   // Dim 3 is number of mirror

   deform = Mirror_deform_arr(,,Mirror_number);

   phi = zero2pi(phi);
   azi_step = (2.*pi)/(dms(2)-1);
   i_azi = long(phi/azi_step) + 1;
   z_step = 1./(dms(3)-1);
   z_norm = (z - Z2arr(Mirror_number))/Mirror_length;
   i_z = long(z_norm/z_step) + 1;
   if( i_z >= dms(3) ) i_z = dms(3) - 1;
   if( i_z < 1 ) i_z = 1;

   // interpolate in azimuth
   deform = (deform(i_azi+1,)-deform(i_azi,))*(phi-azi_step*(i_azi-1))/azi_step + deform(i_azi,);
   // and then in z
   deform = (deform(i_z+1)-deform(i_z))*(z_norm-z_step*(i_z-1))/z_step + deform(i_z);

   return deform;

}

/* Function mt_mk_mdeform_file */

/*************************************************
 *
 *   Mirror deformation file generation
 *   for the MT_RAYOR package
 *
 *   2010-02-06/NJW
 *
 *   A 3D FITS image is produced with the third dimension
 *   as the mirror number. An Optical Module file is
 *   accompanied by a mirror deformation file (else "no deformation"
 *   is reported in a keyword).
 *   The first coordinate represents the azimuth angle as
 *   reported in the keywords CRPIX1, CRVAL1, CDELT1
 *   The unit must be radians.
 *   The second coordinate represents the z-value relative to the
 *   reference plane for the Optical Module. The scale given with
 *   keywords CRVAL and CDELT is normalized to -1 -> 0 since the
 *   mirror length may not be identical for all mirrors in a
 *   module. Hence a rescaling must be done in the application
 *   of the deformation values.
 *
 *   The image array value represents the deviation from the ideal
 *   surface with a negative sign.
 *
 *   Rule: With NAXISi CRPIXi = v_min, CDELTi = (v_max - v_min)/(NAXISi - 1),
 *         CRPIXi = 1  =>   v(j) = CRVALi + (j-CRPIXi)*CDELTi
 *                and     j = int((v - CRVALi)/CDELTi) + CRPIXi
 *
 *   For i == 1 (azimuth direction)
 *
 *       The first (0 radians) and last (2pi radians) values should
 *       be identical.
 *
 *   For i == 2 (along Z axis):
 *
 *       z(j) = (CRVAL2 + (j-CRPIX2)*CDELT2) * mirror_length
 *       j = int((z/mirror_length - CRVAL2)/CDELT2) + CRPIX2
 *
 ***************************************************/
func mt_mk_mdeform_file( filename, mode, param, nz=, naz=, arr= )
/* DOCUMENT arr = mt_mk_mdeform_file( mode, param, nz=, naz= )
     or mt_mk_mdeform_file, filename, mode, param, nz=, naz=, arr=

     In the first form the mirror deformation array is returned for
     inspection and perhaps further manipulation.

     In the second form (called as subroutine) a file is written with
     the 3D deformation array. The array may be given by keyword 'arr'
     in which case the only action is to write it to the disk. This
     functionality gives the opportunity to define the array by e.g.:

      > my_arr = mt_mk_mdeform_file( 1, 0.002, nz=50, naz=100 );
      > ... further manipulation of 'my_arr'
     saving the result by
      > mt_mk_mdeform_file,"my_arr.fits",arr=my_arr;

     mode    param
      1      amplitude            Parabolic shape, all mirrors identical
      2      [dt_bottom, dt_top]  Uniform temperature gradient
                                  i.e. conical mirrors but with a
                                  different slope (proportional to radius)
      3      amplitude/radius     Parabolic shape, the amplitude is
                                  proportional to the radius
      4      [amplitude, wavelength, phase] Sinusoidal single frequency
                                  perturbation amp*sin(phase + (2 pi z)/wavel)

     Keywords:
       nz    Number of points in the z-direction
       naz   Number of points in the azimuth direction (0 - 2pi)
       arr   3D array for storing.

   2010-02-08/NJW
   2010-06-22/NJW, updated with mode==2 temperature gradient
   2010-06-23/NJW, updated with mode==3 radius dependence
   2011-01-06/NJW, updated with mode==4 sinusoidal perturbation
*/
{
   extern N_mirrors, Z1arr, Z2arr;

   if( is_void(nz) ) nz = 30;
   if( is_void(naz) ) naz = 5
   zarr = span(-1.0,0,nz);

   build_arr = 1;
   if( !am_subroutine() ) {
      param = mode;
      mode = filename;
      arr = []; // N/A when called as a function
   } else {
      if( numberof(arr) ) {
         dms = dimsof(arr);
         if( dms(1) != 3 ) error,"Illegal dimension of 'arr'";
         // override setting of naz and nz
         naz = dms(2);
         nz = dms(3);
         build_arr = 0;
         garr = arr;
         param = 0.0;
         mode = 99;
      }
   }

   if( build_arr ) {
      if( mode == 1 ) { // Parabolic shape with amplitude 'param'
                        // all mirrors identical
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all azimuth
                                  // values and all mirrors
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Same amplitude for all mirrors";
      } else if( mode == 2 ) { // Temperature (constant) gradient
                         // 'param' is a 2-element array with
                         // param(1) as the delta-T at bottom and
                         // param(2) as delta-T at top
                         // A negative param(i) means that radii get smaller
         if( numberof(param) != 2 ) error,"'param' must have 2 elements";
         garr = array(double,naz,nz,N_mirrors);
         alpha_Al = 23.e-6; // per degree
         for( imir = 1; imir <= N_mirrors; imir++ ) {
            auxil = -param*alpha_Al*R1arr(imir);
            shape = interp(auxil,[-1.,0.],zarr);
            garr(,,imir) = shape(-:1:naz,); // copy to all azimuth values
         }
         kwds_set,"COMMENT","Constant temperature gradient along axis";
      } else if( mode == 3 ) { // Parabolic shape with amplitude
                               // radius*param i.e. different for
                               // each mirror
         if( numberof(param) != 1 ) error,"'param' must be a scalar";
         shape = 4*param*zarr*(zarr+1);
         garr = shape(-:1:naz,,-:1:N_mirrors); // copy to all az's and mirrors
         garr *= R1arr(-:1:naz,-:1:nz,);
         kwds_set,"COMMENT","Parabolic symmetrical shape";
         kwds_set,"COMMENT","Amplitude is proportional to mirror radius";

      } else if( mode == 4 ) { // Sinusoidal perturbation
                               // param is three-element array
                               // [amplitude, wavelength, phase]
         if( numberof(param) != 3 ) error,"'param' must be a 3-element array";
         shape = param(1)*sin(param(3) + zarr(,-:1:N_mirrors)*(Z1arr-Z2arr)(-:1:nz,)*2.*pi/param(2));
         garr = shape(-:1:naz,,); // copy to all az's
         kwds_set,"COMMENT","Sinusoidal perturbation";

      } else error,"This mode is not supported";
   }

   if( am_subroutine() ) { // File writing prepared

      crval1 = 0.0; crpix1 = 1.0; cdelt1 = 2.*pi/(naz-1);
      crval2 = -1.0; crpix2 = 1.0; cdelt2 = 1.0/(nz-1);
      crval3 = 0.0; crpix3 = 1.0; cdelt3 = 1.0;

      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_mk_mdeform_file","Producing software";
      kwds_set,"MODE",mode,"Parameter for deformation mode";
      if( numberof(param) == 1 ) {
         kwds_set,"PARAM",param,"Deformation parameter for applied mode";
      } else {
         for( i = 1; i <= numberof(param); i++ ) {
            kwds_set,"PARAM"+itoa(i),param(i),"Deformation parameter for applied mode";
         }
      }
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"EXTNAME","MIRROR_DEFORM","Name of extension";
      kwds_set,"CRVAL1", crval1,"Reference coordinate value 1";
      kwds_set,"CRPIX1", crpix1,"Reference pixel 1";
      kwds_set,"CDELT1", cdelt1,"Increment value 1";
      kwds_set,"CRVAL2", crval2,"Reference coordinate value 2";
      kwds_set,"CRPIX2", crpix2,"Reference pixel 2";
      kwds_set,"CDELT2", cdelt2,"Increment value 2";
      kwds_set,"CRVAL3", crval3,"Reference coordinate value 3";
      kwds_set,"CRPIX3", crpix3,"Reference pixel 3";
      kwds_set,"CDELT3", cdelt3,"Increment value 3";

      writefits,filename, garr, clobber=1;

   } else {

      return garr;

   }
}
/* Function mt_mirplot */

func mt_mirplot( mirror_number, phi, yr=, nz= )
/* DOCUMENT mt_mirplot, mirror_number, phi, yr=, nz=

   Plot the mirror surface as a function of Z in
   comparison to the straight line connecting the
   nominal mirror end radii.

   Keywords:    yr   plot range in y-direction
                       defaults to max(abs(deviation)) or 0.01,
                       whatever is largest
                nz   number of z-values, defaults to 100
*/
{
// ynclude = zax
  extern  Acoef,              Mirror_anglearr,    Modtype,            Use_mdeform, \
          Acoefarr,           Mirror_deform_arr,  R1_mirror,          Z1_mirror, \
          Dcoef,              Mirror_length,      R1arr,              Z1arr, \
          Dcoefarr,           Mirror_number,      R2arr,              Z2arr, \
          Mirror_angle;
// yxclude =

   if( is_void(Z1arr) ) {
      write,"No OM has been loaded - skip ...";
      return;
   }
   if( is_void(Use_mdeform) ) {
      Use_mdeform = (numberof(Mirror_deform_arr) > 0);
   }
   Mirror_number = mirror_number;
   z1 = Z2arr(mirror_number);
   z2 = Z1arr(mirror_number);
   if( Modtype == "parabolic" ) {
      funcname = rpar;
      Dcoef = Dcoefarr(Mirror_number);
   } else if( Modtype == "hyperbolic" ) {
      funcname = rhyp;
      Acoef = Acoefarr(Mirror_number);
   } else if( Modtype == "conical" ) {
      funcname = rcon;
      Mirror_angle = Mirror_anglearr(Mirror_number);
      R1_mirror = R1arr(Mirror_number);
      Z1_mirror = Z1arr(Mirror_number);
   } else error,"MT_MIRPLOT Illegal Modtype specification";

   if( is_void(nz) ) nz = 100;
   y = z = span(z1,z2,nz);
   yref = interp([R2arr(mirror_number),R1arr(mirror_number)],[z1,z2],z);

   Mirror_length = Z1arr(mirror_number) - Z2arr(mirror_number);
   for(i=1;i<=nz;i++) y(i) = funcname(z(i),double(phi));
   if( is_void(yr) ) {
      yamp = max(abs(y-yref));
      yr = (yamp < 0.01 ? 0.01 : 1.1*yamp)*[-1,1];
   }
   plot, z, yref - y,yr=yr,xtitle="Z [mm]", \
         ytitle="Line - R [mm]", title=Modtype+swrite(format=", phi = %5.3f rad",double(phi));
}

/* Function mt_detector */

/************************************************************
 *
 *  A function to convert the photons with status==0 from
 *  the photon list (external 'Phs') to events including
 *  detection probability, finite energy resolution (by the
 *  RDM matrix), and pixellation.
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_detector( offset=, cont=, bkglvl=, flag= )
/* DOCUMENT mt_detector, offset=, cont=, bkglvl=, flag=

   produces an event list from the existing photon list, Phs.
   based on the detector properties as defined in a detector
   description file. The detector properties are loaded by
   function 'mt_load' with keyword 'detfile'.

   Note that the RDM plays an active role in event rejection if its
   sum over detector channels is less than 1.

   Keywords: offset  - a 2 element array [dx,dy] in mm that shifts the
                       optical axis relative to the detector center.
             cont    - will cause a catenation of the Evlist in order to
                       combine several raytracing sessions e.g. to simulate
                       a situation with more sources in the FOV such as
                       an extended source
             bkglvl  - the background level which is the number of counts
                       per pixel per keV, i.e. NOT per second!. Will be
                       added to the event list (Evlist) with a flag value
                       of zero.
             flag    - the flag value for all raytraced events (i.e. not bkg)
                       defaults to 1

   SEE ALSO: mt_det_add_bkg, mt_det_image.
*/
{
// ynclude = zay
  extern  E_max,        Energ_lo,     Num_pixels2,  Qeff,         Xpixlo, \
          E_min,        Evlist,       Phs,          Rdm,          Ypixlims, \
          Energ_hi,     Num_pixels1,  Q_ener,       Xpixlims,     Ypixlo, \
          Det_offset, Dead_pixel_map;
// yxclude =

   if( is_void(offset) ) {
      Det_offset = [0.,0.];
   } else {
      if( numberof(offset) != 2 ) error,"Error in offset for mt_detector";
      Det_offset = double(offset);
   }
   if( is_void(bkglvl) ) bkglvl = 0.0;
   if( is_void(flag) ) flag = 1;


   sel = where( Phs.status == 0 );
   nphot = numberof(sel);
   evt = s_MTEvent();
   if(!cont) Evlist = [];
   for( i = 1; i <= nphot; i++ ) {
      // reject if outside detector
      if( Phs(sel(i)).E(1) < Xpixlims(1) || Phs(sel(i)).E(1) > Xpixlims(2) ) continue;
      if( Phs(sel(i)).E(2) < Ypixlims(1) || Phs(sel(i)).E(2) > Ypixlims(2) ) continue;
      // find quantum efficiency of the detector at the photon energy
      q = interp( Qeff, Q_ener, Phs(sel(i)).energy );
      // combine with telescope transmission coefficient
      trans = q * Phs(sel(i)).rcoef;
      // reject if random > trans
      if( random(1)(1) > trans ) continue;
      w = where( Energ_lo < Phs(sel(i)).energy );
      if( !numberof(w) ) continue; // reject, energy is too low
      if( Phs(sel(i)).energy > Energ_hi(0) ) continue; // reject, energy is too high
      j = w(0); // Energ_lo/hi channel
      p = Rdm(,j);
      psu = p(psum);
      // Note for the programmer: this could have been done to begin with i.e.
      // making a 'psu' array
      ptot = psu(0);
      // Decide if this should be rejected
      if( random(1)(1) > ptot ) continue; // 'ptot' is the probability
                                          // for acceptance in the detector channels
      if( psu(0) > 0.0 ) psu /= psu(0);  // normalize now that it has been accepted
      k = where( psu > random(1)(1) )(1); // channel number
      e_out = E_min(k) + (random(1)(1))*(E_max(k) - E_min(k));
      evt.energy = e_out;
      evt.pha = k;
      evt.phs_index = i;

      // now determine the pixel

      w = where(Xpixlo - Det_offset(1) < Phs(sel(i)).E(1));
      k = numberof(w) ? w(0) : 1;
      evt.rawx = k;
      evt.detx = Phs(sel(i)).E(1) + Det_offset(1); // relative to detector center
      w = where(Ypixlo - Det_offset(2) < Phs(sel(i)).E(2));
      k = numberof(w) ? w(0) : 1;
      evt.rawy = k;
      if( Dead_pixel_map(evt.rawx,evt.rawy) ) continue; // skip if landed on a dead pixel
      evt.dety = Phs(sel(i)).E(2) + Det_offset(2); // relative to detector center
      evt.flag = flag;
      grow, Evlist, evt;
   }

   if( bkglvl > 0.0 ) {
      nbkg = long(bkglvl * (E_max(0) - E_min(1)) * Num_pixels1 * Num_pixels2+0.5);
      bkg = array(s_MTEvent,nbkg);
      bkg.detx = random(nbkg)*Num_pixels1 - Num_pixels1/2.;
      bkg.rawx = long(bkg.detx + Num_pixels1/2. + 1);
      bkg.dety = random(nbkg)*Num_pixels2 - Num_pixels2/2.;
      bkg.rawy = long(bkg.dety + Num_pixels2/2. + 1);
      dead = where( Dead_pixel_map );
      if( numberof(dead) ) {
         idx = (bkg.rawy - 1) * Num_pixels1 + bkg.rawx;
         idx = whereany( idx, dead );
         bkg = rem_elem( bkg, idx );
         nbkg = numberof( bkg );
      }
      bkg.flag = 0;
      bkg.phs_index = -2;
      bkg.energy = random(nbkg)*(E_max(0) - E_min(1)) + E_min(1);
      for( i = 1; i <= nbkg; i++ ) {
         w = where( E_min < bkg(i).energy );
         bkg(i).pha = numberof(w) ? w(0) : 1;
      }
      grow, Evlist, bkg;
   }
}

/* Function mt_det_image */

/************************************************************
 *
 *  A function to make a detector image in a specified energy
 *  interval
 *
 *    2010-02-12/NJW
 *
 *************************************************************/

func mt_det_image( void, emin=, emax=, outfile=, bkglvl= )
/* DOCUMENT mt_det_image, emin=, emax=, outfile=, bkglvl=
       or   image = mt_det_image( emin=, emax=, outfile=, bkglvl= )

   returns a detector image based on the event list Evlist
   and the detector size as defined by a call of 'mt_detector'

   Keywords: emin    - minimum energy, defaults to E_min(1)
             emax    - maximum energy, defaults to E_max(0)
             outfile - name of output file for FITS image
             bkglvl  - average number of background counts per pixel
                       and per keV i.e. NOT per second will be
                       randomly distributed in position


*/
{
// ynclude = zaz
  extern  Dec_scx,       Evlist,        Num_pixels1,   Pixel_size1,   Ra_scx, \
          E_max,         Exposure,      Num_pixels2,   Posang,        Version, \
          E_min,         Focal_length, Det_offset;
// yxclude =

   nevs = numberof(Evlist);
   if( nevs == 0 ) {
      write,"No events in event list - skip";
      return [];
   }
   if( is_void(emin) ) emin = E_min(1);
   if( is_void(emax) ) emax = E_max(0);

   sel = where( Evlist.energy >= emin & Evlist.energy <= emax );
   if( (nsel = numberof(sel)) == 0 ) {
      write,"No events survived the energy selection - skip";
      return [];
   }
   im = array(int,Num_pixels1,Num_pixels2);
   for( i = 1; i <= nsel; i++ ) im(Evlist(sel(i)).rawx,Evlist(sel(i)).rawy)++;

   if( !is_void(bkglvl) ) {
      npix = Num_pixels1*Num_pixels2;
      nbkgcts = long(bkglvl*npix*(emax-emin)+0.5);
      x = long(random(nbkgcts)*Num_pixels1 + 1);
      y = long(random(nbkgcts)*Num_pixels2 + 1);
      for( i = 1; i <= nbkgcts; i++ ) im(x(i),y(i))++;
   } else bkglvl = 0.0;

   if( !is_void(outfile) ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mt_rayor(mt_det_image)","Software used";
      kwds_set,"VERSION",Version,"Version of mt_rayor";
      kwds_set,"BUNIT","cts/pixel","Unit of image pixel values";
      kwds_set,"CTYPE1","RA---TAN","Coordinate system 1. axis";
      kwds_set,"CRPIX1",Num_pixels1/2. + Det_offset(1)/Pixel_size1,"Reference pixel coordinate 1";
      crval1 = is_void(Ra_scx) ? 0.0 : Ra_scx;
      kwds_set,"CRVAL1",crval1,"Reference value coordinate 1";
      kwds_set,"CUNIT1","deg","Unit of reference value coordinate 1";
      kwds_set,"CTYPE2","DEC--TAN","Coordinate system 2. axis";
      kwds_set,"CRPIX2",Num_pixels2/2. + Det_offset(2)/Pixel_size2,"Reference pixel coordinate 2";
      crval2 = is_void(Dec_scx) ? 0.0 : Dec_scx;
      kwds_set,"CRVAL2",crval2,"Reference value coordinate 2";
      kwds_set,"CUNIT2","deg","Unit of reference value coordinate 2";
      pix1 = (Pixel_size1/Focal_length)*(180./pi);
      rot = is_void(Posang) ? 0.0 : Posang * (pi/180.);
      kwds_set,"CD1_1", -pix1*cos(rot), "[deg] -pix1*cos(rot)";
      kwds_set,"CD1_2", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_1", -pix1*sin(rot), "[deg] -pix1*sin(rot)";
      kwds_set,"CD2_2",  pix1*cos(rot), "[deg]  pix1*cos(rot)";

      kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
      kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
      if( !is_void(Exposure) ) kwds_set,"EXPOSURE", Exposure,"[s] Exposure time";
      kwds_set,"BKGLVL", bkglvl,"[cts/s/keV] Background counts added to the image";
      writefits,outfile,im,clobber=1;
   }

   if( am_subroutine() ) {
      disp, im;
   } else return im;

}

/* Function mt_upd_scatter_width */

func mt_upd_scatter_width( filename, width, typ=, angle_max=, unit=, outfile= )
/* DOCUMENT mt_upd_scatter_width, filename, width, typ=, angle_max=, unit=, outfile=

   Updates a FITS scatter table with gaussian scatter tables
   characterized by 'width'.
   Keyword 'typ' most be one of
       "f" : FWHM (default)
       "s" : sigma
       "h" : HPD
   Keyword angle_max is max angle of distribution
           If not given it will be kept as previously
   Keyword 'unit' must be one of
       "a" : arcsec
       "s" : arcsec
       "d" : degrees
       "m" : arcmin
       "r" : radians (default)
   Defaults to:    FWHM =  9.7e-5 rad (20 arcsec)

   NB! 'unit' applies BOTH to 'width' and to 'angle_max'

   2010-04-13/NJW
*/
{
   extern Version;

   dol = filename+"+1";
   fh = headfits( dol );
   if( is_void(outfile) ) outfile = filename;

   extname = fxpar(fh, "EXTNAME");
   is_type2 = (extname == "SCATTER_TYPE2");

   // See if 'width' has been given

   if( is_void(width) ) {
      width = 9.7e-5; // FWHM in radians
      typ = "f";
      unit = "r";
   } else width = double(width);

   // Check for width being FWHM, sigma, or HPD

   if( is_void(typ) ) {
      typ = "f";
   } else {
      typ = strpart(typ,1:1);
      if( typ != "f" && typ != "s" && typ != "h" ) error,"Bad 'typ' keyword";
   }

   // Check for unit being arcsec, arcmin, degree, or radian

   if( is_void(unit) ) {
      unit = "r";
   } else {
      unit = strpart(unit,1:1);
      if( unit == "s" ) unit = "a";
      if( unit != "a" && unit != "d" && unit != "r" && unit != "m" ) error,"Bad 'unit' keyword";
   }

   if( typ == "s" ) {
      sigma = width;
   } else if( typ == "f" ) {
      sigma = width / 2.35482;
   } else { // typ == "h"
      sigma = width / 1.34898;
   }
   conv_fac = 1.0;
   if( unit == "a" ) {
      conv_fac = 1./206265.;
   } else if( unit == "m" ) {
      conv_fac = 1./3437.75;
   } else if( unit == "d" ) {
      conv_fac = 1./57.2958;
   } // do nothing if unit == "r"
   sigma *= conv_fac;

  /*
   ********    Act differently for a type 2 scatter file
   */

   if( is_type2 ) {

      if( !is_void(outfile) ) cp, filename, outfile;

      dol = outfile+"[SCATTER_TYPE2B]";
      angle_dist = rdfitscol( dol, "ANGLE" );
      atype = typeof(angle_dist);
      old_distr = rdfitscol( dol, "DISTRIBUTION" );

      if( !is_void(angle_max) ) {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,numberof(angle_dist));
      }
      distribution = exp(-0.5*(angle_dist/sigma)^2);
      if( structof(old_distr) == float ) distribution = float(distribution);
      if( atype == "float" ) angle_dist = float(angle_dist);

      fits_bintable_poke, dol, 1, "DISTRIBUTION", distribution;
      fits_bintable_poke, dol, 1, "ANGLE", angle_dist;
      write,format="Has updated type 2 scatter file %s\n", outfile;

   } else {

      ener = rdfitscol( dol, "energy" );
      angi = rdfitscol( dol, "angle_in" );
      rcoe = rdfitscol( dol, "r_coef" );
      coat = rdfitscol( dol, "coating" );
      dori = rdfitscol( dol, "data_origin" );

      scat = rdfitscol( dol, "distribution" );
      dms = dimsof( scat );
      if( is_void(angle_max) ) {
         angle_dist = scat(,1);
      } else {
         angle_max *= conv_fac;
         angle_dist = span(-angle_max,angle_max,dms(2));
      }

      distribution = exp(-0.5*(angle_dist/sigma)^2)(,-:1:dms(3));
      distribution(,1) = angle_dist;

      dori(2:0) = swrite(format="Gaussian with FWHM of %10.3e rad (sigma=%10.3e rad)",\
                 sigma*2.35482 , sigma);

      kwds_init;
      fits_copy_keys, fh, tokwds=1;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible person";
      kwds_set,"SITE","NSI/DTU","Institution";
      kwds_set,"ORIGIN","mt_upd_scatter_width","produced this file";
      kwds_set,"ORIGFILE",filename,"Original file";
      kwds_set,"VERSION", Version, "MT_RAYOR version indicator";
      kwds_set,"COATING", coat(0), "Coating number";
      kwds_set,"SIGMA", sigma, "[rad] Sigma of gaussian distribution";
      kwds_set,"TUNIT1","keV","Photon energy";
      kwds_set,"TUNIT2","radian","Incoming angle";
      wrmfitscols, outfile, "ENERGY", ener, "ANGLE_IN", angi, \
          "R_COEF", rcoe, "COATING", coat, \
          "DISTRIBUTION", distribution, "DATA_ORIGIN", dori, \
          clobber=1, extname="UPD_SCAT_DIST";
      write,format="Has written scatter file %s\n", outfile;

   }

}

/* Function mt_det_add_bkg */

func mt_det_add_bkg( instr=, dxb=, dxb_adjust= )
/* DOCUMENT mt_det_add_bkg, instr=, dxb=, dxb_adjust=

     Add both instrument and diffuse background to current
     event list (Evlist).

     Override selections in the detector description file by
     keywords instr resp. dxb that each is the name of a file.
     Keyword 'dxb_adjust' is a factor to enhance the DXB contribution.

     The external variable 'Exposure' together with the information
     in the detector description file will define the number of
     background counts.

     SEE ALSO: mt_det_add_instr_bkg, mt_det_add_dxb_bkg

   2010-06-19/NJW
*/
{
   mt_det_add_instr_bkg, instr;
   mt_det_add_dxb_bkg, dxb, adjust=dxb_adjust;
}

/* Function mt_det_add_instr_bkg */

func mt_det_add_instr_bkg( filename )
/* DOCUMENT mt_det_add_instr_bkg[, filename]

   Add the detector background as described in the s-format file
   with two columns, energy (keV) and background (cts/s/keV/cm2).

   If 'filename' is given then this will be read as Instr_bkg_file
   else the file defined in the detector definition file
   (keyword instr_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-05-17/NJW
*/
{

// ynclude = zba
  extern  E_min,           Exposure,        Num_pixels1,     Pixel_size1, \
          Evlist,          Instr_bkg_file,  Num_pixels2,     Pixel_size2;
// yxclude =

   local ener, bkg;

   if( !is_void(filename) ) {
      if( !file_test(filename) ) error,filename+" was not found";
      Instr_bkg_file = filename;
   }

   rstab,Instr_bkg_file,2,ener,bkg,typ="dd",silent=1;

   // Detector area (in cm2) :
   det_area = 0.01 * Num_pixels1 * Num_pixels2 * Pixel_size1 * Pixel_size2;

   //+ int_ener = integ( bkg, ener, E_max(0) ) - integ( bkg, ener, E_min(1));
   int_ener = integ( bkg, ener, ener(0) );

   if( is_void(Exposure) ) {
      write,"  NB: 'Exposure' is set to 100 s";
      Exposure = 100.0;
   }
   n_bkg_counts = long(int_ener * det_area * Exposure + 0.5);

   ener_bkg = draw_from_dist( ener, bkg, n_bkg_counts );

   bkg_evlist = array(s_MTEvent,n_bkg_counts);
   bkg_evlist.detx = random(n_bkg_counts)*Num_pixels1 - Num_pixels1/2.;
   bkg_evlist.rawx = long(bkg_evlist.detx + Num_pixels1/2. + 1);
   bkg_evlist.dety = random(n_bkg_counts)*Num_pixels2 - Num_pixels2/2.;
   bkg_evlist.rawy = long(bkg_evlist.dety + Num_pixels2/2. + 1);
   bkg_evlist.flag = 0;
   bkg_evlist.phs_index = -1;
   bkg_evlist.energy = ener_bkg;
   for( i = 1; i <= n_bkg_counts; i++ ) {
      w = where( E_min < bkg_evlist(i).energy );
      bkg_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, bkg_evlist;
   write,format="%i instr bkg events have been added to 'Evlist'\n", n_bkg_counts;

}

/* Function mt_det_add_dxb_bkg */

func mt_det_add_dxb_bkg( filename, adjust= )
/* DOCUMENT mt_det_add_dxb_bkg[, filename][, adjust=]

   Add the DXB background from the DXB raytracing
   event list in 'filename'. The events are selected randomly
   from this file.

   If 'filename' is given then this will be read as Dxb_bkg_file
   else the file defined in the detector definition file
   (keyword dxb_bkg_file) and read in by command: 'mt_detector,init=1'.

   2010-06-19/NJW
*/
{

// ynclude = zbb
  extern  Dxb_bkg_file,  E_min,         Evlist,        Exposure;
// yxclude =

   if( !is_void(filename) ) Dxb_bkg_file = filename;
   if( is_void(adjust) ) adjust = 1.0;

   hdr = headfits(Dxb_bkg_file+"+1");
   pool_exposure = fxpar(hdr,"EXPOSURE");
   if( is_void(pool_exposure) ) error,"No EXPOSURE keyword in DXB event file";
   npool = fxpar(hdr,"naxis2");
   // how many events to pick?
   n_dxb = long(npool*(Exposure/pool_exposure)*adjust);
   if( n_dxb < 1 || n_dxb > npool ) error,"mt_det_add_dxb_bkg error, n_dxb is illegal";
   write,format="Add %i DXB events to 'Evlist' ...\n", n_dxb;

   r = random(n_dxb);
   i = long(r*npool) + 1;

   if( mem_restore( Dxb_bkg_file+"+1_rawx", rawx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawx";
      rawx = rdfitscol(Dxb_bkg_file+"+1","rawx");
      mem_save, Dxb_bkg_file+"+1_rawx", rawx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_rawy", rawy ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_rawy";
      rawy = rdfitscol(Dxb_bkg_file+"+1","rawy");
      mem_save, Dxb_bkg_file+"+1_rawy", rawy;
   }
   if( mem_restore( Dxb_bkg_file+"+1_detx", detx ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_detx";
      detx = rdfitscol(Dxb_bkg_file+"+1","detx");
      mem_save, Dxb_bkg_file+"+1_detx", detx;
   }
   if( mem_restore( Dxb_bkg_file+"+1_dety", dety ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_dety";
      dety = rdfitscol(Dxb_bkg_file+"+1","dety");
      mem_save, Dxb_bkg_file+"+1_dety", dety;
   }
   if( mem_restore( Dxb_bkg_file+"+1_energy", ener ) < 0 ) {
      write,format="Reading %s ...\n", Dxb_bkg_file+"+1_energy";
      ener = rdfitscol(Dxb_bkg_file+"+1","energy");
      mem_save, Dxb_bkg_file+"+1_energy", ener;
   }

   dxb_evlist = array(s_MTEvent,n_dxb);
   dxb_evlist.detx = detx(i);
   dxb_evlist.rawx = rawx(i);
   dxb_evlist.dety = dety(i);
   dxb_evlist.rawy = rawy(i);
   dxb_evlist.flag = 0;
   dxb_evlist.phs_index = 0;
   dxb_evlist.energy = ener(i);
   for( i = 1; i <= n_dxb; i++ ) {
      w = where( E_min < dxb_evlist(i).energy );
      dxb_evlist(i).pha = numberof(w) ? w(0) : 1;
   }
   grow, Evlist, dxb_evlist;

}

/* Function mt_get_scatter_hpd */

func mt_get_scatter_hpd( energy, angle_in )
/* DOCUMENT hpd_rad = mt_get_scatter_hpd( energy, angle_in )

   Returns HPD in radians

*/
{
   d = mt_sel_scatter( energy, angle_in );
   z = integ(d,Anglesarr,Anglesarr);
   z /= z(0);
   i = 0;
   da = 1.e33;
   do {
      da_prev = da;
      i++;
      // Find angle so half of distribution is covered
      q = interp(Anglesarr,z-z(i),0.5);
      da = q - Anglesarr(i);
   } while( da < da_prev );
   i--;
   return interp(Anglesarr,z-z(i),0.5) - Anglesarr(i);
}

/* Function mt_spoke_read */

func mt_spoke_read( filename, pos= )
/* DOCUMENT mt_spoke_read, filename, pos=

   'filename' is assumed to be an s-format file with at least the
   columns 'angle' and 'width'. Optional columns are 'rstart' and
   'rstop' (always in mm).

   Required keywords: reverse, angle_unit and width_unit
      angle_unit can only be one of: deg  rad
      width_unit can only be one of: mm   cm

*/
{
// ynclude = zbc
  extern  Module_num,          Reverse_spokes2,     Rstop_spokes2, \
          Phi_spokes1,         Rstart_spokes1,      Spoke_define_files, \
          Phi_spokes2,         Rstart_spokes2,      Width_spokes1, \
          Reverse_spokes1,     Rstop_spokes1,       Width_spokes2, \
          Full_length_spokes1, Full_length_spokes2;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";
   if( is_void(filename) ) filename = Spoke_define_files(2*Module_num-2+pos);

   if( filename != "none" ) {

      // define unit conversion factors

      au = comgets( filename, "angle_unit" );
      aconv_factor = au == "deg" ? pi/180 : 1.0;
      wu = comgets( filename, "width_unit" );
      wconv_factor = wu == "cm" ? 10.0 : 1.0;

      // see if radius defining columns are present
      colnames = comgets(filename,"colname");
      if( noneof( colnames == "angle" ) ) error,"Spoke angle column is missing";
      if( noneof( colnames == "width" ) ) error,"Spoke width column is missing";
      rdef = anyof( colnames == "rstart" ) & anyof( colnames == "rstop" );

      // read the table values
      phi_spokes = rscol(filename,"angle",silent=1,nomem=1)*aconv_factor;
      width_spokes = rscol(filename,"width",silent=1,nomem=1)*wconv_factor;
      n_spokes = numberof(phi_spokes);
      if( rdef ) {
         rstart_spokes = rscol(filename,"rstart",silent=1,nomem=1); // must be in mm
         rstop_spokes = rscol(filename,"rstop",silent=1,nomem=1); // must be in mm
      } else {
         rstart_spokes = array(0.0, n_spokes);
         rstop_spokes = array(1.e6, n_spokes); // ridiculously large number
      }

      // make sure that all angles are positive (or zero) and sorted
      phi_spokes = zero2pi(phi_spokes);
      is = sort(phi_spokes);
      phi_spokes = phi_spokes(is);
      width_spokes = width_spokes(is);
      rstart_spokes = rstart_spokes(is);
      rstop_spokes = rstop_spokes(is);

      // see if spokes are blocking or slits

      reverse_spokes = comget( filename, "reverse", lng=1 );
      if( is_void(reverse_spokes) ) reverse_spokes = 0;
      if( reverse_spokes != 0 ) reverse_spokes = 1;

      // see if spokes are blocking in full length

      full_length_spokes = comget( filename, "full_length", lng=1 );
      if( is_void(full_length_spokes) ) full_length_spokes = 0;

      if( pos == 1 ) {
         Phi_spokes1 = phi_spokes;
         Width_spokes1 = width_spokes;
         Rstart_spokes1 = rstart_spokes;
         Rstop_spokes1 = rstop_spokes;
         Reverse_spokes1 = reverse_spokes;
         Full_length_spokes1 = full_length_spokes;
      } else {
         Phi_spokes2 = phi_spokes;
         Width_spokes2 = width_spokes;
         Rstart_spokes2 = rstart_spokes;
         Rstop_spokes2 = rstop_spokes;
         Reverse_spokes2 = reverse_spokes;
         Full_length_spokes2 = full_length_spokes;
      }
   }

}

/* Function mt_spoke_blocking */

func mt_spoke_blocking( p, pos= ) // p is coordinate in (x,y)
/* DOCUMENT flag = mt_spoke_blocking( p, pos= )

   Returns [1,0] if the photon at position p (2 element array (x,y))
   is blocked by a spoke. Returns [0,next_spoke] if allowed.
   This makes it possible to test against 'passage through same opening'.
   The spokes are defined in the
   file given in variable 'Spoke_define_file'.

   Keyword pos: 1 for entrance and 2 for exit of optical module.

*/
{

// ynclude = zbd
  extern  Phi_spokes1,      Reverse_spokes2,  Rstop_spokes1,    Width_spokes1, \
          Phi_spokes2,      Rstart_spokes1,   Rstop_spokes2,    Width_spokes2, \
          Reverse_spokes1,  Rstart_spokes2,   Full_length_spokes1;
// yxclude =

   if( is_void(pos) ) pos = 1;
   if( pos != 1 && pos != 2 ) error,"Bad value of keyword pos";

  /*
   *   Assume that the spoke definition is such that
   *   Phi_spokes is never decreasing (assured by function
   *   mt_spoke_read). There may be several spokes with the same angle.
   */

   phi = zero2pi(atan( p(2), p(1) )); // phi angle of photon
   rad = sqrt(p(1)^2 + p(2)^2);       // radius of photon
   //+ write,format="SB: phi = %8.4f\n", phi;

   // use temporary storage to do a radius selection
   if( pos == 1 ) {
      phi_spokes = Phi_spokes1;
      width_spokes = Width_spokes1;
      rstart_spokes = Rstart_spokes1;
      rstop_spokes = Rstop_spokes1;
      reverse_spokes = Reverse_spokes1;
   } else {
      phi_spokes = Phi_spokes2;
      width_spokes = Width_spokes2;
      rstart_spokes = Rstart_spokes2;
      rstop_spokes = Rstop_spokes2;
      reverse_spokes = Reverse_spokes2;
   }

   w = where( rstart_spokes <= rad & rad <= rstop_spokes );
   nw = numberof(w);
   if( nw == 0 ) return reverse_spokes; // no spokes at this radius
   phi_spokes = phi_spokes(w);
   width_spokes = width_spokes(w);
   rstart_spokes = rstart_spokes(w);
   rstop_spokes = rstop_spokes(w);

   // Locate next spoke

   w = where( phi_spokes > phi );
   nw = numberof(w);
   next_spoke = nw == 0 ? 1 : w(1);
   //+ write,format="SB: next_spoke = %i\n", next_spoke;
   previous_spoke = next_spoke - 1; // exploits that Yorick has 'rolling' indices
   //+ write,format="SB: previous_spoke = %i\n", previous_spoke;
   //+ write,format="SB: Phi prev/next = %8.4f  %8.4f\n", Phi_spokes(previous_spoke), Phi_spokes(next_spoke);
   // oplot,[p(1)],[p(2)],ps=12,symsize=0.5,color="red";
   // distance to previous spoke
   //+ epsilon = abs(phi - phi_spokes(previous_spoke));
   epsilon = zero2pi(phi - phi_spokes(previous_spoke));
   dprev = rad * sin(epsilon);

   // distance to next spoke
   //+ epsilon = abs(phi - phi_spokes(next_spoke));
   epsilon = zero2pi(phi_spokes(next_spoke) - phi);
   dnext = rad * sin(epsilon);

   //+ write,format="SB: dist prev/next = %8.4f  %8.4f mm\n", dprev, dnext;

   if( dprev < 0.5*width_spokes(previous_spoke) || dnext < 0.5*width_spokes(next_spoke) ) {
      // It has hit a spoke
      if( reverse_spokes ) {
         return [0,next_spoke];
      } else {
         return [1,0];
      }
   } else {
      // It did not hit a spoke
      if( reverse_spokes ) {
         return [1,0];
      } else {
         return [0,next_spoke];
      }
   }

}

/* Function mt_clear */

func mt_clear
/* DOCUMENT mt_clear

     Erases Exposure information
*/
{
   extern Exposure;
   Exposure = [];
}

/* Function mt_dxb2skydef */

func mt_dxb2skydef( skydefname, dol_dxbflux, wfov, n, exposure=,
            mission=, instrume= )
/* DOCUMENT mt_dxb2skydef, skydefname, dol_dxbflux, wfov, n, exposure=, \
            mission=, instrume=

     Produces a skydefinition file for DXB determination
     Put sources in a regular mesh around (RA,Dec) = (180,0)

     Arguments:
        skydefname   :  filename of sky definition file to be made
        dol_dxbflux  :  DOL of DXB flux information in proper energy
                        range and in photons /cm2/s/keV/sr
        wfov         :  [deg] full width of the FOV
        n            :  The number of 'sources' from center to edge
                        implying that the total number of sources
                        will become (2*n + 1)^2
     Keywords:
        exposure     :  [s] exposure time to be written to the output file
        mission      :  A scalar string for the FITS keyword 'MISSION'
        instrume     :  A scalar string for the FITS keyword 'INSTRUME'


     After this has been run, a call of mt_run (if the raytracing has been
     properly initiated) will generate the DXB photons:

      > mt_run,dol_dxbflux

    2010-08-13/NJW
*/
{

   extern Version;

   local x, y;

   if( is_void(exposure) ) exposure= 1000.0; // s

   w_of_fov_deg = wfov; // degrees
   w_of_fov_arcmin = w_of_fov_deg * 60.; // arcmin
   // 'n' is number of steps to one side
   N = 2*n + 1; // making it odd
   step_arcmin = w_of_fov_arcmin/(N-1);
   // 8.4616e-8 sr per arcmin^2
   omega = 8.4616e-8 * step_arcmin^2;

   ra_scx = 180.;
   dec_scx = 0.0;
   posang = 0.0;
   rad2arcmin = 60*(180./pi); // rad to arcmin

   ra_obj = reform(span(180-w_of_fov_deg/2,180+w_of_fov_deg/2,N)(,-:1:N),N*N);
   dec_obj = reform(span(-w_of_fov_deg/2,w_of_fov_deg/2,N)(-:1:N,),N*N);

   fluxdols = array( dol_dxbflux, N*N);
   enera = dphota = x_sky = y_sky = array(1., N*N);
   renorma = array( omega, N*N);


   for( i = 1; i <= N*N; i++ ) {
      jconv_coord, ra_scx, dec_scx, posang, ra_obj(i), dec_obj(i), \
                   x, y, to_sc=1;
      x_sky(i) = -x * rad2arcmin;
      y_sky(i) = y * rad2arcmin;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME",instrume,"Name of instrument";
   kwds_set,"DATE",ndate(3),"Date of creation";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version,"Software package/version";
   kwds_set,"FUNCTION","mt_dxb2skydef (MT_RAYOR)","Software that created this file";
   kwds_set,"VERSION", Version,"MT_RAYOR version";
   kwds_set,"EXPOSURE", exposure,"[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx,"[deg] R.A. of satellite pointing axis";
   kwds_set,"DEC_SCX", dec_scx,"[deg] Decl. of satellite pointing axis";
   kwds_set,"POSANG", posang,"[deg] Position angle of satellite pointing";
   kwds_set,"COMMENT","Mesh of sources for DXB determination";

   wrmfitscols, skydefname, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", fluxdols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                clobber=1;

   write,format="%s has been written\n", skydefname;

}

/* Function mt_skyspec2skydef */

/*************************************************************************
 *
 *   Use a FITS sky spectral definition file to make a MT_RAYOR
 *   sky definition file (SDF) from a sky spectral definition file (SSDF).
 *
 *   The SSDF consists of a norm map (NORM_MAP),
 *   an ARF (SPECRESP), a map of PARAM1 (P1MAP) or a PARAM1 keyword,
 *   and a map of NH (NHMAP) or a NH keyword. The spectral code is
 *   given as a keyword.
 *   The SSDF can be prepared with function 'skyima2skyspec'
 *
 *   2010-08-18/NJW
 *
 ************************************************************************/

func mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang, \
            fraclim=, exposure=, e1=, e2=, nchan=, \
            radius=, fluxdir=, mission=, instrume=, telescop= )
/* DOCUMENT mt_skyspec2skydef, sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang

  or   nsources = mt_skyspec2skydef( sky_spec_def_file, skydef_file, ra_scx, dec_scx, posang )

    Arguments:
       sky_spec_def_file  - name of the input sky spectral definition file (FITS format)
       skydef_file - Name of the output sky definition file
       ra_scx      - [deg] RA of telescope boresight or DOL of previous sky definition file.
       dec_scx     - [deg] Dec of telescope boresight
       posang      - [deg] Position angle of telescope

    Keywords:
       fraclim  - is fractional limit of image maximum for inclusion
                  (if set too low a LARGE number of sources may be defined)
                  default is 0.5.
       exposure - [s] exposure time, default 1000.
       e1       - [keV] lower energy boundary for photon spectra, default 0.5.
       e2       - [keV] upper energy boundary for photon spectra, default 10.0.
       nchan    - number of energy channels in photon spectra (default is 200).
       radius   - [deg] only pixels within this radius from the pointing direction
                  will be used, default 0.5.
       fluxdir  - directory for storing the photon flux files (default is current).
       mission  - name of mission (becomes FITS keyword 'MISSION')
       instrume - name of instrument (becomes FITS keyword 'INSTRUME')
       telescop - name of 'telescope' (becomes FITS keyword 'TELESCOP')

    If the argument 'ra_scx' is a string, then it is interpreted as a DOL to a previous
    SDF and the keywords except 'fluxdir' will be copied from that. If some are given
    nevertheless, they will be neglected.


    SEE ALSO: mt_skyima2skyspec

    2010-08-18/NJW
*/
{

   extern Version;

   local ra, dec;
   local x, y;

   rad2arcmin = 60*(180./pi); // rad to arcmin

   hdr_norm = headfits(sky_spec_def_file+"[NORM_MAP]");
   norm_map = readfits(sky_spec_def_file+"[NORM_MAP]");
   dms = dimsof(norm_map);

   // Reset the Energ_lo, Energ_hi, and Flux content of memory
   mem_reset;

   if( typeof( ra_scx ) == "string" ) {
      hdr = headfits( ra_scx+"[SKY_DEFINITION]" );
      ra_scx = fxpar( hdr, "ra_scx" );
      dec_scx = fxpar( hdr, "dec_scx" );
      posang = fxpar( hdr, "posang" );
      fraclim = fxpar( hdr, "fraclim" );
      radius = fxpar( hdr, "radius" );
      e1 = fxpar( hdr, "e1" );
      e2 = fxpar( hdr, "e2" );
      nchan = fxpar( hdr, "nchan" );
      exposure = fxpar( hdr, "exposure" );
   }
   if( is_void(nchan) ) nchan = 200;
   if( is_void(radius) ) radius = 0.5; // deg
   if( is_void(exposure) ) exposure = 1000.0; // s
   if( is_void(fraclim) ) fraclim = 0.5;
   if( is_void(e1) ) e1 = 0.5;
   if( is_void(e2) ) e2 = 10.0;
   if( is_void(fluxdir) ) {
      fluxdir = "";
   } else {
      fluxdir = app_slash(fluxdir);
   }

   // get spectral code from the NORM_MAP header of the SSDF

   sc = fxpar( hdr_norm, "SC" );
   if( is_void(sc) ) error,"SC not defined in NORM_MAP header";

   // is p1 a scalar or a map?

   local dummy, extno;
   get_exten_no, sky_spec_def_file+"[P1MAP]", dummy, extno;
   if( extno >= 0 ) { // There is a P1MAP in an extension
      p1dol = sky_spec_def_file+"+"+itoa(extno);
      p1map = readfits(p1dol);
      dmsmap = dimsof(p1map);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - p1map has bad dimensions ...";
      }
   } else { // a keyword must exist
      p1 = fxpar(hdr_norm,"PARAM1");
      if( is_void(p1) ) error,"Error in file - no PARAM1 keyword found ...";
      p1map = [];
   }

   // is nh a scalar or a map?

   get_exten_no, sky_spec_def_file+"[NHMAP]", dummy, extno;
   if( extno >= 0 ) { // There is a NHMAP in an extension
      nhdol = sky_spec_def_file+"+"+itoa(extno);
      nhmap = readfits(nhdol);
      dmsmap = dimsof(nhmap);
      if( dms(2) != dmsmap(2) || dms(3) != dmsmap(3) ) {
         error,"Error in file - nhmap has bad dimensions ...";
      }
   } else { // a keyword must exist
      nh = fxpar(hdr_norm,"NH");
      if( is_void(nh) ) error,"Error in file - no NH keyword found ...";
      nhmap = [];
   }


  /*
   *   Default rule: include pixels with value > fraclim*max_value
   */

   maxval = max(norm_map);
   w = where(norm_map > fraclim*maxval);
   nw = numberof(w);
   write,format="%i allowed pixels found\n", nw;

   // Walk through all allowed image pixels to produce a
   // photon flux file for each

   dols = x_sky = y_sky = enera = renorma = dphota = \
           name = ra_obj = dec_obj = intens = nharr = param1 = [];
   nsour = 0;
   sx_sum = 0.0;
   memflag = 1;
   for( i = 1; i <= nw; i++ ) {
      ij = indices(norm_map,w(i));
      skypos_fits,hdr_norm,ij(1),ij(2),ra,dec,to_sky=1,silent=1;

      // reject if more than 'radius' away from pointing

      if( arcdist(ra,dec,ra_scx,dec_scx) > radius ) continue;

      nsour++;
      fname = swrite(format=fluxdir+"photflux_%06i.fits",1000*ij(1)+ij(2));
      if( !is_void(p1map) ) p1 = p1map(w(i));
      if( !is_void(nhmap) ) nh = nhmap(w(i));
      // Change with version 4.4.5
      //+ mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
      //+     p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,silent=1;
      mk_photflux,sc=sc,nh=nh,norm=norm_map(w(i)), \
          p1=p1,e1=e1,e2=e2,nchan=nchan,outfile=fname,nof=1,mem=memflag,silent=1;
      sx_sum += Sx_photflux;
      memflag++;

      grow, dols, fname+"+1";
      grow, name, strpadd(itoa(i),40,truncate=1);
      grow, ra_obj, ra;
      grow, dec_obj, dec;
      grow, intens, Sx_photflux;
      grow, nharr, nh;
      grow, param1, p1;

      jconv_coord, ra_scx, dec_scx, posang, ra, dec, \
                   x, y, to_sc=1;

      grow, x_sky, -x * rad2arcmin;
      grow, y_sky, y * rad2arcmin;
      grow, enera, 1.0;
      grow, renorma, 1.0;
      grow, dphota, 1.0;
   }

   kwds_init;
   kwds_set,"EXTNAME","SKY_DEFINITION","Name of this extension";
   if( !is_void(mission) ) kwds_set,"MISSION", mission, "Name of mission";
   if( !is_void(instrume) ) kwds_set,"INSTRUME", instrume,"Name of instrument";
   if( !is_void(telescop) ) kwds_set,"TELESCOP", telescop,"Name of telescope";
   kwds_set,"DATE",ndate(3),"Date of creation of this file";
   kwds_set,"ORIGIN","MT_RAYOR-"+Version, "Software/version for creation of this file";
   kwds_set,"FUNCTION","mt_skyspec2skydef", "Function used for creation of this file";
   kwds_set,"EXPOSURE", exposure, "[s] Exposure time";
   kwds_set,"RA_SCX", ra_scx, "[deg] R.A. of telescope bore sight";
   kwds_set,"DEC_SCX", dec_scx, "[deg] Decl. of telescope bore sightsatellite pointing axis";
   kwds_set,"E1", e1, "[keV] Lower energy for photon spectrum";
   kwds_set,"E2", e2, "[keV] Upper energy for photon spectrum";
   kwds_set,"NCHAN", nchan, "Number of energy channels in photon spectrum";
   kwds_set,"POSANG", posang, "[deg] Position angle of telescope bore sight";
   kwds_set,"INPUTFIL",sky_spec_def_file, "Sky spectral definition file";
   kwds_set,"FRACLIM", fraclim, "Fractional limit for pixel inclusion";
   strran = swrite(format="%.1f-%.1f", e1, e2);
   kwds_set,"SX_SUM", sx_sum,"[erg/cm2/s] ("+strran+" keV) Actual summed source intensity";
   kwds_set,"SC", sc, "Spectral code (used by mk_photflux)";
   if( is_void(nhmap) ) {
      kwds_set,"NH", nh, "[atoms/cm2] Column density for entire image";
   } else {
      kwds_set,"NHMAPDOL",nhdol,"Map of column densities used";
   }
   if( is_void(p1map) ) {
      kwds_set,"PARAM1",p1,"Spectral parameter used for entire image";
   } else {
      kwds_set,"P1MAPDOL",p1dol,"Map of spectral parameters used";
   }
   kwds_set,"RADIUS", radius, "[deg] Inclusion radius";

   wrmfitscols, skydef_file, "X_SKY", x_sky, "Y_SKY", y_sky, \
                "ENERGY", enera, "INTENS", intens, "DPHOT", dphota, "RENORM", renorma, \
                "DOL", dols, "RA_OBJ", ra_obj, "DEC_OBJ", dec_obj, \
                "NAME", name, clobber=1;
   write,format="%i rows in %s have been written\n", numberof(x_sky), skydef_file;
   if( am_subroutine() ) write,format="%s has been written\n", skydef_file;

   return nsour;

}

/* Function mt_skyima2skyspec */

/************************************************
 *
 *   Convert count or countrate image to sky spectral
 *   definition file.
 *
 *    Information needed:
 *        ARF (effective area)
 *        Energy limits
 *        Spectral models i.e. spectral code, param1, nh
 *
 *    ARF must be in a FITS table with ENERG_LO, ENERG_HI
 *        and SPECRESP columns.
 ************************************************/


func mt_skyima2skyspec( dol_skyima, dol_arf, emin, emax, outfile, \
                        fraclim=, sc=, nh=, p1=, enx= )
/* DOCUMENT mt_skyima2skyspec, dol_skyima, dol_arf, emin, emax, outfile, \
            fraclim=, sc=, nh=, p1=, enx=

   Uses a skyimage, 'dol_skyima', with countrates per pixel to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   The energy limits, 'emin' and 'emax', are also those for the input image.

   Keyword 'fraclim' defines the selection:
                    where(skyima > fraclim*max(skyima))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   Keyword for extra Sx calculation:
           enx    :   [e1,e2] (2 element array)
                      makes only sense if emin < e1 < e2 < emax

   SEE ALSO: mt_skyspec2skydef

   2010-08-18/NJW

*/
{
   skyima = readfits(dol_skyima);
   hdr_skyima = headfits(dol_skyima);
   dms = dimsof(skyima);
   norm_map = array(float,dms);

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skyima > fraclim*max(skyima));
   nsrc = numberof(src);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and nh-map";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skyima and p1-map";
   } else {
      p1map = [];
   }

   energ_lo = rdfitscol(dol_arf,"energ_lo");
   energ_hi = rdfitscol(dol_arf,"energ_hi");
   specresp = rdfitscol(dol_arf,"specresp");
   eline = sqrt(energ_lo*energ_hi);

   first = 1;
   tot_flux = [];

   // Loop over all 'active' pixels

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
            nchan=100,nof=1,silent=1;
      // produces Eline, Flux, Sx_photflux
      if( first ) arf = interp(specresp,eline,Eline);
      // calculate countrate expected from a norm=1 spectrum
      I = sum(Flux(zcen)*arf(zcen)*Eline(dif));
      k_norm = skyima(src(i))/I;
      norm_map(src(i)) = k_norm;
      if( is_void(tot_flux) ) {
         tot_flux = k_norm * Flux;
      } else {
         tot_flux += k_norm * Flux;
      }
      first = 0;
   }
   sxtot = sflux(emin,emax,Eline,tot_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   sxtotx = [];
   if( numberof(enx) == 2 ) {
      sxtotx = sflux(enx(1),enx(2),Eline,tot_flux);
      write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
              sxtotx, enx(1), enx(2);
   }

   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skyima,"DOL of input sky ima";
   kwds_set,"ARFDOL",dol_arf,"DOL of applied ARF";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   if( !is_void(sxtotx) ) {
      s1 = swrite(format="%.2f", enx(1));
      s2 = swrite(format="%.2f", enx(2));
      kwds_set,"SXTOTALX",sxtotx,"[erg/cm2/s] from "+s1+" to "+s2+" keV";
   }

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skyima,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   fh = writefits(outfile,norm_map,clobber=1,cont=1);

   // Add the ARF

   kwds_set,"EXTNAME","SPECRESP","Name of this extension";
   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = wrmfitscols( fh, "ENERG_LO",energ_lo,"ENERG_HI",energ_hi,"SPECRESP",specresp,cont=cont);

   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

/* Function mt_roll */

func mt_roll( roll_angle )
/* DOCUMENT mt_roll, roll_angle

   Executes a rotation of all the photons in 'Phs' around the z-axis.
   roll_angle is in radians. Please note that this is the opposite angle
   of the optic rotation.

   The roll angle is saved as an external variable: Roll_phot (in radians).

*/
{
   extern Phs, Roll_phot;

   Roll_phot = roll_angle;

   eq_nocopy, cE, Phs.E;
   eq_nocopy, cR, Phs.R;

   omega = [[cos(roll_angle),sin(roll_angle),0], \
            [-sin(roll_angle),cos(roll_angle),0], \
             [0,0,1]]; // defines the rotation around z
   Phs.E = omega(,+)*cE(+,);
   Phs.R = omega(,+)*cR(+,);
}

/* Function mt_photpr */

func mt_photpr( iphot )
/* DOCUMENT mt_photpr, iphot

    Nice screen print of photon number 'iphot'
*/
{
   write,"Element  Meaning                 Value(s)";
   write,format="(status)    Status                : %6i\n", Phs(iphot).status;
   write,format="(mirror)    Mirror                : %6i\n", Phs(iphot).mirror;
   write,format="(bounce)    Bounce                : %6i\n", Phs(iphot).bounce;
   write,format="(flag)      Flag                  : %6i\n", Phs(iphot).flag;
   write,format="(energy)    Energy                : %10.3f keV\n", Phs(iphot).energy;
   write,format="(rcoef)     Rcoef                 :   %10.5f\n\n", Phs(iphot).rcoef;
   write,format="(E)         Current position      : %10.3f%10.3f%10.3f\n", Phs(iphot).E(1), \
                       Phs(iphot).E(2), Phs(iphot).E(3);
   write,format="(E1)        Entrance OM1 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E1(1), \
                       Phs(iphot).E1(2), Phs(iphot).E1(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E1(2),Phs(iphot).E1(1)));
   write,format="(E2)        Entrance OM2 position : %10.3f%10.3f%10.3f\n", Phs(iphot).E2(1), \
                       Phs(iphot).E2(2), Phs(iphot).E2(3);
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).E2(2),Phs(iphot).E2(1)));
   write,format="(I1)        Reflection OM1 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I1(1), \
                       Phs(iphot).I1(2), Phs(iphot).I1(3);
   if( Phs(iphot).I1(1) != 0.0 || Phs(iphot).I1(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I1(2),Phs(iphot).I1(1)));
   write,format="(I2)        Reflection OM2 point  : %10.3f%10.3f%10.3f\n", Phs(iphot).I2(1), \
                       Phs(iphot).I2(2), Phs(iphot).I2(3);
   if( Phs(iphot).I2(1) != 0.0 || Phs(iphot).I2(2) != 0.0 ) \
   write,format="( - )       Azimuth               : %12.5f rad\n", zero2pi(atan(Phs(iphot).I2(2),Phs(iphot).I2(1)));
   write,"";
   write,format="(R)         Current direction     :   %10.5f%10.5f%10.5f\n", Phs(iphot).R(1), \
                       Phs(iphot).R(2), Phs(iphot).R(3);
   write,format="(D1)        Entrance OM1 direction:   %10.5f%10.5f%10.5f\n", Phs(iphot).D1(1), \
                       Phs(iphot).D1(2), Phs(iphot).D1(3);
   write,format="(D2)        Entrance OM2 direction:   %10.5f%10.5f%10.5f\n\n", Phs(iphot).D2(1), \
                       Phs(iphot).D2(2), Phs(iphot).D2(3);
   write,format="(angle_in1) Reflection OM1 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in1*1000., \
                       Phs(iphot).angle_out1*1000.;
   write,format="(angle_in2) Reflection OM2 angles :   %10.5f%10.5f mrad\n", Phs(iphot).angle_in2*1000., \
                       Phs(iphot).angle_out2*1000.;
}

/* Function is_defined */

func is_not_defined ( x )
{
   if( is_void(x) ) return 1;
   if( structof(x) == string ) {
      if( x == "[]" ) return 1;
   }
   return 0;
}

/* Function mt_eff_area_quick */

func mt_eff_area_quick( earr=, outfile= )
/* DOCUMENT eff_area = mt_eff_area_quick( earr=, outfile= )

   Calculate the telescope effective area from the optical module
   files and scatter+reflection informations.
   Go through all mirrors and sum the mirror contributions.

   Default energy array is 'E_uniq' (external variable)

   If the keyword 'outfile' is not set or set to zero then
   no output file will be written. If it is given as a string
   then this will be the output file name, else the standard
   naming as eff_area_quick_nnnn.fits, where 'nnnn' is a serial number,
   will be used.

   The correction for the blocking by spokes is included if
   'mt_get_mirror_eff_factors' is run before this function.

   Version 3.5     2011-08-04/NJW
*/

{

// ynclude = zbe
  extern  Om_files, Num_modules, N_mirrors, Coat_list, Mirror_coating, \
          R1arr, R2arr, Z1arr, Z2arr, E_uniq, Mirror_eff_factors, \
          Telescop, Instrume, Mirror_area;
// yxclude =

   if( is_void(earr) ) {
      if( is_void(E_uniq) ) {
         n_earr = 50;
         earr = span(2.,79, n_earr);
      } else {
         n_earr = numberof(E_uniq);
         earr = E_uniq;
      }
   } else {
      n_earr = numberof(earr);
   }



   //  Sum the reflection coefficients
   //    not so useful when no scattering/refl tables have been read in

   mt_load, omfile=Om_files(1);
   if( is_not_defined(Coat_list) ) {
      write,"Coat_list has not been defined, no action! ...";
      return [];
   }

   Mirror_area = array(double, N_mirrors);
   eff_area_m = array(double, n_earr, N_mirrors);
   mir_angle1 = array(double, N_mirrors);

   //  Loop over all mirrors

   for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
      coating = Mirror_coating(mirror);
      q = where( Coat_list.id == coating );
      if( numberof(q) == 0 ) error,"##17## coating problem";
      required_scatfile = Coat_list(q(1)).file;
      if( Scatter_file != required_scatfile ) {
         mt_load,scatfile=required_scatfile;
      }
      mir_angle1(mirror) = \
        atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
      Mirror_area(mirror) = 2 * pi * (R1arr(mirror) - R2arr(mirror)) \
                    * (0.5*(R1arr(mirror) + R2arr(mirror)));

      // Loop over energies

      for( j = 1; j <= n_earr; j++ ) {
         refl_coef = mt_get_rcoef( earr(j), mir_angle1(mirror) );
         eff_area_m( j, mirror ) = Mirror_area(mirror) * refl_coef;
      }
   }

   if( Num_modules > 1 ) { // include the second reflection

      mt_load, omfile=Om_files(2);

      //  Loop over all mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         coating = Mirror_coating(mirror);
         q = where( Coat_list.id == coating );
         if( numberof(q) == 0 ) error,"##17## coating problem";
         required_scatfile = Coat_list(q(1)).file;
         if( Scatter_file != required_scatfile ) {
            mt_load,scatfile=required_scatfile;
         }
         // account for the first reflection
         mir_angle = \
            atan((R1arr(mirror) - R2arr(mirror))/(Z1arr(mirror) - Z2arr(mirror)));
         angle = mir_angle - 2*mir_angle1(mirror);

         // Loop over energies

         for( j = 1; j <= n_earr; j++ ) {
            refl_coef = mt_get_rcoef( earr(j), angle );
            eff_area_m( j, mirror ) *= refl_coef;
         }
      }
   }

   if( numberof(Mirror_eff_factors) == N_mirrors ) {
      eff_area_m *= Mirror_eff_factors(-:1:n_earr,);
   } else {
      write,"NOT corrected for shielding by spokes";
      write,"You can run 'mt_get_mirror_eff_factors' to introduce";
      write,"the correction and then 'mt_eff_area_quick' again.";
   }
   eff_area = eff_area_m(,sum);

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_quick_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_eff_area_quick of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";
      if( numberof(Mirror_eff_factors) == N_mirrors ) {
         kwds_set,"COMMENT","Corrected for shielding by spokes";
      } else {
         kwds_set,"COMMENT","NOT corrected for shielding by spokes";
      }

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area,clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY and EFF_AREA";
   }

   return eff_area;
}

/* Function mt_get_mirror_eff_factors */

func mt_get_mirror_eff_factors
/* DOCUMENT mt_get_mirror_eff_factors

    Fills the external array 'Mirror_eff_factors' which holds
    each individual relative throughput not blocked by spokes.
    Only for on-axis rays so no concern about 'full length' spokes.

    Takes no arguments. Mainly useful for 'mt_eff_area_quick'.

    SEE ALSO: mt_eff_area_quick
*/
{
// ynclude = zbf
  extern N_mirrors, Mirror_eff_factors, Spoke_define_files, Om_files, \
         R1arr, R2arr, Module_num;
// yxclude =

   Mirror_eff_factors = array(1.0,N_mirrors); // Unity if no spokes are defined

   if( Spoke_define_files(1) != "none" ) {
      Module_num = 1;      // used by 'mt_spoke_read'
      mt_spoke_read,pos=1; // Load the entrance spokes
      mt_load,omfile=Om_files(1); // Load the first optical module


      // Loop over mirrors

      for( mirror = 1; mirror <= N_mirrors; mirror++ ) {
         radius = 0.5*(R1arr(mirror) + R2arr(mirror));
         // make 0.1 mm steps along circumference
         step = 0.1; // mm
         phi = span(0., 2*pi, long(2*pi*radius/step)+1)(1:-1);
         x = radius * cos(phi);
         y = radius * sin(phi);
         nphi = numberof(phi);
         block = 0;
         for( i = 1; i <= nphi; i++ ) {
            if( mt_spoke_blocking([x(i),y(i)],pos=1)(1) ) block++;
         }
         Mirror_eff_factors(mirror) = 1. - double(block)/nphi;
      }
   }
}

/* Function mt_bg_run */

func mt_bg_run( system_file, energy, offaxis, azimuth, no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )
/* DOCUMENT filelist_file = mt_bg_run( system_file, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, \
                dphot=, renorm=, fraper=, labxoff=, labyoff=, roll=, gbend=, \
                ncases=, dir=, nproc= )

     This function will start 'mt_run' in the background in several incarnation
     and then assemble all the Phs arrays finally. This takes advantage of a Linux
     machine with several CPUs. Returns name of file that holds the list of
     individual batch calls.

     'system_file' is the argument for mt_setup_system
     'energy', 'offaxis', 'azimuth' as for an ordinary call of mt_run
     'no_scatter', 'no_mdeform', 'gbend', 'dphot', and 'renorm' as for mt_run
     'fraper', 'labxoff', 'labyoff', and 'roll' as for mt_run
     'ncases' is the number of individual mt_run's (default: 20)
     'dir'    is the directory for the batch files and save files
     'nproc'  is the number of simultaneous processes (default: 10)

     'dphot' and 'renorm' apply to each individual run.

     Upon completion the saved 'Phs' arrays are assembled and saved into
     the external variable 'Phs'.

*/
{

// ynclude = eehd
   extern Phs, R_inner_design, R_outer, Fraper, Fraper_area, Dphot, \
          Src_offaxis, Src_azimuth, Use_mdeform, Use_scatter;
// yxclude =

   if( OSTYPE == "nonx" ) {
      write,"Sorry, this command is not valid for current OS";
      return [];
   }
   ncases = is_void(ncases) ? 20 : ncases;
   dir = is_void(dir) ? "." : dir;
   dir = app_slash( dir);
   nproc = is_void(nproc) ? 10 : nproc;

   if( !is_void(dphot) ) dphot = double(dphot);
   if( !is_void(renorm) ) renorm = double(renorm);
   list_name = get_next_filename(dir+"bg_run_????.list");
   fh = open( list_name, "w" );

   if( is_void(fraper) ) {
      mt_setup_system,system_file;
      fraper = [R_inner_design, R_outer, 0., 360. ];
   }
   Fraper = fraper;
   Fraper_area = pi * (fraper(2)^2 - fraper(1)^2) * (fraper(4)-fraper(3))/360.;

   // Set externals for later call of e.g. mt_save

   if( !is_void(dphot) ) Dphot = dphot * ncases;
   if( !is_void(offaxis) ) Src_offaxis = offaxis;
   if( !is_void(azimuth) ) Src_azimuth = azimuth;
   Use_scatter = no_scatter ? 0 : 1;
   Use_mdeform = no_mdeform ? 0 : 1;

   for( i = 1; i <= ncases; i++ ) {
      outstr = "_"+ranstr(15);
      write,fh,format="%s\n", dir+"y"+outstr+".ysav";
      _mt_bg_run, system_file, outstr, dir, \
               energy, offaxis, azimuth, \
               no_scatter=no_scatter, no_mdeform=no_mdeform, gbend=gbend, \
               dphot=dphot, renorm=renorm, fraper=fraper, labxoff=labxoff, \
               labyoff=labyoff, roll=roll;
      while( n_yoricks() > nproc ) {
         write,"Wait a bit, currently too many yorick processes ...";
         pause, 30000;
      }
   }
   close, fh;

   // Re assemble the 'Phs' array

   filenames = rdfile(list_name);
   n = numberof(filenames);

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(filenames(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+filenames(i)+" ...";
         fh = openb( filenames(i) );
         restore, fh;
         close, fh;
         grow, assembled_Phs, Phs;
         filenames = rem_elem( filenames, i );
         n--;
      }
   }

   //+ eq_nocopy, Phs, assembled_Phs;
   Phs = assembled_Phs;

   return list_name;
}

/* Function _mt_bg_run */

func _mt_bg_run( system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll= )
/* DOCUMENT _mt_bg_run, system_file, outfile, dir, energy, offaxis, azimuth, \
                no_scatter=, no_mdeform=, dphot=, renorm=, fraper=, gbend=, \
                labxoff=, labyoff=, roll=

    Produces a batch file '<dir>/ymbr_<random string>.ymbr' and a yorick save
    file '<dir>/ytmp_<random string>.ytmp' holding the resulting Phs array.

    The batch file is launched in the background.

    Note that 'outfile' is only the basic name, becomes y<outfile>.ysav

    SEE ALSO: mt_bg_run

    2011-09-22/NJW
*/
{
   fname = app_slash(dir)+"ymbr_"+ranstr(15)+".ymbr";
   fn = open(fname,"w");
   badir = get_env("HOSTSITE") == "CALTECH" ? "/users/njw/yorick" : "/home/njw/yorick";
   write,fn,format="#include \"%s/common.id\"%s",badir,"\n";
   write,fn,format="#include \"%s/mt_rayor.i\"%s",badir,"\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";

   // build the command

   comm = "mt_run,";
   s = typeof(energy) == "string" ? "\""+energy+"\"" : ftoa(energy,ndec=3);
   // First mt_run argument: energy
   comm += (s+","); // remember comma between parts
   // Second and third argument: offaxis and azimuth
   if( is_void(offaxis) ) offaxis = 0.0;
   if( is_void(azimuth) ) azimuth = 0.0;
   comm += (ftoa(offaxis,ndec=3)+","+ftoa(azimuth,ndec=3));
   // From now on we have only keywords with preceding commas
   if( no_scatter ) comm += (",no_scatter="+itoa(no_scatter));
   if( no_mdeform ) comm += (",no_mdeform="+itoa(no_mdeform));
   if( numberof(dphot) ) comm += (",dphot="+ftoa(dphot,ndec=3));
   if( numberof(renorm) ) comm += (",renorm="+ftoa(renorm,ndec=3));
   if( numberof(gbend) ) comm += (",gbend="+ftoa(gbend,ndec=4));
   if( numberof(fraper) ) {
      n = numberof(fraper);
      s = ",fraper=[";
      for(i=1;i<=n;i++) {
         s += ftoa(fraper(i),ndec=4);
         if( i < n ) s += ",";
      }
      s += "]";
      comm += s;
   }
   if( numberof(labxoff) ) comm += (",labxoff="+ftoa(labxoff,ndec=3));
   if( numberof(labyoff) ) comm += (",labyoff="+ftoa(labyoff,ndec=3));
   if( numberof(roll) ) comm += (",roll="+ftoa(roll,ndec=3));

   write,fn,format="%s,no_par=1;\n", comm;

   write,fn,format="mt_save,mode=\"s\",outfile=\"%s\",dir=\"%s\";\n", outfile, rem_slash(dir);
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_add_ysaves */

func mt_add_ysaves( file=, list=, reset= )
/* DOCUMENT mt_add_ysaves, file=, list=, reset=

    Add Phs's saved as 'save,fh,Phs'.

    Keywords:
       file     :  String (scalar or array) with text file(s)
                   containing ysave filenames.
       list     :  String (scalar or array) with ysave filenames.
       reset    :  Will reset the Phs, else Phs will be expanded.

    2011-09-23/NJW
*/
{
   extern Phs;

   if( numberof(file) && numberof(list) ) error,"Use 'file' xor 'list'";
   if( !(numberof(file) || numberof(list)) ) error,"Use one of 'file' or 'list'";

   filenames = [];

   if( !is_void(file) ) {
      for( i = 1; i <= numberof(file); i++ ) {
         if( !file_test(file(i)) ) {
            write,"Did not find "+file(i);
            continue;
         }
         grow, filenames, rdfile(file(i));
      }
   } else {
      filenames = list;
   }

   // Re assemble the 'Phs' array

   n = numberof(filenames);

   if( reset ) Phs = [];
   assembled_Phs = Phs;

   for( i = 1; i <= n; i++ ) {
      if( !file_test(filenames(i)) ) {
         write,"Failed to find "+filenames(i);
         continue;
      }
      write,"Getting data from "+filenames(i)+" ...";
      fh = openb( filenames(i) );
      restore, fh;
      close, fh;
      grow, assembled_Phs, Phs;
   }

   Phs = assembled_Phs;

}

/* Function mt_bg_run_eff_area */

func mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, ncases=, dir=, nproc= )
/* DOCUMENT eff_area = mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, \
              no_scatter, no_mdeform, dphot, earr, outfile=, \
              ncases=, dir=, nproc= )

    Running a number of background processes for the effective area determination.

    Keywords:
      ncases  :  Number of runs of the eff. area determination [default 20]
         dir  :  Directory for temporary files [default '.']
       nproc  :  Maximum number of simultaneous processes [default 20]
*/
{
// ynclude = rwwe
   extern Telescop, Instrume;
// yxclude =

   if( is_void(ncases) ) ncases = 20;
   if( is_void(nproc) ) nproc = 20;
   if( is_void(dir) ) dir = ".";
   dir = app_slash(dir);
   energy = double(energy);
   offaxis = double(offaxis);
   azimuth = double(azimuth);
   earr = double(earr);
   dphot = double(dphot);

   local serstrf;
   first_file = get_next_filename("mbr_eff_area_?????.fits",serstrf,dir=dir);
   s = atoi(serstrf);
   ss = indgen(s:s+ncases-1);
   intermediate_files = dir+"mbr_eff_area_"+itoa(ss,5)+".fits";

   for( i = 1; i <= ncases; i++ ) {
      _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, \
               no_scatter, no_mdeform, dphot, earr, intermediate_files(i), dir;
      while( n_yoricks() > nproc ) {
         write,"Waiting for free processes ...";
         pause, 30000;
      }
   }

   // Add up the individual effective area files

   n = ncases;

   assembled_Phs = [];

   while( n > 0 ) {
      for( i = 1; i <= n; i++ ) {
         if( !file_test(intermediate_files(i)) ) continue;
         // heureca ! found one
         pause, 2000; // give time to finish writing
         write,"Getting data from "+intermediate_files(i)+" ...";

         hdr = headfits( intermediate_files(i)+"+1" );
         area = rdfitscol(intermediate_files(i)+"+1","EFF_AREA");
         if( n == ncases ) {
            nphot_in = fxpar( hdr, "NPHOT_IN");
            nphotons = fxpar( hdr, "NPHOTONS");
            eff_area = area(,-);
            ap_area = fxpar( hdr, "AP_AREA");
         } else {
            grow, eff_area, area;
            nphot_in += fxpar( hdr, "NPHOT_IN");
            nphotons += fxpar( hdr, "NPHOTONS");
         }

         intermediate_files = rem_elem( intermediate_files, i );
         n--;
      }
      write,"Waiting for eff. area file ...";
      pause,2000;
   }

   // Got all data, make average and write to FITS file

   eff_area_avg = eff_area(,avg); // is now average
   eff_area_err = eff_area(,rms)/sqrt(ncases); // is now error

   if( is_set(outfile) ) {

      if( structof(outfile) != string ) \
         outfile = get_next_filename("eff_area_????.fits");

      kwds_init;
      kwds_set,"DATE",ndate(3),"Time of file creation";
      kwds_set,"ORIGIN","mt_bg_run_eff_area of MT_RAYOR-"+Version,"Software used";
      kwds_set,"RESPONSI","Niels J. Westergaard","Responsible programmer";
      kwds_set,"SITE","NSI/DTU","Institution";
      if( !is_void(Telescop) ) kwds_set,"TELESCOP", Telescop,"Name of telescope or mission";
      if( !is_void(Instrume) ) kwds_set,"INSTRUME", Instrume,"Name of instrument";
      if( typeof(energy) == "double" ) {
         kwds_set,"ENERGYIN", energy, "[keV] Energy of injected photons";
      } else {
         kwds_set,"COMMENT","A photon flux file was used as input";
      }
      if( !is_void(offaxis) ) kwds_set,"SRC_OFAX",offaxis,"[arcmin] Source off axis angle";
      if( !is_void(azimuth) ) kwds_set,"SRC_AZIM",azimuth,"[degrees] Source azimuth angle";
      kwds_set,"NPHOT_IN",nphot_in,"Total number of injected photons";
      kwds_set,"NPHOTONS",nphotons,"Total number of accepted photons";
      kwds_set,"AP_AREA",ap_area,"[mm2] Aperture area of telescope";
      kwds_set,"TUNIT1","keV","Unit of first column: ENERGY";
      kwds_set,"TUNIT2","mm2","Unit of second column: EFF_AREA";

      wrmfitscols,outfile,"ENERGY",earr,"EFF_AREA",eff_area_avg, \
            "EFF_AREA_ERR", eff_area_err, clobber=1;
      write,format="%s has been written\n", outfile;
      write,"with columns ENERGY, EFF_AREA, and EFF_AREA_ERR";

   }

   write,format="Geometrical active area: %7.2f cm2\n", 0.01 * (ap_area * nphotons) / nphot_in;

   return eff_area_avg;
}

/* Function _mt_bg_run_eff_area */

func _mt_bg_run_eff_area( energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir )
/* DOCUMENT _mt_bg_run_eff_area, energy, offaxis, azimuth, system_file, no_scatter, \
                no_mdeform, dphot, earr, outfile, dir

    Produces a batch file 'mbr_<random string>.ymac' and an FITS file with the
    energy array: 'tmp_<random string>.fits', both in directory 'dir', for the
    production of an effective area file in 'outfile'. The batch file is
    launched in the background.

    2011-09-04/NJW
*/
{
   if( is_void(dir) ) dir = "."; // defaults to current directory
   dir = app_slash(dir);
   fname = dir+"mbr_"+ranstr(15)+".ymac";
   tmpfil = dir+"tmp_"+ranstr(15)+".fits";
   kwds_init;
   wrmfitscols,tmpfil,"EARR",earr;
   fn = open(fname,"w");
   write,fn,format="#include \"/home/njw/yorick/common.id\"%s","\n";
   write,fn,format="#include \"/home/njw/yorick/mt_rayor.i\"%s","\n";
   write,fn,format="%s\n","mt_setup_system,\""+system_file+"\";";
   write,fn,format="mt_run,%.2f,%.2f,%.2f,no_scatter=%i,no_mdeform=%i,dphot=%.4f;\n", \
       energy, offaxis, azimuth, no_scatter, no_mdeform, dphot;
   write,fn,format="earr = rdfitscol(\"%s+1\",\"EARR\");\n", tmpfil;
   write,fn,format="mt_eff_area_photons,earr=earr,outfile=\"%s\";\n",outfile;
   write,fn,format="%s\n","quit";
   close, fn;
   system,"yorick -batch "+fname+" &";
}

/* Function mt_aperture_stop */

func mt_aperture_stop( z_position, open_radius, cen_dx=, cen_dy=, photfile=, undo=, chat= )
/* DOCUMENT mt_aperture_stop, z_position, open_radius, cen_dx=, cen_dy=, photfile=, undo=, chat=

    will update Phs.status if equal to zero to 201 for photons
    passing outside of a circle centered on the optical axis
    with radius 'open_radius' at a z-position 'z_position'
    above the focal plane.  For NuSTAR z_position is 833.187 mm,
    and open_radius = 29 mm.

    To take effect this subroutine should be called after 'mt_run' has finished.

    When called with arguments the external variables 'Z_position_as' and
    'Open_radius_as' are defined so for following calls no arguments are required.

    Keywords
        cen_dx      [mm] displacement in x-direction
        cen_dy      [mm] displacement in y-direction
        photfile    Operate on the named photonfile
        undo        Undo the operation on the named photonfile
        chat        Display certain extra information

    2011-10-24/NJW
*/
{
// ynclude = udts
   extern Phs, Z_position_as, Open_radius_as, Cen_dx_as, Cen_dy_as;
// yxclude =

   // When neither the argument nor the external variable is defined:
   if( is_void(z_position) && is_void(Z_position_as) ) error,"First argument must be defined";
   if( is_void(open_radius) && is_void(Open_radius_as) ) error,"Second argument must be defined";

   if( !is_void(z_position) ) {
      Z_position_as = double(z_position);
   }
   if( !is_void(open_radius) ) {
      Open_radius_as = double(open_radius);
   }

   // Shifting center position in x/y directions

   if( is_void(cen_dx) ) {
      if( is_void(Cen_dx_as) ) Cen_dx_as = 0.0;
   } else {
      Cen_dx_as = double(cen_dx);
   }
   if( is_void(cen_dy) ) {
      if( is_void(Cen_dy_as) ) Cen_dy_as = 0.0;
   } else {
      Cen_dy_as = double(cen_dy);
   }

   if( is_void(photfile) ) {

      if( is_void(Phs) ) {
         write,"External 'Phs' does not exist, no action.";
         return; // If no photons then only set externals
      }
      w0 = where( Phs.status == 0 );
      if( numberof(w0) == 0 ) {
         if( chat ) write,"Found no status zero photons, no action.";
         return; // No good photons, simply skip this step
      }

      mt_propagate, Z_position_as;
      eq_nocopy, cE, Phs.E;
      r = sqrt((cE(1,w0)-Cen_dx_as)^2 + (cE(2,w0)-Cen_dy_as)^2);
      w = where( r > Open_radius_as );
      if( numberof(w) ) Phs(w0(w)).status = 201;
      mt_propagate, 0.0; // set photon positions (back) to focal plane

   } else {  // Operate on a photon file

      if( !file_test(photfile) ) {
         write,"Photfile: "+photfile+" was not found, no action.";
         return;
      }

      local hdr, nrows;
      ptr = rdfitsbin( photfile+"+1", hdr, nrows );
      colstat = fits_colnum(hdr,"status");
      status = *ptr(colstat);
      detx = *ptr(fits_colnum(hdr,"detx"));
      dety = *ptr(fits_colnum(hdr,"dety"));
      rayx = *ptr(fits_colnum(hdr,"rayx"));
      rayy = *ptr(fits_colnum(hdr,"rayy"));
      rayz = *ptr(fits_colnum(hdr,"rayz"));

      if( undo ) {
         nw = numberof( (w = where( status == 201 ) ) );
         if( nw == 0 ) {
            if( chat ) write,"Found no status 201 photons, no action.";
            return; // No 201 photons, simply skip this step
         }
         status(w) = 0; // Remove aperture stop signature
         if( chat ) write,"Updating "+photfile+" with "+itoa(nw)+" reversals to  status zero ...";
         fits_bintable_poke, photfile+"+1", 1, colstat, status;
         if( chat ) write,"done";

      } else {

         nw = numberof( (w = where( status == 0 ) ) );
         if( nw == 0 ) {
            if( chat ) write,"Found no status zero photons, no action.";
            return; // No good photons, simply skip this step
         }

         kount = 0;
         for( i = 1; i <= nw; i++ ) {
            p = _propa([detx(w(i)),dety(w(i)),0.],[rayx(w(i)),rayy(w(i)),rayz(w(i))],Z_position_as);
            if( sqrt( (p(1) - Cen_dx_as)^2 + (p(2) - Cen_dy_as)^2) > Open_radius_as ) {status(w(i)) = 201; kount++;}
         }
         if( kount ) {
            if( chat ) write,"Updating "+photfile+" with "+itoa(kount)+" times status 201 ...";
            fits_bintable_poke, photfile+"+1", 1, colstat, status;
            if( chat ) write,"done";
         } else {
            if( chat ) write,"No update of "+photfile+" was required.";
         }
      }
   }
}

/* Function mt_translate */

func mt_translate( iphot, dx=, dy= )
/* DOCUMENT mt_translate, iphot, dx=, dy=

   Translates photon(s) in X and Y direction as indicated
   by keywords 'dx' and 'dy'.
   'iphot' is an array of indices to Phs. If not given
   'mt_translate' will operate on all photons.

   The struct element 'E' will be updated.

   2011-11-10/NJW
*/
{
   if( is_void(iphot) ) {
      cE = Phs.E;
      if( !is_void(dx) ) cE(1,) += dx;
      if( !is_void(dy) ) cE(2,) += dy;
      Phs.E = cE;
   } else {
      cE = Phs(iphot).E;
      if( !is_void(dx) ) cE(1,iphot) += dx;
      if( !is_void(dy) ) cE(2,iphot) += dy;
      Phs(iphot).E = cE;
   }
}

/* Function mt_info */

func mt_info( void )
/* DOCUMENT mt_info

   Takes no arguments. Displays basic information on the current telescope under
   investigation.
*/
{
// ynclude = zzxf
   extern Om_files, System_filename, Scat_files;
// yxclude =

   write," --- Information about currently loaded system ---";
   if( structof(System_filename) == string ) {
      write,"System file: "+System_filename;
   } else write,"System file is badly or not defined";
   if( structof(Om_files) == string ) {
      if( strlen(Om_files(1)) ) {
         write,"OM file 1  : "+Om_files(1);
      } else write,"OM file 1 is not defined"
      if( numberof(Om_files) > 1 ) {
         if( strlen(Om_files(1)) ) {
            write,"OM file 2  : "+Om_files(2);
         } else write,"OM file 2 is not defined"
      }
   } else write,"No OM files are defined";
}

/* Function mt_gravity_bend */

func mt_gravity_bend( gbend, mlength= )
/* DOCUMENT mt_gravity_bend, gbend, mlength=

    Make mirror deformation from circular bending of an X-ray telescope
    horizontally suspended in a gravitational field giving largest deviation
    in the middle.

    deform = -delta_r = -(gbend/mlength^2) * (z + mlength) * (z - mlength)

    for mirror parts above the axis and with reversed sign below the axis.
    Sign reversal is taken care of by the sine function in azimuth.

        For 1-alpha   z c [ 0., mlength]
        For 3-alpha   z c [-mlength, 0.]

    The 'gbend' parameter is the distance (same unit as 'mlength', often mm)
    between the cord and the circular arc where it is at a maximum,
    i.e. right between the 1alpha and 3alpha mirror sections.

    Use dimensions from already existing deformation cube Mirror_deform_arr.

    The mirror length can be set with keyword 'mlength' (defaults to 225. mm)

    2012-06-04/NJW

*/
{
   extern Mirror_deform_arr, Module_num, Roll_phot;

   //   Module_num is either 1 (U or 1-alpha section) or 2 (L or 3-alpha section)

   if( is_void(mlength) ) mlength = 225.; // mm - mirror length

   dms = dimsof( Mirror_deform_arr );

   naz = dms(2);
   nz =  dms(3);
   nlayers = dms(4);

   // Ensure that the largest deviation is found for low indices
   // for the 1-alpha section

   if( Module_num == 1 ) {

      z = span(0.,mlength,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   } else {

   // Ensure that the largest deviation is found for high indices
   // for the 3-alpha section

      z = span(-mlength,0.,nz);
      yz = -gbend * (z + mlength) * (z - mlength) / mlength^2;

      ya = sin(span(0.,2*pi,naz) - Roll_phot);

      Mirror_deform_arr += ((ya(,-:1:nz)) * (yz(-:1:naz,)))(,,-:1:nlayers);

   }

}

/* Function mt_substr_volume */

func mt_substr_volume( void )
{
// ynclude = jdhf
   extern Mirror_thicknessarr, Num_modules, R1arr, R2arr, Om_files, Z1arr, Z2arr;
// yxclude =

   // Loading first mirror module;
   mt_load,omfile=Om_files(1);

   // vol = Mirror_thicknessarr * 0.5 * (R1arr + R2arr) * 2 * pi * (Z1arr - Z2arr);
   vol = pi * sum( Mirror_thicknessarr * (R1arr + R2arr) * (Z1arr - Z2arr) );

   if( Num_modules > 1 ) {
      mt_load,omfile=Om_files(2);
      vol += pi * sum( Mirror_thicknessarr * (R1arr + R2arr) * (Z1arr - Z2arr) );
   }

   write,format="Substrate volume = %10.2e mm3 = %10.2e liters\n", vol, vol*1.e-6;

   return vol;

}
%FILE% mt_skydist2skyspec.i
/* Function mt_skydist2skyspec */

/************************************************
 *
 *   Convert some sky distribution image to a sky spectral
 *   definition file.
 *
 *   The distribution can be
 *        - In S-flux (DISTTYPE  SFLUX)
 *        - In photon intensity at given energy (DISTTYPE  PHINTENS)
 *    The distribution type can be given as FITS keyword or as keyword
 *    to this function.
 *
 *    Information needed:
 *        Total S-flux of object in erg/cm2/s in given energy interval
 *        Spectral models i.e. spectral code, param1, nh
 *
 ************************************************/


func mt_skydist2skyspec( dol_skydist, outfile, totflux, emin, emax, \
                        fraclim=, sc=, nh=, p1=, disttype=, phenergy=, chat= )
/* DOCUMENT mt_skydist2skyspec, dol_skydist, outfile, totflux, emin, emax, \
            fraclim=, sc=, nh=, p1=, disttype=, phenergy=, chat=

   Uses a sky distribution, 'dol_skydist', to produce
   a sky spectral definition file (SSDF) - in short: a skyspec file,
   which has arrays with normalization factors, spectral parameter,
   and column densities.
   The last two may reduce to keywords in the first extension if a
   constant value is to be used. The ancillary response file (ARF)
   that should be pertinent for the input sky image is copied to the
   output sky spectral definition file.

   If 'emin' and 'emax' are not given here they must be found as FITS
   header keywords. Similarly the DISTTYPE must be found as a FITS
   keyword if not given in the call of the function. In case of a conflict
   the function keywords will override the FITS keywords.

   Arguments: totflux  flux in erg/cm2/s between energies emin and emax

   Keyword 'fraclim' defines the selection:
                    where(skydist > fraclim*max(skydist))
                    (defaults to 0.02)

   The keywords define a spectral model:
            sc   :  spectral code "PL" (default), "BB", or "TB"
            nh   :  column density, (defaults to 1e21), a scalar
                      value or a DOL to a map
            p1   :  spectral parameter, (defaults to 2.0), a scalar
                      value or a DOL to a map
                      -> for "PL"  the photon index
                      -> for "TB" and "BB" the temperature (kT) in keV

   SEE ALSO: mt_skyima2skyspec, mt_skyspec2skydef

   2012-09-11/NJW

*/
{
   if( is_void(chat) ) chat = 0;
   nchat3 = 0;
   skydist = readfits(dol_skydist);
   skydist /= sum(skydist); // normalize to sum 1.0
   hdr_skydist = headfits(dol_skydist);
   dms = dimsof(skydist);
   norm_map = array(float,dms);
   if( chat > 0 ) write,"Mark 1: distribution retrieved";

   //  Determine the type of distribution
   if( is_void(disttype) ) disttype = fxpar(hdr_skydist,"disttype");
   if( is_void(disttype) ) error,"##1## DISTTYPE has not been defined.";
   disttype = strupcase(disttype);
   if( chat > 0 ) write,"Mark 2: distribution type "+disttype;

   //  Analyse the type of distribution
   if( disttype == "SFLUX" ) { // Must be accompanied by EMIN and EMAX
      if( is_void( emin ) ) emin = fxpar(hdr_skydist,"EMIN");
      if( is_void( emax ) ) emax = fxpar(hdr_skydist,"EMAX");
      if( is_void( emin ) ) error,"##2## EMIN has not been defined";
      if( is_void( emax ) ) error,"##3## EMAX has not been defined";
      e1 = emin; e2 = emax;
   } else if( disttype == "PHINTENS" ) { // Must be accompanied by PHENERGY
      if( is_void( phenergy ) ) phenergy = fxpar(hdr_skydist,"PHENERGY");
      if( is_void( phenergy ) ) error,"##4## PHENERGY has not been defined";
      e2 = phenergy + 0.1;
      e1 = phenergy^2 / e2;
   } else error,"##5## Illegal DISTTYPE";
   if( chat > 1 ) {
      write,"Mark 3: emin = "+ftoa(emin,ndec=3);
      write,"        emax = "+ftoa(emax,ndec=3);
      write,"        e1   = "+ftoa(e1,ndec=3);
      write,"        e2   = "+ftoa(e2,ndec=3);
   }

   if( is_void(fraclim) ) fraclim = 0.02;
   src = where(skydist > fraclim*max(skydist));
   nsrc = numberof(src);
   if( chat > 0 ) write,"Mark 4: number of src pixels = "+itoa(nsrc);

   if( is_void(sc) ) sc = "PL";
   if( is_void(nh) ) nh = 1.e21;
   if( typeof(nh) == "string" ) { // it must be a DOL
      nhdol = nh;
      nhmap = readfits(nhdol);
      d = dimsof(nhmap);
      if(anyof(dms-d)) error,"Mismatching dimensions in skydist and nh-map";
      if( chat > 0 ) write,"Mark 5: nh included as a map.";
   } else {
      nhmap = [];
   }
   if( is_void(p1) ) p1 = 2.;
   if( typeof(p1) == "string" ) { // it must be a DOL
      p1dol = p1;
      p1map = readfits(p1dol);
      d = dimsof(p1map);
      if(anyof(dms-d)) error,"Mismatching dimensions in skydist and p1-map";
      if( chat > 0 ) write,"Mark 6: p1 included as a map.";
   } else {
      p1map = [];
   }


   // Loop over all 'active' pixels

   sum_flux = 0.0;

   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      // generate a photon flux in the energy interval relevant for
      // the instrument that has produced the sky image

      if( disttype == "SFLUX" ) {
         mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=e1,e2=e2,\
               nchan=100,nof=1,silent=1;
         // produces Eline, Flux, Sx_photflux
         // calculate sflux from a norm=1 spectrum
         SF = 1.6e-9*sum(Flux(zcen)*Eline(zcen)*Eline(dif));
         k_norm = skydist(src(i))*totflux/SF;
         norm_map(src(i)) = k_norm;
         if( chat > 3 ) {
            ii = indices( skydist, src(i) );
            write,"Mark 7: SFLUX i = "+itoa(i)+", ("+itoa(ii(1))+","+itoa(ii(2))+")";
            write,"          SF = "+ftoa(SF, ndec=2, sci=1)+", k_norm = "+ftoa(k_norm,ndec=2,sci=1);
            if( ++nchat3 > 100 ) chat = 2;
         }
      } else {
         mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=e1,e2=e2,\
               nchan=3,nof=1,silent=1;
         // produces Eline, Flux, Sx_photflux
         skydist(src(i)) /= Flux(2);
         mk_photflux,sc=sc,nh=nh,p1=p1,norm=1.,e1=emin,e2=emax,\
               nchan=100,nof=1,silent=1;
         // produces Eline, Flux, Sx_photflux
         SF = 1.6e-9*sum(Flux(zcen)*Eline(zcen)*Eline(dif));
         sum_flux += skydist(src(i))*SF;
         if( chat > 3 ) {
            ii = indices( skydist, src(i) );
            write,"Mark 8: SFLUX i = "+itoa(i)+", ("+itoa(ii(1))+","+itoa(ii(2))+")";
            write,"          SF = "+ftoa(SF, ndec=2, sci=1)+", skydist = "+ftoa(skydist,ndec=2,sci=1);
            if( ++nchat3 > 100 ) chat = 2;
         }
      }
   }
   if( disttype == "PHINTENS" ) {
      lambda = totflux / sum_flux;
      norm_map = lambda * skydist;
      if( chat > 1 ) write,"Mark 9: lambda = "+ftoa(lambda, ndec=2, sci=1);
   }
   tot_em_flux = [];
   for( i = 1; i <= nsrc; i++ ) {
      if( !is_void(nhmap) ) nh = nhmap(src(i));
      if( !is_void(p1map) ) p1 = p1map(src(i));
      mk_photflux,sc=sc,nh=nh,p1=p1,norm=norm_map(src(i)),e1=emin,e2=emax, \
            nchan=100,nof=1,silent=1;
      if( is_void(tot_em_flux) ) {
         tot_em_flux = Flux;
      } else {
         tot_em_flux += Flux;
      }
   }
   sxtot = sflux(emin,emax,Eline,tot_em_flux);
   write,format="Sx from entire image: %.3e erg/s/cm2 in %.1f-%.1f keV\n", \
                 sxtot, emin, emax;
   kwds_init;
   kwds_set,"EXTNAME","NORM_MAP","Name of this extension";
   kwds_set,"SKYIMAIN",dol_skydist,"DOL of input sky ima";
   kwds_set,"FRACLIM",fraclim,"selects: > fraclim*max(ima)";
   kwds_set,"E_MIN",emin,"[keV] Lower energy limit";
   kwds_set,"E_MAX",emax,"[keV] Upper energy limit";
   kwds_set,"SC",sc,"Spectral code PL, BB, or TB";
   if( !is_void(p1map) ) {
      kwds_set,"P1MAP",p1dol,"DOL of applied p1 map";
   } else {
      kwds_set,"PARAM1", p1,"Value of param1 for entire image";
   }
   if( !is_void(nhmap) ) {
      kwds_set,"NHMAP",nhdol,"DOL of applied nh map";
   } else {
      kwds_set,"NH", nh,"Value of nh for entire image";
   }
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from E_MIN to E_MAX";
   s1 = swrite(format="%.2f", emin);
   s2 = swrite(format="%.2f", emax);
   kwds_set,"SXTOTAL",sxtot,"[erg/cm2/s] from "+s1+" to "+s2+" keV";

   // Copy coordinate defining keywords

   clist = "CRVAL1,CRVAL2,CRPIX1,CRPIX2,CDELT1,CDELT2,";
   clist += "CROTA2,CTYPE1,CTYPE2,CUNIT1,CUNIT2,";
   clist += "CD1_1,CD1_2,CD2_1,CD2_2";
   fits_copy_keys,hdr_skydist,list=clist, tokwds=2;
       // tokwds is given a value of 2 to avoid initialization of keywords

   cont = !is_void(p1map) | !is_void(nhmap); // only continue if another map is defined
   fh = writefits(outfile,norm_map,clobber=1,cont=cont);


   // Add the p1map array (if defined)

   if( !is_void(p1map) ) {
      cont = !is_void(nhmap); // only continue if nhmap exists
      kwds_set,"EXTNAME","P1MAP","Name of this extension";
      fh = writefits( fh, p1map,cont=cont);
   }

   // Add the nhmap array (if defined)

   if( !is_void(nhmap) ) {
      kwds_set,"EXTNAME","NHMAP","Name of this extension";
      fh = writefits( fh, nhmap);
   }
}

%FILE% mtest.i
/****************************************

    Testing ideas for MT_RAYOR-4.0

    2011-06-08/NJW
*****************************************/

struct s_PCR { // Photon creation
   double energy;
   double direc(3);
   double posit(3);
   char fate(10);
   long status;
   pointer pnexta(10);
   pointer pnext;
}

struct s_ATZ { // Values at specified Z
   double energy;
   double rcoef;
   double direc(3);
   double posit(3);
   long status;
}

struct s_RFL { // Photon reflection
   long phid; // index in photon (creation) array
   double energy;
   double rcoef;
   double direc(3);
   double posit(3);
   double angles(2); // angles in, out
   pointer pnext;
}

struct s_ASP { // Photon absorption
   long phid;
   double posit(3);
}

/*
 *    Generate the photons
 */

N = 200;
Photons = array( s_PCR, N);
Atz = array( s_ATZ, N);
Photons.energy = span(1.,70.,N);
v = p = array(double,3);
for( i = 1; i <= N; i++ ) {
   v(1) = 0.5*(random()-0.5);
   v(2) = 0.5*(random()-0.5);
   v(3) = 1.;
   v /= sqrt(sum(v^2));
   Photons(i).direc(1) = v(1); // direction more or less in
   Photons(i).direc(2) = v(2); // positive z-direction
   Photons(i).direc(3) = v(3);
   Photons(i).posit(1) = 0.; // start position
   Photons(i).posit(2) = 0.;
   Photons(i).posit(3) = 0.;
}

/*
 *  Propagate to z == 4
 */

zplane = 4.;
for( i = 1; i <= N; i++ ) {
   t = (zplane - Photons(i).posit(3))/Photons(i).direc(3);
   Atz(i).posit = Photons(i).posit + t * Photons(i).direc;
   Atz(i).direc = Photons(i).direc;

   r = sqrt(Atz(i).posit(1)^2 + Atz(i).posit(2)^2);
   if( r > 1.3 ) { // absorption at the edge of the tube - where?
      za = zplane * r / 1.3;
      t = (za - Photons(i).posit(3))/Photons(i).direc(3);
      abso = s_ASP();
      abso.phid = i;
      abso.posit = Photons(i).posit + t * Photons(i).direc;
      idxf = 0; // record the fate in Photons
      while(Photons(i).fate(++idxf) != 0);
      Photons(i).fate(idxf) = 'a'; // signifying absorption
      Photons(i).pnexta(idxf) = &abso;
      Photons(i).pnext = &abso;
      Photons(i).status = 1; // signal for absorption
   } else {
      
/*
 *    A reflection might happen at z == 4
 */

      if( r > 0.5 ) { // a reflection does happen
         refl = s_RFL();
         refl.phid = i; // original photon index
         refl.posit = Atz(i).posit;
         refl.direc(1) = Atz(i).direc(1)*0.8;
         refl.direc(2) = Atz(i).direc(2)*0.8;
         refl.direc(3) = sqrt(1. - refl.direc(1)^2 - refl.direc(2)^2);
         Atz(i).direc = refl.direc;
         refl.energy = Photons(i).energy;
         idxf = 0;
         while(Photons(i).fate(++idxf) != 0);
         Photons(i).fate(idxf) = 'r'; // signifying reflection
         Photons(i).pnexta(idxf) = &refl;
         Photons(i).pnext = &refl;
      }
   }
}

/*
 *  Second intersection plane at z==8
 */

zplane = 8.;
asel = array(int,N);

// Propagate one by one since interactions might have happened

for( i = 1; i <= N; i++ ) {
   // check for interaction in Photons.fate
   if( Photons(i).fate(1) == 0 ) { // No interaction, simple propagation
      t = (zplane - Photons(i).posit(3))/Photons(i).direc(3);
      Photons(i).posit += t * Photons(i).direc;
   } else {
      // Locate latest interaction
      j = 0;
      st = Photons(i);
      while( Photons(i).fate(++j) != 0 ) {
         if( Photons(i).fate(j) == 'a' ) continue;
         stt = *st.pnext;
         st = stt;
      }
      p = st.posit;
      v = st.direc;
      t = (zplane - p(3))/v(3);
      p += t*v;
      r = sqrt(sum(p(1:2)^2));
      if( r > 1. ) { // new reflection
         asel(i) = 1;
         refl = s_RFL();
         refl.phid = i; // original photon index
         refl.posit = p;
         refl.direc(1) = v(1)*0.8;
         refl.direc(2) = v(2)*0.8;
         refl.direc(3) = sqrt(1. - refl.direc(1)^2 - refl.direc(2)^2);
         refl.energy = st.energy;
         Photons(i).fate(j) = 'r'; // signifying reflection
         Photons(i).pnexta(j) = &refl;
         Photons(i).pnext = &refl;
      }
   }
}

func reflection( i, p, v, energy )
/* DOCUMENT stru_RFL = reflection( i, p, v, energy )
   i is phid number
   p is three element position vector
   v is three element direction vector
   energy is the scalar energy [keV]
*/
{
   refl = s_RFL();
   refl.phid = i; // original photon index
   refl.posit = p;
   refl.direc(1) = v(1)*0.8;
   refl.direc(2) = v(2)*0.8;
   refl.direc(3) = sqrt(1. - refl.direc(1)^2 - refl.direc(2)^2);
   refl.energy = energy;
   j = 1; while( Photons(i).fate(j) != 0 ) j++;
   Photons(i).fate(j) = 'r'; // signifying reflection
   Photons(i).pnexta(j) = &refl;
   Photons(i).pnext = &refl;


   return refl;
}


func pphot( i )
{
   write,format="%s : ","posit";
   for(j=1;j<=3;j++) write,format="%7.3f", Photons(i).posit(j);
   write,format="%s","\n";
   write,format="%s : ","direc";
   for(j=1;j<=3;j++) write,format="%7.3f", Photons(i).direc(j);
   write,format="%s","\n";
   write,format="status : %i\n", Photons(i).status;
   write,format="fate : >%s<\n", string(&Photons(i).fate);

   idxj = 0;
   while( Photons(i).fate(++idxj) != 0 ) {
      if( Photons(i).fate(idxj) == 'r' ) { // reflection
         write,format="Refl - %s : ","posit";
         for(j=1;j<=3;j++) write,format="%7.3f", (*Photons(i).pnexta(idxj)).posit(j);
         write,format="%s","\n";
         write,format="Refl - %s : ","direc";
         for(j=1;j<=3;j++) write,format="%7.3f", (*Photons(i).pnexta(idxj)).direc(j);
         write,format="%s","\n";
      } else if( Photons(i).fate(idxj) == 'a' ) { // absorption
         write,format="Abso - %s : ","posit";
         for(j=1;j<=3;j++) write,format="%7.3f", (*Photons(i).pnexta(idxj)).posit(j);
         write,format="%s","\n";
      } else write,"N/A";
   }
}

func poinext( stru )
{
}
%FILE% multi_xspec_fit.i
func multi_xspec_fit( list, template=, outfile= )
/* DOCUMENT multi_xspec_fit, list, template=, outfile=

   When given a list of spectral files (with full path) then
   a result file by name of 'multi_xspec_fit_summary.scm' will
   be produced in the current directory or as given by 'outfile'.

   Operates in the directory of the spectrum files, where the
   XSPEC log files also are placed.

   Keyword 'template' must be
       1) void     - uses *)
       2) "noplot" - uses *)
       3) "plot"   - uses **)
       4) a file name of a template file that has a format similar to *)

  *)  /home/njw/jemx/crab_calib/cal_iws7/crabfit_noplot_template.xcm
  **) /home/njw/jemx/crab_calib/cal_iws7/crabfit_plot_template.xcm

   Original version ca. 2008-12, updated 2012-02-23/NJW
*/
{

   local dname, bname;

   if( is_void(template) ) template = "/home/njw/jemx/crab_calib/cal_iws7/crabfit_noplot_template.xcm";
   if( template == "noplot" ) template = "/home/njw/jemx/crab_calib/cal_iws7/crabfit_noplot_template.xcm";
   if( template == "plot" ) template = "/home/njw/jemx/crab_calib/cal_iws7/crabfit_plot_template.xcm";

   if( !file_test(template) ) error,"Template file not found: "+template;

   if( is_void(outfile) ) outfile = "multi_xspec_fit_summary.scm";

   outfile = fullpath(outfile);
   curdir = get_cwd();

   tpl = read_slist( template );

   // see if 'flux' has been requested in the template file

   fluxkey = anyof(strmatch(tpl,"flux"));

   ntpl = numberof(tpl);
   nlist = numberof(list);

   for( i = 1; i <= nlist; i++ ) {

      // update the template 'xspec' macro file
      // with appropriate names

      splitfname, list(i), dname, bname;
      xlogname = strpart(bname,1:-5)+".xspeclog";

      //   cd  to actual spectral file directory

      cd, dname;
      macro = tpl;
      for( j = 1; j <= ntpl; j++ ) {
         macro(j) = strstrrepl( macro(j), "__xspeclog__", xlogname );
         macro(j) = strstrrepl( macro(j), "__specfile__", bname );
      }

      // write the resulting macro file and call XSPEC
      write_slist, "stdfit.xcm", macro;
      system,"xspec - stdfit";

      // The parameter values are appended to the 'outfile'
      res = get_xspec_fit_params( xlogname, flux=fluxkey, outfile=outfile )

   }

   // return to where you started

   cd, curdir;

}
%FILE% newstring.i

/*---------------------------------------------------------------------------*/
local _ctoupper;
local _ctolower;
/* DOCUMENT _ctoupper
            _ctolower
     Arrays to convert char to upper/lowercase letters.
 */
_ctolower= _ctoupper=  char(indgen(0:255));
_ctoupper(1+'a':1+'z')= _ctoupper(1+'A':1+'Z');
_ctolower(1+'A':1+'Z')= _ctolower(1+'a':1+'z');

func chartolower(c) { return _ctolower(1+c); }
func chartoupper(c) { return _ctoupper(1+c); }
/* DOCUMENT cp= chartolower(c);
            cp= chartoupper(c);
     Convert an array of char to lower/upper case letters.
 */

func strtolower(s) {return strtranslate(s, _ctolower); }
func strtoupper(s) {return strtranslate(s, _ctoupper); }
/* DOCUMENT sp= strtolower(s);
            sp= strtoupper(s);
     Convert a string or an array of strings to lower/upper case letters.

   SEE ALSO: strtranslate, strtrtable.
 */
/*---------------------------------------------------------------------------*/
func strtranslate(s, tr)
/* DOCUMENT sp= strtranslate(s, tr);
     Convert a string or an array of strings given a translation table TR.
     TR must be an array of 256 char (this is not checked).

   SEE ALSO: strtolower, strtoupper, strtrtable.
 */
{
    d= dimsof(s);
    if (d(1) == 0)
	return string(&tr(1+*pointer(s)));
    r= array(string, d);
    n= numberof(s);
    for (i=1; i<=n; i++)
	r(i)= string(&tr(1+*pointer(s(i))));
    return r;
}
/*---------------------------------------------------------------------------*/
func strtrtable(in, out, &tr)
/* DOCUMENT tr= strtrtable(in, out);
       -or- strtrtable, in, out, tr;
     Create or modify translation table TR so that characters that belongs to
     IN array will produce corresponding characters in OUT array.  IN and OUT
     must be conformable arrays of char's.

   SEE ALSO: strtranslate, strtolower, strtoupper.
 */
{
    if (is_void(tr))
	tr= char(indgen(0:255));
    tr(in+1)= char(out+1);
    return tr;
}
/*---------------------------------------------------------------------------*/
func strtrimleft(s)  { return strloop(s, _strtrimleft); }
func strtrimright(s) { return strloop(s, _strtrimright); }
func strtrimlr(s)      { return strloop(s, _strtrim); }
/* DOCUMENT sp= strtrimlr(s);
            sp= strtrimleft(s);
	    sp= strtrimright(s);
     Remove leading and or trailing spaces from a string or from
     an array of strings.

   SEE ALSO: strloop, strtok and strpart.
 */
/*---------------------------------------------------------------------------*/
func strloop(s, op)
/* DOCUMENT sp= strloop(s, op);
     Return the result of applying string operation OP to each strings of
     string array S.  OP is a function that accept and return a scalar
     string.  STRLOOP works around Yorick's distinction between scalars and
     arrays and failure to convert arrays of strings into arrays of chars
     (because strings may not have the same length).
   
   SEE ALSO: strtrimlr.
 */
{
    d= dimsof(s);
    if (d(1) == 0)
	return op(s);
    r= array(string, d);
    n= numberof(s);
    for (i=1; i<=n; i++)
	r(i)= op(s(i));
    return r;
}
/*---------------------------------------------------------------------------*/
local _cnotspace;
/* DOCUMENT _cnotspace
     Arrays to check whether chars are spaces or not.
 */
_cnotspace= array(1n, 256);
_cnotspace(1+[' ', '\t', '\n', '\r', '\v', '\f'])= 0;

func _strtrim(s)
/* DOCUMENT sp= _strtrim(s);
     Scalar version of STRTRIM.
 */
{
    c= *pointer(s);
    nsp= _cnotspace(1+c);
    i= is_array((i= where(nsp))) ? i(1) : 1;
    j= is_array((j= where(nsp*(c!='\0')))) ? j(0) : -1;
    return strpart(s, i:j);    
}

func _strtrimleft(s)
/* DOCUMENT sp= _strtrimleft(s);
     Scalar version of STRTRIMLEFT.
 */
{
    i= where(_cnotspace(1+*pointer(s)));
    return (is_array(i) ? strpart(s, i(1):) : s);   
}

func _strtrimright(s)
/* DOCUMENT sp= _strtrimright(s);
     Scalar version of STRTRIMRIGHT.
 */
{
    i= *pointer(s);
    i= where(_cnotspace(1+i)*(i!='\0'));
    return (is_array(i) ? strpart(s, :i(0)) : s);
}
%FILE% nextfakeswid.i
func nextfakeswid( a, n= )
/* DOCUMENT nextswid = nextfakeswid( n= )

   Returns the next 12 digit fake SWID string (or array with
   'n' elements) for ad hoc image identification

   2008-11-17/NJW
*/
{
   file = "/home/njw/yorick/latestfakeswid.txt";
   if( !file_test(file) ) error,"Basic /home/njw/yorick/latestfakeswid.txt is missing!";
   if( is_void(n) ) n = 1;
   lfswid = read_slist( file )(1);
   fswid = atof( lfswid );
   nfswid = [];
   for( i = 1; i <= n; i++ ) {
      fswid += 10.0;
      grow, nfswid, swrite(format="%12.0f", fswid );
   }
   write_slist, file, nfswid(0);
   if( n == 1 ) {
      return nfswid(1);
   } else return nfswid;
}
%FILE% norm_signif.i
/**************************************************
   Analyze a significance image
     - Renormalize around zero to RMS 1.0
     - return image cut for ds9 display

     2010-11-11/NJW
*****************************************************/

/* Function norm_signif */

func norm_signif( dol, locut, hicut, outfile= )
/* DOCUMENT cut_signif_ima = norm_signif( dol, locut, hicut, outfile= )

    Returns image renormalized to an RMS of 1.0

    When both 'locut' and 'hicut' (number of sigmas) are given
       then values below -locut will be reset to -lcut
       and values above hicut will be reset to hicut.
       In the case that no values are as low as -locut then
       the lower left pixel will get this value.
       In the case that no values are as high as hicut then
       the lower+1 left pixel will get this value.

    Keyword outfile will cause a (over-)writing of the renormalized and
    cut image to this file retaining the NAN pixels.

    Any subsequent writing without resetting (kwds_init) will copy the
    keywords from 'dol'.
*/
{
   local file, extno;
   get_exten_no, dol, file, extno;
   if( !file_test(file) ) {
      write,"NORM_SIGNIF: file not found";
      return [];
   }

   if( is_void(locut) ) hicut = [];
   if( is_void(hicut) ) locut = [];

   im = readfits(dol);
   imhdr = headfits(dol);
   fits_copy_keys,imhdr,tokwds=1;
   imout = im;
   wgood = wherenan( im, not=1 );

   immax = max(im(wgood));
   immin = min(im(wgood));
   if( immax == immin ) error,"NORM_SIGNIF: Single value image";

   //+ histos, im(wgood), h, x, binsize=(immax-immin)/200;
   histos, im(wgood), h, x, bmin=-2.0, bmax=4.0, binsize=0.03;
   plot,x,h,ps=10;
   esti = [max(h), sum(x*h)/sum(h), sqrt(sum(x^2*h)/sum(h))];
   local yfit;
   coefs = gaussfit( x, h, esti, yfit );
   oplot,x,yfit,color="red";
   xyouts,0.2,0.8,"Sigma = "+swrite(format="%.3f",coefs(3)),device=1;

   // produce renormalized image

   imout(wgood) = (im(wgood) - coefs(2))/coefs(3);

   // cut image is both locut and hicut are set:

   if( !is_void(locut) ) {
      w = where(imout(wgood) < -locut);
      if( numberof(w) ) {
         imout(wgood(w)) = -locut;
      } else {
         imout(1,1) = -locut;
      }
      w = where(imout(wgood) > hicut);
      if( numberof(w) ) {
         imout(wgood(w)) = hicut;
      } else {
         imout(1,2) = hicut;
      }
   }

   if( typeof(outfile) == "string" ) writefits,outfile,imout,clobber=1;

   return imout;
}
%FILE% organize.i
extern organizedoc;
/* DOCUMENT organize

   Functions:
    arrange_words_in_columns
    dirsync
    extra_files
    find_all_files
    get_identical_files
    list_file_attributes
    lsdirpath
    mv2special
    mvall2special
    nice_externs
    syco (commands for 'dirsync')
    ynclude

    You may keep in mind that checksum_string = md5sum( file, hex=1)
                           or checksum_array  = md5sum( file )
    (found in ../yorick-v_v/i/md5.i)
    could help to verify file identities. (note added 2008-08-29/NJW)

    2008-08-14/NJW

    Wanted functionality is synchronization between two directories that
    eventually should contain identical files for backup purposes.
    *** the above has been achieved with dirsync + syco ***

*/

/* Function extra_files */

func extra_files( dir1, dir2 )
/* DOCUMENT list = extra_files( dir1, dir2 )

   Return list of files in dir2 that do not exist in dir1
   2007-09-22/NJW
*/
{

   list1 = find_all_files( dir1 );

   list2 = find_all_files( dir2 );

   // Files to copy from dir2 to dir1
   list = filter_done( list1, list2 );
}

/* Function find_all_files */

func find_all_files ( dir, chat= )
/* DOCUMENT list = find_all_files( dir, chat= )

   Return a list with all files (not directories) in or
   below directory 'dir'.

   2007-09-23/NJW
*/
{
   //+ require, "c:/yo/filter_done.i";
   local nsubs, list_all, sublist, list_subdirs;

   if( is_void(chat) ) chat = 0;

   if(chat>0) write,format="FAF starting on directory %s ...\n", dir;
   list_all = lsdirpath( dir, list_subdirs );
   // If 'dir' exists then list_all is either a string array or nil
   // Else list_all == 0 (long)
   if( typeof(list_all) == "long" ) return list_all;
   nsubs = numberof( list_subdirs );
   if(chat>0) write,format="FAF: Found %i subdirectories\n", nsubs;
   if( nsubs > 0 ) {
      for( i = 1; i <= nsubs; i++ ) {
         sublist = find_all_files( list_subdirs(i) );
         grow, list_all, sublist;
      }
   }
   return list_all;
}

/* Function lsdirpath */

func lsdirpath( dir, &subs )
/* DOCUMENT files = lsdirpath( dir, >subs )

   same functionality as 'lsdir' with two arguments, except that
   full paths beginning from 'dir' are returned.

   2007-09-23/NJW
*/
{

   list = lsdir( dir, subs );
   // If the directory 'dir' does not exist, lsdir returns '0'
   // lsdirpath must inherit the same behaviour
   if( typeof(list) == "long" ) {
      if( list != 0 ) error,"LSDIRPATH should not happen, list is long and != 0";
      write,format="No such directory: %s\n", dir;
      return list;
   }
   if( !is_void(subs) ) subs = dir+"/"+subs;
   if( !is_void(list) ) list = dir+"/"+list;
   return list;
}

/* Function arrange_words_in_columns */

func arrange_words_in_columns( filename, ncols, colwidth, outfile=, embed=, margin= )
/* DOCUMENT arrange_words_in_columns, infilename, ncols, \
                 colwidth, outfile=, embed=, margin=

   The first argument must be a text file (scalar string) or an array of
   strings (may contain just one element).
   The words are separated out by
   space(s), sorted, and output column by column.

   Keyword 'outfile' can be set as 1 in which case 'filename' is overwritten
           if it is indeed a filename
           or a string that becomes the name of the output file.
           If zero or not given no writing will be done.

   Keyword 'embed' (a two element integer array) implies that the words are given
   between the two line numbers given incl.

   If 'ncols' or 'colwidth' is given as [] (void) then the values are reproduced
   from the input table.

   Keyword margin : Width of left margin

   2008-08-01/NJW
   2009-04-24/NJW updated with 'embed' keyword and functionality
   2010-02-24/NJW updated to accept a string array as well
*/
{

   if( typeof(filename) != "string" ) error,"AWIC called with illegal first argument";

   is_file = is_scalar(filename);
   part1 = part2 = [];

   if( is_file ) { // A text file is expected

      // get the table of words and isolate the table if
      // embedded in a text file

      if( !file_test(filename) ) {
         write,"AWIC Warning: file not found";
         return;
      }
      table = read_slist(filename);
      nt = numberof(table);
      write,format="%i lines in %s\n", nt, filename;

      if( !is_void(embed) ) {
         if( embed(2) > nt ) error,"AWIC error, keyword 'embed'";
         part1 = embed(1) == 1 ? [] : table(1:embed(1)-1);
         part2 = embed(2) == nt ? [] : table(embed(2)+1:0);
         table = table(embed(1):embed(2));
      }

   } else {         // assume that input is the string array

      table = filename;
      if( !is_void(outfile) ) { // must be a genuine filename
         if( typeof(outfile) != "string" ) error,"AWIC, outfile must be a string (filename)";
      }
   }

   lun = [];
   if( typeof(outfile) == "string" ) {
      lun = open(outfile,"w");
   } else if( !is_void(outfile) ) {
      if( outfile ) {
         lun = open(filename,"w");
      }
   }

   nt = numberof(table);
   // avoid empty lines
   ctable = [];
   xtable = [];
   for( i = 1; i <= nt; i++ ) {
      s = strtrim(strcompress(table(i)));
      if( strlen(s) > 0 ) {
         grow, xtable, table(i);
         grow, ctable, s;
      }
   }
   table = xtable; // now without empty lines else unchanged
   nt = numberof(table);

   // determine number of columns if ncols == []
   // as the maximum encountered in (c)table

   if( is_void(ncols) ) {
      ncols = 1;
      for( i = 1; i <= nt; i++ ) {
         n = pos = 0;
         // count number of spaces
         while((pos=strpos(ctable(i)," ",pos+1))) n++;
         if( n >= ncols ) ncols = n+1;
      }
   }

   // determine column width if colwidth == []

   if( is_void(colwidth) ) {
      if( ncols == 1 ) {
         colwidth = 1; // not applicable
      } else {
         // find first line with more that one word
         for( i = 1; i <= nt; i++ ) {
            n = pos = 0;
            // count number of spaces
            while((pos=strpos(ctable(i)," ",pos+1))) n++;
            if( n >= 1 ) break;
         }
         wds = strsplit(ctable(i)," ");
         pos1 = strpos(table(i),wds(1),1);
         pos2 = strpos(table(i),wds(2),strlen(wds(1))+1);
         colwidth = pos2 - pos1;
         if( is_void(margin) ) margin = pos1 - 1;
      }
   }

   // form the list of words in 'list'

   list = [];
   for(i=1;i<=nt;i++) grow,list,strsplit(ctable(i)," ");
   list = list(sort(list));
   nlist = numberof(list); // number of words
   nrows = nlist/ncols;    // number of lines with 'ncols' words
   rem = nlist - nrows*ncols; // number of remaining words

   // 's_ind' is the start index at the top of each column
   s_ind = array(long, ncols);
   s_ind(1) = 1;

   // get next start index as adding number of rows plus the
   // partially fillled extra row at bottom
   for( j = 1; j <= ncols; j++ ) {
      nr = nrows + (j <= rem);
      if( j < ncols ) {
         s_ind(j+1) = nr + s_ind(j);
      }
   }

   // outputting the reformatted table
   // start with part1 if defined

   if( !is_void(part1) && typeof(lun) == "text_stream" ) {
      for(k=1;k<=numberof(part1);k++) write,lun,format="%s\n",part1(k);
   }

   for( i = 1; i <= nrows + (rem > 0); i++ ) {
      line = "";
      if(!is_void(margin)) line = strpadd(line,margin," ");
      for( j = 1; j <= ncols; j++ ) {
         index = s_ind(j) + i-1;
         if( i > nrows && j > rem ) break;
         line += strpadd(list(index),colwidth," ");
      }
      write,format="%s\n",line;
      if( typeof(lun) == "text_stream" ) write,lun,format="%s\n",line;
   }

   // end with part2 if defined

   if( !is_void(part2) && typeof(lun) == "text_stream" ) {
      for(k=1;k<=numberof(part2);k++) write,lun,format="%s\n",part2(k);
   }

   if( typeof(lun) == "text_stream" ) close, lun;

}

/* Function dirsync */

func dirsync ( dir1, dir2, rec=, syco= )
/* DOCUMENT dirsync, dir1, dir2, rec=, syco=

   Make arrays with
      a) files in dir1 that are absent in dir2 : Files_dir1_alone
      b) files in dir2 that are absent in dir1 : Files_dir2_alone
      c) files common for the two directories  : Files_common

   Keyword rec (recursive) descend into subdirectories default=0
   Keyword syco is only used when called from function 'syco'

   SEE ALSO: syco

   2008-11-29/NJW
*/
{
  /*
   *  Assume that identical file names represent identical files
   *
   */

   extern Rec, Dir1, Dir2, Files_dir1_alone, \
          Files_dir2_alone, Files_common, \
          List_dir1, List_dir2;

   local pathname, basename;

   Dir1 = dir1;
   Dir2 = dir2;

   len1 = strlen(dir1);
   len2 = strlen(dir2);

   if( is_void(rec) ) rec = 0;
   Rec = rec;

   if( rec ) {
      List_dir1 = find_all_files( dir1 );
      List_dir2 = find_all_files( dir2 );
   } else {
      List_dir1 = lsdirpath( dir1 );
      List_dir2 = lsdirpath( dir2 );
   }
   d = 1;
   if( typeof(List_dir1) == "long" ) {
      write,format="Dir1 (%s) does not exist\n", dir1;
      write,format="    You may want to use: > mkdirp, \"%s\"\n", dir1;
      d = 0;
   }
   if( typeof(List_dir2) == "long" ) {
      write,format="Dir2 (%s) does not exist\n", dir2;
      write,format="    You may want to use: > mkdirp, \"%s\"\n", dir2;
      d = 0;
   }
   if( !d ) return;

   n1 = numberof(List_dir1);
   if( n1 ) {
      restnames1 = array(string, n1);
      for( i = 1; i <= n1; i++ ) {
         pos = strpos(List_dir1(1),dir1,1);
         if( pos != 1 ) error,"##45##";
         restnames1(i) = strpart( List_dir1(i), len1+2:0);
      }
   }
   n2 = numberof(List_dir2);
   if( n2 ) {
      restnames2 = array(string, n2);
      for( i = 1; i <= n2; i++ ) {
         pos = strpos(List_dir2(1),dir2,1);
         if( pos != 1 ) error,"##45##";
         restnames2(i) = strpart( List_dir2(i), len2+2:0);
      }
   }
   if( n1 ) {
      if( n2 ) {
         // There are files in both directories
         Files_dir1_alone = filter_done( restnames2, restnames1 );
         Files_dir2_alone = filter_done( restnames1, restnames2 );
         n1_alone = numberof( Files_dir1_alone );
         n2_alone = numberof( Files_dir2_alone );
         Files_common = filter_common( restnames1, restnames2 );
         n_common = numberof( Files_common );
         write,format="%6i files in total in Dir1: %s\n", n1, dir1;
         write,format="%6i files in total in Dir2: %s\n", n2, dir2;
         write,format="%6i files in Dir1 and not in Dir2\n", n1_alone;
         write,format="%6i files in Dir2 and not in Dir1\n", n2_alone;
         write,format="%6i files are common\n", n_common;
      } else {
         // There are only files in dir1
         Files_dir1_alone = restnames1;
         write,format="%6i files in total in Dir1: %s\n", n1, dir1;
         write,format="and no files in Dir2: %s\n", dir2;
      }
   } else {
      if( n2 ) {
         Files_dir2_alone = restnames2;
         write,format="%6i files in total in Dir2: %s\n", n2, dir2;
         write,format="and no files in Dir1: %s\n", dir1;
      } else {
         write,"No files at all";
      }
   }
   if( !syco ) {
      write,"External variables defined:";
      write,"      Dir1 and Dir2 - directory names";
      write,"      Files_dir1_alone - list of files";
      write,"      Files_dir2_alone - list of files";
      write,"      Files_common - files common to both directories";
      write,"";
      write," Call 'syco' to make an action";
      write,"";
   }
}

/* Function syco */

func syco( a )
/* DOCUMENT syco
    Sync Command - must be preceded by a call of dirsync that sets a number
    of external variables

    SEE ALSO: dirsync, setup_dir
*/
{

   extern Rec, Dir1, Dir2, Files_dir1_alone, \
          Files_dir2_alone, Files_common, \
          List_dir1, List_dir2;

   cmds = ["full","cp2dir1","cp2dir2","cmpr","cmpu1", \
           "cmpu2","disy","sz1","sz2","x","?"];

   command = "";

   while( command != "x" ) {
      read,prompt="Enter command ('?' for help) : ... ", command;
      if( !numberof(where(command == cmds))) {
         write,format="Illegal command : %s\n", command;
         continue;
      }

      if( command == "?" ) {
         write,"full    - full synchronization";
         write,"cp2dir1 - copy missing files to dir1";
         write,"cp2dir2 - copy missing files to dir2";
         write,"cmpr    - compare common files, just report";
         write,"cmpu1   - compare common files, update in dir1";
         write,"cmpu2   - compare common files, update in dir2";
         write,"disy    - run 'dirsync' to update file lists";
         write,"sz1     - report total size for dir1 + 10 biggest files";
         write,"sz2     - report total size for dir2 + 10 biggest files";
         write,"x       - exit";
      }
      if( command == "full" ) {
         n = numberof(Files_dir2_alone);
         for( i = 1; i <= n; i++ ) {
            write,format="Going to copy: %s\n", Dir2+"/"+Files_dir2_alone(i);
            setup_dir, Dir1+"/"+Files_dir2_alone(i);
            cp,Dir2+"/"+Files_dir2_alone(i),Dir1+"/"+Files_dir2_alone(i);
         }
         n = numberof(Files_dir1_alone);
         for( i = 1; i <= n; i++ ) {
            write,format="Going to copy: %s\n", Dir1+"/"+Files_dir1_alone(i);
            setup_dir, Dir2+"/"+Files_dir1_alone(i);
            cp,Dir1+"/"+Files_dir1_alone(i),Dir2+"/"+Files_dir1_alone(i);
         }
      }
      if( command == "cp2dir1" ) {
         n = numberof(Files_dir2_alone);
         for( i = 1; i <= n; i++ ) {
            write,format="Going to copy: %s\n", Dir2+"/"+Files_dir2_alone(i);
            setup_dir, Dir1+"/"+Files_dir2_alone(i);
            cp,Dir2+"/"+Files_dir2_alone(i),Dir1+"/"+Files_dir2_alone(i);
         }
      }
      if( command == "cp2dir2" ) {
         n = numberof(Files_dir1_alone);
         for( i = 1; i <= n; i++ ) {
            write,format="Going to copy: %s\n", Dir1+"/"+Files_dir1_alone(i);
            setup_dir, Dir2+"/"+Files_dir1_alone(i);
            cp,Dir1+"/"+Files_dir1_alone(i),Dir2+"/"+Files_dir1_alone(i);
         }
      }
      if( strpart(command,1:3) == "cmp" ) {
         n_diff = 0;
         n = numberof(Files_common);
         for( i = 1; i <= n; i++ ) {
            if( i%10 == 0 ) write,format="%s",".";
            chsum1 = md5sum( Dir1+"/"+Files_common(i), hex=1 );
            chsum2 = md5sum( Dir2+"/"+Files_common(i), hex=1 );
            if( chsum1 != chsum2 ) {
               write,format="\nDifference %s\n", Dir1+"/"+Files_common(i);
               write,format="       and %s\n", Dir2+"/"+Files_common(i);
               n_diff++;
               if( command == "cmpu1" ) {
                  write,format="\nUpdating %s\n", Dir1+"/"+Files_common(i);
                  cp,Dir2+"/"+Files_common(i), Dir1+"/"+Files_common(i);
               }
               if( command == "cmpu2" ) {
                  write,format="\nUpdating %s\n", Dir2+"/"+Files_common(i);
                  cp,Dir1+"/"+Files_common(i), Dir2+"/"+Files_common(i);
               }
            }
         }
         plural = n_diff == 1 ? "" : "s";
         write,format="\n%i files compared, %i differing file%s\n", \
                        n, n_diff, plural;
      }
      if( command == "disy" ) {
         dirsync, Dir1, Dir2, rec=Rec, syco=1;
      }
      if( command == "sz1" ) {
         n = numberof(List_dir1);
         top10 = 0;
         top10name = "";
         totsz = 0.0;
         for( i = 1; i <= n; i++ ) {
            ff = open(List_dir1(i),"rb");
            sz = sizeof(ff);
            close,ff;
            totsz += sz;
            if( sz > min(top10) ) {
               grow, top10, sz;
               grow, top10name, List_dir1(i);
               if( numberof(top10) > 10 ) {
                  is = sort(top10);
                  top10 = top10(is)(2:0);
                  top10name = top10name(is)(2:0);
               }
            }
         }
         local unit;
         _bytes, totsz, unit;
         write,format="Total size of %s: %.3f %s\n", Dir1, totsz, unit;
         for( i = numberof(top10); i >= 1; i-- ) {
            dsz = double(top10(i));
            _bytes, dsz, unit;
            write,format="%7.3f %s %s\n", dsz, unit, top10name(i);
         }
      }
      if( command == "sz2" ) {
         n = numberof(List_dir2);
         top10 = 0;
         top10name = "";
         totsz = 0.0;
         for( i = 1; i <= n; i++ ) {
            ff = open(List_dir2(i),"rb");
            sz = sizeof(ff);
            close,ff;
            totsz += sz;
            if( sz > min(top10) ) {
               grow, top10, sz;
               grow, top10name, List_dir2(i);
               if( numberof(top10) > 10 ) {
                  is = sort(top10);
                  top10 = top10(is)(2:0);
                  top10name = top10name(is)(2:0);
               }
            }
         }
         local unit;
         _bytes, totsz, unit;
         write,format="Total size of %s: %.3f %s\n", Dir2, totsz, unit;
         for( i = numberof(top10); i >= 1; i-- ) {
            dsz = double(top10(i));
            _bytes, dsz, unit;
            write,format="%7.3f %s %s\n", dsz, unit, top10name(i);
         }
      }
   }
}

func _bytes( &sz, &unit )
{
   unit = "bytes";
   if( sz > 1024. ) { unit = "kB"; sz /= 1024.; }
   if( sz > 1024. ) { unit = "MB"; sz /= 1024.; }
   if( sz > 1024. ) { unit = "GB"; sz /= 1024.; }
}

/* Function list_file_attributes */

func list_file_attributes( dir, outfile, rec=, app= )
/* DOCUMENT list_file_attributes, dir, outfile, rec=

    Keywords:  rec  :   set for recursive search
               app  :   append to existing 'outfile'

   2008-12-15/NJW
*/
{
   errmode = 1;
   mode = app ? "a" : "w";

   if( rec ) {
      list = find_all_files( dir );
   } else {
      list = lsdirpath( dir, subdirs );
   }
   nlist = numberof(list);
   szarr = [];
   chsumarr = [];
   listarr = [];

   for( i = 1; i <= nlist; i++ ) {
      f = open( list(i),"rb", errmode );
      if( f ) {
         sz = sizeof(f);
         close,f;
         chsum = md5sum( list(i), hex=1 );
         grow, szarr, sz;
         grow, chsumarr, chsum;
         grow, listarr, list(i);
      } else {
         write,format="%s is probably a link\n", list(i);
      }
   }
   nlist = numberof(listarr);

   is = sort(szarr);
   szarr = szarr(is);
   chsumarr = chsumarr(is);
   list = list(is);

   f = open( outfile, mode );
   for( i = 1; i <= nlist; i++ ) {
      write,f,format="%12i %36s %s\n", szarr(i), chsumarr(i), list(i);
   }
   close,f;

   write,"Done! Result in "+outfile;

}

/* Function get_identical_files */

func get_identical_files( filename, outfile= )
/* DOCUMENT get_identical_files, filename, outfile=

   'filename' is supposed to te an output file from 'list_file_attributes'
   or in the same format.

*/
{

   if( !file_test(filename) ) {
      write,format="File not found: %s\n", filename;
      return;
   }
   if( !is_void(outfile) ) {
      fout = open( outfile, "w" );
   } else fout = [];

   lines = rdfile( filename );
   nlines = numberof(lines);
   sz = 0;
   chsum = "";
   nam = "";
   szarr = array(long,nlines);
   chsumarr = array(string,nlines);
   namarr = array(string,nlines);
   for( i = 1; i <= nlines; i++ ) {
      sread,lines(i),sz,chsum,nam;
      szarr(i) = sz;
      chsumarr(i) = chsum;
      namarr(i) = nam;
   }

   // sort according to file size

   is = sort(szarr);
   szarr = szarr(is);
   chsumarr = chsumarr(is);
   namarr = namarr(is);

   u = uniq(szarr);
   grow,u,numberof(szarr)+1;
   grps = shift(u,1) - u;
   grps = grps(1:-1);
   g = where(grps > 1);
   ngrps = numberof(g);
   for( i = 1; i <= ngrps; i++ ) {
      nmem = grps(g(i));
      idx = u(g(i));
      chs = chsumarr(idx:idx+nmem-1);
      nms = namarr(idx:idx+nmem-1);
      iss = sort(chs);
      chs = chs(iss);
      nms = nms(iss);
      us = uniq(chs); // Index of start in chs and nms
      grow,us,numberof(chs)+1;
      grpss = shift(us,1) - us;
      grpss = grpss(1:-1);
      gs = where(grpss > 1); // Index of groups in 'us'
      ngrpss = numberof(gs);
      for( j = 1; j <= ngrpss; j++ ) {
         nmems = grpss(gs(j));
         write,format="\n%s\n", nms(us(gs(j)));
         if(fout)write,fout,format="\n%s\n", nms(us(gs(j)));
         for( k = 1; k < nmems; k++ ) {
            write,format="%s\n", nms(us(gs(j))+k);
            if(fout)write,fout,format="%s\n", nms(us(gs(j))+k);
         }
      }
   }
   if( fout ) {
      close, fout;
      write,"\nOutput in "+outfile;
   }
}

/* Function ynclude */

/**************************************************************
 *
 *   A primitive way to include a fixed set of lines
 *   in a Yorick code
 *
 * The line in a text file:
 *
 * // ynclude = include_file.ixc
 *
 * where the "// ynclude =" must be reproduced in an exact way
 * will, with the call of ynclude,"your_text_file.txt"
 * be followed by the contents of "include_file.ixc" and
 * immediately by the line
 *
 * // yxclude =
 *
 * to signal 'end-of-include-file'
 *
 * If the text file contains "// ynclude =" as well as "// yxclude ="
 * then the action will be like this:
 * The lines between the two lines will be written to the file
 * pointed to by "// ynclude = filename", they will be removed from
 * the present file as well as the "// yxclude =" line.
 *
 * 2010-02-09/NJW
 *
 *******************************************************/

func ynclude( filename, silent=, clean= )
/* DOCUMENT ynclude, filename, silent=, clean=

    Lines between '// ynclude = incl_filename'
              and '// yxclude ='
    will be written to 'incl_filename' and removed from original file

    If no '// yxclude =' is found then the contents of 'incl_filename'
    is inserted after '// ynclude = incl_filename' and supplemented
    with the line '// yxclude ='

    It toggles between two states of the file with respect to inclusion.

    Keywords
       silent     suppresses output
       clean      removes include files following inclusion

    2010-02-09/NJW
*/
{
   vb = is_void(silent);

   lines = rdfile(filename);

   // check for applicability ie. presence of "// ynclude ="

   wn = where(strpart(lines,1:12) == "// ynclude =");
   if( (nwn = numberof(wn)) == 0 ) {
      write,"No 'ynclude' found - skip any action";
      return;
   }

   // check for status ie. presence of "// yxclude"

   wx = where(strpart(lines,1:12) == "// yxclude =");
   if( (nwx = numberof(wx)) == 0 ) {

      if(vb) write,"No 'yxclude' found - in inclusion mode";

      lines_out = [];
      in_names = [];
      for( i = 1; i <= nwn; i++ ) {
         if( i == 1 ) {
            grow, lines_out, lines(1:wn(i));
         } else {
            grow, lines_out, lines(wn(i-1)+1:wn(i));
         }
         in_name = strtrim(strpart(lines(wn(i)),13:0));
         if(vb) write,format=" Including file: %s\n", in_name;
         if( file_test(in_name) ) {
            grow, lines_out, rdfile(in_name);
            grow, in_names, in_name;
         } else write,"Warning: Include file '"+in_name+"' is missing!";
         grow, lines_out, "// yxclude =";
      }
      // get the remainder - if any
      if( wn(i-1)+1 <= numberof(lines) ) grow, lines_out, lines(wn(i-1)+1:0);
      write_slist, filename, lines_out;

      if( clean ) {
         for( i = 1; i <= numberof(in_names); i++ ) {
            remove, in_names(i);
         }
      }

   } else {

      if(vb) write,"'yxclude' was found - in reduction mode";

      // check for pairing up

      if( nwn != nwx ) {
         write,format="%i ynclude and %i yxclude were found - skip action\n",\
                  nwn, nwx;
         return;
      }

      if( anyof( wx < wn ) ) {
         write,"ynclude and yxclude appear in wrong order - skip action";
         return;
      }
      if( nwn > 1 ) {
         if( anyof( wx(1:-1) > wn(2:0) ) ) {
            write,"ynclude and yxclude appear in wrong order - skip action";
            return;
         }
      }

      lines_out = [];
      for( i = 1; i <= nwn; i++ ) {
         if( i == 1 ) {
            grow, lines_out, lines(1:wn(i));
         } else {
            grow, lines_out, lines(wx(i-1)+1:wn(i));
         }
         out_name = strtrim(strpart(lines(wn(i)),13:0));
         save_lines = lines(wn(i)+1:wx(i)-1);
         if(vb) write,format=" Saving %i lines to file: %s\n", \
                  numberof(save_lines), out_name;
         write_slist,out_name,save_lines;
      }
      // get the remainder - if any
      if( wx(i-1)+1 <= numberof(lines) ) grow, lines_out, lines(wx(i-1)+1:0);
      write_slist,filename, lines_out;

   }
}

/* Function nice_externs */

func nice_externs( filename, ned= )
/* DOCUMENT nice_externs, filename, ned=

    An auxiliary function to 'ynclude' to edit and make a
    nice appearance of extern variables.

   SEE ALSO: ynclude
*/
{
   if( !ned )vi, filename;
   text = rdfile( filename );
   words = str_get_words( text );
   w = where( words != "extern" );
   words = words(w)+",";
   len = max(strlen(words))+2;
   arrange_words_in_columns, words, 80/len, len, outfile=filename, margin=10;
   text = strtrim(rdfile( filename ), 2);
   text(1) = strput( text(1), "extern", 3 );
   nlines = numberof(text);
   if( nlines > 1 ) text(1:-1) += " \\";
   pos = strpos( text(0), ",",rev=1);
   text(0) = strput( text(0), ";", pos );
   write_slist,filename,text;
   //+write,"  ----   Result in "+filename+"  ----";
   //+prstrarr, text;
   //+write,"  ----        -----          ----";
}

/* Function mvall2special */

func mvall2special( chat= )
/* DOCUMENT mvall2special, chat=

   Invoke 'mv2special' for each *.i file present in the
   current directory.

   2013-02-27/NJW
*/
{
   // Never use this function in a */yorick or */yorick/special directory
   curdir = rem_slash(get_cwd());
   bcurdir = basename(curdir);
   if( bcurdir == "yorick" ) {
      write,"Not to be used in this directory: "+curdir;
      return;
   }
   if( bcurdir == "special" ) {
      if( strlen(curdir) > 14 ) {
         if( strpart(curdir,-13:0) == "yorick/special" ) {
            write,"Not to be used in this directory: "+curdir;
            return;
         }
      }
   }

   list = rdfile(popen("find . -maxdepth 1 -type f -name \\*.i",0));
   n = numberof(list);
   if( n ) {
      list = basename(list);
      for( i = 1; i <= n; i++ ) mv2special, list(i), chat=chat;
   } else {
      write,"No *.i type f files found";
   }
}

/* Function mv2special */

func mv2special( filename, chat= )
/* DOCUMENT mv2special, filename, chat=

    An auxiliary function to copy a yorick function file to
    /home/njw/yorick/special and create a link in the current
    directory.

    Example:    mv2special,"asdf.i"
       will move asdf.i to /home/njw/yorick/special/asdf_0001.i
       where 0001 is the next serial number for asdf_nnnn.i files.
       A symbolic link asdf.i -> /home/njw/yorick/special/asdf_0001.i
       is created. An entry is added to the file
       /home/njw/yorick/special/index.txt to tell where the file
       asdf_0001.i originated.

    'filename' must be a file where the name has the suffix .i

   2012-04-27/NJW
*/
{
   local fdir, fname;

   if( is_link(filename) ) {
      write,filename+" is already a symbolic link - return ...";
      return;
   }

   cwd = rem_slash(get_cwd()); // remember from where the function was called
   splitfname, filename, fdir, fname;
   if( fdir != "." ) cd, fdir;

   // Never use this function in a */yorick or */yorick/special directory
   curdir = rem_slash(get_cwd());
   bcurdir = basename(curdir);
   if( bcurdir == "yorick" ) {
      write,"Not to be used in this directory: "+curdir;
      return;
   }
   if( bcurdir == "special" ) {
      if( strlen(curdir) > 14 ) {
         if( strpart(curdir,-13:0) == "yorick/special" ) {
            write,"Not to be used in this directory: "+curdir;
            return;
         }
      }
   }

   // get name without .i suffix
   pos = strpos( fname, ".i", rev=1 );
   len = strlen(fname);
   if( pos+1 != len || len < 3 ) {
      write,"Not a *.i file - return";
      return;
   }

   //  --  get part of name without .i
   sname = strpart( fname, 1:pos-1 );

   //  --  see what the serial number in ~/yorick/special must be
   dir = "/home/njw/yorick/special";
   nname = get_next_filename( sname+"_????.i", dir=dir );

   //  --  move the file
   system,"mv "+fname+" "+nname;

   //  --  note where it came from in index file
   f = open("/home/njw/yorick/special/index.txt","a");
   write,f,format="%s %s\n", strpadd(basename(nname),50," "), get_cwd();
   close, f;
   //  -- create the link to maintain the filename
   system,"ln -s "+nname+" "+fname;

   if( chat ) {
      write,"Move: "+filename;
      write,"  to: "+nname+" ...";
   }

   if( fdir != "." ) cd, cwd;
}
%FILE% osaerr.i
func osaerr( jemxNum, proj_name )
/* DOCUMENT osaerr, jemxNum, proj_name

   A subroutine that will produce a new swid.list in subdirectory
   analysis7/proj_name   with the SWIDs that were left in the first
   round because running stopped prematurely.
   It is assumed that the shell script 'osaerr.cgs' has been run
   to begin with.

   2008-01-15/NJW
*/
{
  /*
   * Get information about SWIDs where the failure occurred
   */
   failure_file = proj_name+".failures";
   if( !file_test(failure_file) ) {
      write,format="%s does not exist", failure_file;
      return [];
   }
   lines = read_slist( failure_file );
   nlines = numberof(lines);
   if( nlines == 0 ) {
      write,"Nothing to do! ...";
      return [];
   }
   dir = "analysis7/"+proj_name;
   cwdir = get_cwd();
   cd,dir;
   back, "swid.list";
   remove,"swid.list";
  /*
   * Extract the block numbers as well as the SWIDs
   */
   for( i = 1; i <= nlines; i++ ) {
      parts = strsplit( lines(i), " " );
      block = strpart( parts(1), 6:7 );
      swid = parts(2);
      write,format="block %s, SWID: %s\n", block, swid;
     /*
      *  Find the SWIDs that should have been run
      */
      bb = read_slist( "block_"+block );
      sw = strpart(bb,1:12);
      nbb = numberof(bb);
      w = where( sw == swid );
      nw = numberof(w);
      if(nw!=1) error,"##3## swid finding error";
      if( w(1) == nbb ) {
         write,"Trouble SWID is the last one - do nothing ...";
      } else {
         write_slist,"swid.list",sw(w(1)+1:0),app=1;
         write,"swid.list has been updated";
      }
   }

   cd, cwdir;
}
%FILE% ovplot.i
/* Function ovplot */

func ovplot( x, y, virymax, ps=, color=, li=, thick= )
/* DOCUMENT ovplot, x, y, virymax, ps=, color=, li=, thick=

     overplot of (x,y) so that x becomes vertical and y
     extends to the right.

     Assume that x matches current ordinate scale.

    2011-03-23/NJW
*/
{
   local p, q, yan;
   // scale y values to range 0. - virymax
   linscale, min(y), max(y), 0., virymax, p, q;
   ya = y*p + q;

   // convert ya values to world coordinates along x axis

   mcoord_conv, ya, 0., yan, dum, from="vir", to="wor";
   if( is_void(ps) ) {
      oplot,yan,x,ps=ps,color=color,li=li,thick=thick;
   } else {
      if( ps == 100 ) {
         oplot,x, yan,ps=ps,color=color,li=li,thick=thick;
      } else oplot,yan,x,ps=ps,color=color,li=li,thick=thick;
   }
}
%FILE% pbez3.i
// Third order polynomium

#include "rootpoly.i"
#include "pbez_funcs.i"
#include "rotate.i"

func pbez3( xarr1, yarr1, xarr2, yarr2, nelem, eps, pl= )
/* DOCUMENT

    Connect last piece of arr1 with first piece of arr2

*/
{
   extern x2, x3, f2, f3, fp2, alpha, gamma, x0, a_factor;

   if( xarr1(-1) >= xarr1(0) ) error,"PBEZ3 (1)";
   if( xarr1(0) >= xarr2(1) ) error,"PBEZ3 (2)";
   if( xarr2(1) >= xarr2(2) ) error,"PBEZ3 (3)";

   y = x = array(double,4);
   x(1:2) = xarr1(-1:0);
   y(1:2) = yarr1(-1:0);
   x(3:4) = xarr2(1:2);
   y(3:4) = yarr2(1:2);

   if( pl ) {
      window,0;
      sx = 0.1*(x(0)-x(1));
      sy = 0.3*(max(y) - min(y));
      plot,x(1:2),y(1:2), xr=[min(x)-sx,max(x)+sx], yr=[min(y)-sy,max(y)+sy];
      oplot,x(3:4),y(3:4);
   }

   // rotate to more favorable position

   obj = array(s_Point,4);
   obj.x = x;
   obj.y = y;
   //+ scale = s_Point();
   //+ scale.x = 1./(max(x)-min(x));
   //+ scale.y = 1./(max(y)-min(y));
   scale = [];
   center = s_Point();
   center.x = 0.5*(x(2)+x(3));
   center.y = 0.5*(y(2)+y(3));
   angle = atan(y(2)-y(3),x(3)-x(2))*180/pi;
   rot_obj = scalrot( obj, center, scale, angle );

   x = rot_obj.x;
   y = rot_obj.y;
   if( pl ) {
      window,1;
      sx = 0.1*(max(x)-min(x));
      sy = 0.3*(max(y) - min(y));
      plot,x(1:2),y(1:2), xr=[min(x)-sx,max(x)+sx], yr=[min(y)-sy,max(y)+sy];
      oplot,x(3:4),y(3:4);
   }

   x2 = x(2);
   x3 = x(3);
   f2 = y(2);
   f3 = y(3);

   dy = y(dif);
   dx = x(dif);
   fp2 = dy(1)/dx(1);
   fp3 = dy(3)/dx(3);
   del = dx(2)/2;

   xi = span(x(2)+eps,x(3)-eps,nelem);


   //------ section for direct solution

   alpha = x2 + x3;
   gamma = x2*x3;

   K32 = K(x3) - K(x2);
   L32 = L(x3) - L(x2);
   P32 = Phat(x3) - Phat(x2) - (x3-x2)*K(x2);
   Q32 = Qhat(x3) - Qhat(x2) - (x3-x2)*L(x2);
   R32 = (x3-x2)*fp2;
   Delta = f3 - f2;
   Deltap = fp3 - fp2;
   x0 = (Deltap*Q32 - L32*(Delta-R32))/((Delta-R32)*K32 - Deltap*P32);
   a_factor = Deltap / (x0*K32 + L32);


   coefs = coef_rootpoly([x2,x0,x3]);

   //+ A = x0 + x2 + x3;
   //+ B = x2*x3 + x0*x2 + x0*x3;
   //+ C = x0*x2*x3;

   fpp = a_factor * polyn(xi, coefs);


   icoefs = icoef_polyn(coefs);
   D2 = polyn(x2,icoefs);
   icoefs(1) = -D2 + fp2/a_factor;
   fp = a_factor*polyn(xi,icoefs);


   iicoefs = icoef_polyn(icoefs);
   E2 = polyn(x2,iicoefs);
   iicoefs(1) = -E2 + f2/a_factor;
   f = a_factor*polyn(xi,iicoefs);

   if( pl ) {
      window,5;
      plot,xi,fpp,title="fpp";
      window,2;
      plot,xi,fp,title="fp";

      window,3;
      plot,xi,f,title="f";

      window,1;
      oplot,xi,f,color="green";
   }

   curv = array(s_Point, numberof(xi));
   curv.x = xi;
   curv.y = f;

   vruc = scalrot(curv,center,scale,angle,inv=1);

   if( pl ) {
      window,0;
      oplot,vruc.x,vruc.y,color="green";
   }

   return vruc;
}

func K( x )
{
   extern alpha, gamma;

   return -(x^3)/3 + alpha*x^2/2 - gamma*x;
}
func L( x )
{
   extern alpha, gamma;

   return x^4/4 - alpha*x^3/3 + gamma*x^2/2;
}

func P( x )
{
   extern x2, alpha, gamma;

   return -(x^4)/12 + alpha*x^3/6 - gamma*x^2/2 - K(x2)*x;
}
func Phat( x )
{
   extern x2, alpha, gamma;

   return -(x^4)/12 + alpha*x^3/6 - gamma*x^2/2;
}
func Q( x )
{
   extern x2, fp2, alpha, gamma;

   return x^5/20 - alpha*x^4/12 + gamma*x^3/6 + (fp2 - L(x2))*x;
}
func Qhat( x )
{
   extern x2, fp2, alpha, gamma;

   return x^5/20 - alpha*x^4/12 + gamma*x^3/6;
}

func fp_a( x )
{
   extern x0;

   return x0*K(x) + L(x);
}

func f_a( x )
{
   extern x0;

   return x0*P(x) + Q(x);
}
func f_b( x )
{
   extern a_factor, x0, x2, fp2;

   t1 = a_factor * x0 * (Phat(x)-Phat(x2));
   t2 = -(x-x2)*a_factor*x0*K(x2);
   t3 = a_factor*(Qhat(x)-Qhat(x2));
   t4 = -(x-x2)*a_factor*L(x2);
   t5 = fp2*(x-x2);

   return t1+t2+t3+t4+t5;
}
func fp_b( x )
{
   extern a_factor, x0, x2, fp2;

   return a_factor*(x0*(K(x)-K(x2))+L(x)-L(x2)) + fp2;
}
%FILE% pbez5.i
// Second derivative is a 5th order polynomium

/****    Note for later development  2009-07-30/NJW
 *
 *  In the present version the second derivative is set to zero
 *  at the connecting points (x2,f2) and (x3,f3). If more than a
 *  single curve element (i.e. more than 2 points) are given then
 *  it is possible to derive the second derivative as e.g.
 *   x = [xarr1(-2),xarr1(-1),xarr1(0),xarr2(1),xarr2(2),xarr2(3)]
 *   y = [yarr1(-2),yarr1(-1),yarr1(0),yarr2(1),yarr2(2),yarr2(3)]
 *   Fpp2 = (y(dif)(dif)/x(zcen)(dif))(1)
 *   Fpp3 = (y(dif)(dif)/x(zcen)(dif))(4)
 *      NB NB!!! in the rotated arrays!!
 *  and pass them on for the RHS of the matrix equation
 */

#include "pbez_matsol5.i"
#include "rotate.i"

func pbez5( xarr1, yarr1, xarr2, yarr2, nelem, eps, pl= )
/* DOCUMENT res = pbez5( xarr1, yarr1, xarr2, yarr2, nelem, eps, pl= )

    Connect last piece of arr1 with first piece of arr2
    Returns the missing curve by an array of 's_Point'
    x = res.x
    y = res.y

*/
{
   extern Xi, Farr, Nelem, Eps;

   if( is_void(eps) ) eps = 1.e-3;
   if( is_void(nelem) ) nelem = 100;
   Nelem = nelem;
   Eps = eps;

   if( xarr1(-1) >= xarr1(0) ) error,"PBEZ5 (1)";
   if( xarr1(0) >= xarr2(1) ) error,"PBEZ5 (2)";
   if( xarr2(1) >= xarr2(2) ) error,"PBEZ5 (3)";

   y = x = array(double,4);
   x(1:2) = xarr1(-1:0);
   y(1:2) = yarr1(-1:0);
   x(3:4) = xarr2(1:2);
   y(3:4) = yarr2(1:2);

   if( pl ) {
      window,0;
      sx = 0.1*(max(max(xarr1),max(xarr2))-min(min(xarr1),min(xarr2)));
      sy = 0.1*(max(max(yarr1),max(yarr2))-min(min(yarr1),min(yarr2)));
      plot,xarr1,yarr1, xr=[min(min(xarr1),min(xarr2))-sx,max(max(xarr1),max(xarr2))+sx], \
                        yr=[min(min(yarr1),min(yarr2))-sy,max(max(yarr1),max(yarr2))+sy];
      oplot,xarr2, yarr2;
   }

   // rotate to more favorable position

   obj = array(s_Point,4);
   obj.x = x;
   obj.y = y;
   //+ scale = s_Point();
   //+ scale.x = 1./(max(x)-min(x));
   //+ scale.y = 1./(max(y)-min(y));
   scale = [];
   center = s_Point();
   center.x = 0.5*(x(2)+x(3));
   center.y = 0.5*(y(2)+y(3));
   angle = atan(y(2)-y(3),x(3)-x(2))*180/pi;
   rot_obj = scalrot( obj, center, scale, angle );

   x = rot_obj.x;
   y = rot_obj.y;
   if( pl ) {
      window,1;
      sx = 0.1*(max(x)-min(x));
      sy = 0.3*(max(y) - min(y));
      plot,x(1:2),y(1:2), xr=[min(x)-sx,max(x)+sx], yr=[min(y)-sy,max(y)+sy];
      oplot,x(3:4),y(3:4);
   }

   x2 = x(2);
   x3 = x(3);
   f2 = y(2);
   f3 = y(3);

   dy = y(dif);
   dx = x(dif);
   fp2 = dy(1)/dx(1);
   fp3 = dy(3)/dx(3);

   pbez_matsolve, x2, x3, f2, f3, fp2, fp3;


   curv = array(s_Point, numberof(Xi));
   curv.x = Xi;
   curv.y = Farr;

   vruc = scalrot(curv,center,scale,angle,inv=1);

   if( pl ) {
      window,0;
      oplot,vruc.x,vruc.y,color="green";
   }

   return vruc;
}
%FILE% pbez_matsol5.i
func pbez_matsolve( x2, x3, f2, f3, fp2, fp3 )
{
   extern X2, X3, F2, F3, Fp2, Fp3, Xi, Farr;
   extern Nelem, Eps;

   X2 = x2; X3 = x3;
   F2 = f2; F3 = f3;
   Fp2 = fp2; Fp3 = fp3;

   p = array(double,3,2); // array for 'amoeba'
   p(1,) = 0.;
   p(2,) = 0. + [0.1,0.];
   p(3,) = 0. + [0.,0.01];
   parm = array(double,2);
   yinit = array(double,3);
   for(i=1;i<=3;i++) yinit(i) = pbez_matsol5(p(i,));

   p_res = amoeba( pbez_matsol5, p, yinit, 1.e-4, iter );

   write,"Fit result"
   write,format=" beta = %12.3e\n", p_res(1);
   write,format=" zeta = %12.3e\n", p_res(2);
   write,format=" by %i iterations\n", iter;

   // setting externals Xi and Farr:
   kmin = pbez_matsol5( p_res );
}

func pbez_matsol5( parm )
{

   extern X2,X3,F2,F3,Fp2,Fp3, Xi, Farr;
   extern Nelem, Eps;

   beta = parm(1);
   zeta = parm(2);

   x2 = X2; x3 = X3;
   f2 = F2; f3 = F3;
   fp2 = Fp2; fp3 = Fp3;

   x22=x2^2; x23=x22*x2; x24=x23*x2; x25=x24*x2; x26=x25*x2; x27=x26*x2;
   x32=x3^2; x33=x32*x3; x34=x33*x3; x35=x34*x3; x36=x35*x3; x37=x36*x3;

   rhs = [f2,f3,fp2,fp3,0.,0.];

   // free parameters 'beta' and 'zeta'

   Cmatx = array(double, 6,8);

   unit = array(1.,8);
   dunit = dcoef_polyn(unit);
   ddunit = dcoef_polyn(dunit);
   dddunit = dcoef_polyn(ddunit);
   grow, dunit, 0.; dunit = shift(dunit,-1);
   grow, ddunit, 0., 0.; ddunit = shift(ddunit,-2);
   xx2arr = [1.,x2,x22,x23,x24,x25,x26,x27];
   xx3arr = [1.,x3,x32,x33,x34,x35,x36,x37];
   Cmatx(1,) = xx2arr * unit;
   Cmatx(2,) = xx3arr * unit;
   Cmatx(3,) = shift(xx2arr,-1) * dunit;
   Cmatx(4,) = shift(xx3arr,-1) * dunit;
   Cmatx(5,) = shift(xx2arr,-2) * ddunit;
   Cmatx(6,) = shift(xx3arr,-2) * ddunit;

   rhsx = rhs - beta*Cmatx(,7) - zeta*Cmatx(,8);

   fcoefs = LUsolve( Cmatx(,1:6), rhsx );
   grow, fcoefs, beta, zeta;
   fpcoefs = dcoef_polyn(fcoefs);
   fppcoefs = dcoef_polyn(fpcoefs);
   //+ fpppcoefs = dcoef_polyn(fppcoefs);

   Xi = span(x2+Eps,x3-Eps,Nelem);
   Farr = g = polyn(Xi,fcoefs);
   gp = polyn(Xi,fpcoefs);
   gpp = polyn(Xi,fppcoefs);
   //+ gppp = polyn(Xi,fpppcoefs);

   k = gpp/(1+gp^2)^(1.5);
   //+ dkdx = ((1+gp^2)*gppp - 3*gp*gpp^2)/(1+gp^2)^(2.5);

   return max(abs(k));

}
%FILE% pde.i
// A collection of Yorick routines for integrating various PDEs.
// All programs use finite-difference techniques.
// Intended for in-class demonstrations, etc.
// Used for Math Physics II, Jan - Mar 2000.
// D. Holmgren,
// Dept. of Physics & Astronomy,
// Brandon University,
// Brandon, Manitoba, Canada
// R7A 6A9
// holmgren@brandonu.ca
// ----------------------------------------------------------------

// typical usage:
// window,0
// wave, 20, 500

require, "movie.i";
pldefault, marks=0;

// ----------------------------------------------------------------
// Finite difference solution for 4th order beam problem.
// This technique from Ames' book.
// This simulates a beam fixed at both ends:
//  u_tt + u_xxxx = 0
//  u(0) = 0 = u(1) and u_x(0) = 0 = u_x(1)
//  u_t = 0 at t = 0 and u(x,0) = sin(pi*x)-pi*x*(1-x)
// DH 13.2.00  Appears to work correctly.
func beam2(nx,nt)
{
// Keep time step much less than stability limit:
	dx = 1./nx;
	dt = 0.25*dx^2
	p = array(0.,nx);
        x = span(0.,1.,nx);
	q = p;
// Initial displacement, fixed at both ends:
	p = sin(pi*x) - pi*x*(1.-x);
	p1 = p;
	c = (dt/dx^2)^2;
// Enforce BCs; displacement and first derivatives at ends are zero.
        p(1:2)= p(-1:0)= 0.;
        limits, min(x), max(x), -1.1*max(abs(p)), 1.1*max(abs(p))
	movie, beam2_step, time_limit, min_interframe;
        beam2_step, nt;
}

func beam2_step(j)
{
  q(3:-2)= 2.*p(3:-2) - p1(3:-2) - c*p(dif)(dif)(dif)(dif);
  // Must keep present and past two time levels:
  p1 = p;
  p = q;

  plg, p, x;
  return (j < nt);
}

// ---------------------------------------------------------------
// Simple FD transmission line program.
// This program solves:
// u_tt - lambda^2 * u_xx + 2*c*u_t = 0
// with fixed ends, etc.
// DH 23.2.00
func tl(nx,nt)
{
 x = span(0.,1.,nx); dx = x(2)-x(1);
 dt = dx; c = 1.0; lambda = 1.;
 m = (dt/dx)^2; a = 1./(1.+dt*c);
 u = array(0.,dimsof(x)); v = u; w = u;
// f = (x-0.5)*exp(-100.*(x-0.5)^2);
 f = u; f(3:10)=1.;
 g = u;
 u = f;
 bc_left = 0.; bc_right = 0.;
  u(1)= bc_left;  u(0)= bc_right;
  limits, min(x), max(x), -1.5*max(abs(u)), 4.*max(abs(u))
 movie, tl_step, time_limit, min_interframe;
 tl_step, nt;
}

func tl_step(n)
{
  v(2:-1)= a*(2.*u(2:-1) - w(2:-1) + m*u(dif)(dif) +
              dt*c*w(2:-1));
  w= u;
  u= v;

  plg, u, x;
  return (n < nt);
}

// ----------------------------------------------------------------
// Simple FD transmission line program.
// This version solves:
// u_tt - lambda^2*u_xx + 2*c*u_t + u = 0
// with fixed ends, etc.
// Use large nx and nt to see TL effects.
// DH 23.2.00
func tl2(nx,nt)
{
 x = span(0.,1.,nx); dx = x(2)-x(1);
 dt = dx; c = 1.0; lambda = 1.;
 m = (dt/dx)^2; a = 1./(1.+dt*c);
 u = array(0.,dimsof(x)); v = u; w = u;
// f = (x-0.5)*exp(-100.*(x-0.5)^2);
 f = u; f(3:15)=1.;
 g = u;
 u = f;
 bc_left = 0.; bc_right = 0.;
  u(1)= bc_left;  u(0)= bc_right;
  limits, min(x), max(x), -3.*max(abs(u)), 7.*max(abs(u))
 movie, tl2_step, time_limit, min_interframe;
 tl2_step, nt;
}

func tl2_step(n)
{
  v(2:-1)= a*(2.*u(2:-1) - w(2:-1) + m*u(dif)(dif) +
              dt*c*w(2:-1) + dt^2*u(2:-1));
  w= u;
  u= v;

  plg, u, x;
  return (n < nt);
}

// ------------------------------------------------------------------
// Simple solution of a nonlinear conservation equation. DH 26.2.00
//  u_t + 3*u*u_x = 0
//  u(x,0) = 1 ( x < 0 )
//           1-x ( 0 < x < 1 )
//           0 ( x > 1)
// This uses a leapfrog method which I think is stable
// for (dt/dx)*3u < 1.
// Use traffic(100,175) to see a shock wave develop.
// Before running program, do:
// 1. window,0
// 2. limits,"e","e",0.,1.05
// This sets up Yorick for animation.
func traffic(nx,nt)
{
	x=span(-2.,2.,nx);
	dx = x(nx)-x(nx-1);
	dt = 0.05*dx;
	u=array(0.,nx);
	v = u;
	u = 1.-x;
	i1 = where(u<0);
	u(i1)=0.;
	i2 = where(u>1.);
	u(i2)=1.;
	w = u;
        v(1)=1.; v(nx)=0.;
        limits, min(x), max(x), -0.1*max(abs(u)), 5.*max(abs(u))
	movie, traffic_step, time_limit, min_interframe;
        traffic_step, nt;
}

func traffic_step(k)
{
  v(2:-1)= w(2:-1) - (dt/dx)*6.*u(2:-1)*u(dif)(zcen);
  w= u;
  u= v;

  plg, u, x;
  return (k < nt);
}

// ------------------------------------------------------------------
// Simple FD routine to solve the 1D wave equation
// u_tt = u_xx
// with reflecting BC's.
// DH 23.2.00
func wave(nx,nt)
{
// To get standing waves, try this domain:
//      x = span(0.,1.,nx);
// This larger domain is nice for watching propagation:
	x = span(-10.,10.,nx);
	dx = x(2)-x(1); dt = dx;
	m = (dt/dx)^2;
	u = array(0.,dimsof(x)); v = u; w = u;
// An initial Gaussian distribution:
        f = exp(-50.*x^2);
// This initial distribution is for standing waves:
//      f = sin(pi*x);
// Allow both position u and velocity w to be Gaussian:
	u = f; w = f;
// Enforce BCs:
	 v(1) = 0.; v(nx) = 0.;
        limits, min(x), max(x), -1.2*max(abs(u)), 1.2*max(abs(u))
         movie, wave_step, time_limit, min_interframe;
         wave_step, nt;
}

func wave_step(j)
{
  v(2:-1)= 2.*u(2:-1) - w(2:-1) + m*u(dif)(dif);
  w= u;
  u= v;

  plg, u, x;
  return (j < nt);
}

// ----------------------------------------------------------------
// Simple FD routine to solve the 3D wave equation
// u_tt = u_xx + u_yy + u_zz   (x,y,z) in R^3
// as an initial value problem.
// This appears to work correctly.
// DH 24.2.00
func wave3d(nx,nt)
{
	require,"plwf.i";
	orient3;
        limits;
// Define a cube:
	x = span(-10.,10.,nx);
	y = x; z = x;
	dx = x(2)-x(1); dt = dx; dy = dx; dz = dx;
	m = (dt/dx)^2;
	u = array(0., nx,nx,nx); v = u; w = u;
	u(nx/2,nx/2,nx/2) = 1.;
	movie, wave3d_step, time_limit, min_interframe;
        wave3d_step, nt;
}

func wave3d_step(n)
{
  uxx= u(dif,2:-1,2:-1)(dif,,);
  uyy= u(2:-1,dif,2:-1)(,dif,);
  uzz= u(2:-1,2:-1,dif)(,,dif);
  v(2:-1,2:-1,2:-1)= 2.*u(2:-1,2:-1,2:-1) - w(2:-1,2:-1,2:-1) +
    m*(uxx+uyy+uzz);
  w= u;
  u= v;

  plwf, u(,,nx/2);
  draw3;
  return (n < nt);
}

// ----------------------------------------------------------------
// Jacobi iteration for Laplace or Poisson equations.
// This problem is 11.16 from DuChateau & Zachmann:
// u_xx + u_yy = 0 , 0 <= x,y <= 1
// u(x,y) = exp(2*pi*x)*sin(2*pi*y) on bdy.
// DH 14.3.00
func sor(nx,ny,iter)
{
// Nonzero f gives the Poisson equation.
 u = array(0., nx,ny); f = u;
 dx = 1./nx; dy = 1./ny;
 x = span(0.,1.,nx); y = x;
 u(1,)=exp(2.*pi*x(1))*sin(2.*pi*y);
 u(nx,)=exp(2.*pi*x(nx))*sin(2.*pi*y);
 u(,1)=exp(2.*pi*x)*sin(2.*pi*y(1));
 u(,ny)=exp(2.*pi*x)*sin(2.*pi*y(ny));
 for( k = 1; k <= iter; ++k ){
  for( n = 2; n <= nx-1; ++n ){
   for( m = 2; m <= ny-1; ++m ){
    u(n,m)=(u(n,m-1)+u(n-1,m)+u(n,m+1)+u(n+1,m)-dx*dy*f(n,m))/4.;
   }
  }
 }
 palette,"heat.gp";
 pli,u,0.,0.,1.,1.;
}

// ----------------------------------------------------------------
// Jacobi iteration for Laplace or Poisson equations.
// This problem is 11.16 from DuChateau & Zachmann:
// u_xx + u_yy = f , 0 <= x,y <= 1
// u(x,y) = 0 on bdy.
// This version computed the Green's function.
// DH 16.3.00
func gsor(nx,ny,iter)
{
 require, "plwf.i";
 orient3;
// Nonzero f gives the Poisson equation.
 u = array(0., nx,ny); f = u;
 dx = 1./nx; dy = 1./ny;
 x = span(0.,1.,nx); y = x;
 f(nx/2,ny/2)=-1.;
 for( k = 1; k <= iter; ++k ){
  for( n = 2; n <= nx-1; ++n ){
   for( m = 2; m <= ny-1; ++m ){
    u(n,m)=(u(n,m-1)+u(n-1,m)+u(n,m+1)+u(n+1,m)-dx*dy*f(n,m))/4.;
   }
  }
 }
 plwf,u;
}

// ----------------------------------------------------------------
// Routine for solving biharmonic equation.  DH 20.3.00
// Appears to work correctly.
func bihar(nx,ny,iter)
{
 require, "plwf.i";
 orient3;
 u = array(0., nx,ny); f = u;
 dx = 1./nx; dy = 1./ny;
 x = span(0.,1.,nx); y = span(0.,1.,ny);
 u(nx/2,ny/2)=1.;
 for( k = 1; k <= iter; ++k ){
  for( i = 3; i <= nx-2; ++i ){
   for( j = 3; j <= ny-2; ++j ){
    u(i,j)=(8.*(u(i+1,j)+u(i-1,j)+u(i,j-1)+u(i,j+1))-2.*(u(i-1,j-1)+u(i+1,j+1)+u(i+1,j-1)+u(i-1,j+1))-u(i+2,j)-u(i-2,j)-u(i,j-2)-u(i,j+2)+dx^2*dy^2*f(i,j))/20.;
   }
  }
 }
 plwf,u;
}

// ----------------------------------------------------------------
// Jacobi iteration for Helmholtz equation.
// k = wavenumber of mode
// DH 21.3.00 - appears to work correctly.
func helmholtz(k,nx,ny,iter)
{
 require, "plwf.i";
 orient3;
 u = array(0., nx,ny);
 dx = 1./nx; dy = 1./ny;
 x = span(0.,1.,nx);
 y = span(0.,1.,ny);
 u(nx/2,) = sin(pi*y);
 for( i = 1; i <= iter; ++i ){
  for( n = 2; n <= nx-1; ++n ){
   for( m = 2; m <= ny-1; ++m ){
    u(n,m)=(u(n,m-1)+u(n-1,m)+u(n,m+1)+u(n+1,m)-dx*dy*k^2*u(n,m))/4.;
   }
  }
 }
 plwf,u;
}

// ----------------------------------------------------------------
// Simple FD routine to solve the 1D Klein-Gordon wave equation
// u_tt = c^2*u_xx - zeta*u
// with reflecting BC's.
// DH 6.4.00
func kg(nx,nt)
{
// To get standing waves, try this domain:
        x = span(0.,1.,nx);
// This larger domain is nice for watching propagation:
//      x = span(-10.,10.,nx);
	dx = x(2)-x(1); dt = dx;
	m = (dt/dx)^2;
	u = array(0.,dimsof(x)); v = u; w = u;
        c=0.25; zeta=0.1;
// An initial Gaussian distribution:
//      f = exp(-50.*x^2);
// This initial distribution is for standing waves:
        f = sin(pi*x);
// Allow both position u and velocity w to be Gaussian:
	u = f; w = f;
// Enforce BCs:
        v(1)= v(0)= 0.;
        limits, min(x), max(x), -1.2*max(abs(u)), 1.2*max(abs(u))
	movie, kg_step, time_limit, min_interframe;
        kg_step, nt;
}

func kg_step(j)
{
  v(2:-1)= 2.*u(2:-1)-w(2:-1) + m*c^2*u(dif)(dif) - zeta*u(2:-1)*dt^2;
  w= u;
  u= v;

  plg, u, x;
  return (j < nt);
}
%FILE% peakfit1.i
/*
 *  Struct used by peakfit1 to apply the Levenberg-Marquardt
 *  method for minimization in Yorick file: lmfit.i
 *
 */
struct pdat { double x; double y; }

/*
 *  Expect 9 elements of 'a'
 */

func ftepf1(x, a)
/* DOCUMENT y = ftepf1(x,a)

    where 'x' is an array of struct 'pdat' and 'a' is a 9 element
    vector. Auxiliary function for peakfit1
    Describes a main peak standing in a depression valley on a
    background that is a plane.

    2007-02-07/NJW
*/
{
   term1 =  a(1)*exp(-0.5*((x.x-a(2))^2+(x.y-a(3))^2)/a(4)^2);
   term2 =  a(5)*exp(-0.5*((x.x-a(2))^2+(x.y-a(3))^2)/a(6)^2);
   term3 =  a(7) + a(8)*x.x + a(9)*x.y;

   return term1 - term2 + term3;
}


func peakfit1( im, xpos, ypos, radius, &rim, freeze= )
/* DOCUMENT coefs = peakfit1( im, xpos, ypos, radius, >rim, freeze= )

  'radius' is the radius of the peak fitting area (in pixels).

  Returns array with:

     1: norm of main peak c1*exp(-0.5*((x-c2)^2+(y-c3)^2)/c4^2)
     2: x position of peak
     3: y position of peak
     4: sigma of main peak
     5: norm of depression valley, usually a fraction of c1
     6: sigma of depression valley, usually larger than c4
     7: constant background level
     8: slope af background in x direction
     9: slope af background in y direction
    10: Number of counts in main peak (c1*c4^2*2*pi)

  The argument 'rim' is returned as the image with the peak replaced by
  the resulting fit function.

  Keyword 'freeze' is an a double array with
     [index1, fixed value1, index2, fixed value2, ... ]

   Uses: ftepf1, lmfit;

   2007-02-07/NJW
*/
{
   //+ require, "lmfit.i";

   if( is_void(freeze) ) {
      fit=[];
      n = 0;
   } else {
      n = numberof(freeze);
      index = int(freeze(1:n:2));
      fvals = freeze(2:n:2);
      // make sure that the 'fit' contains the indices of not frozen parm's
      fit = [];
      for(i=1;i<=9;i++) {
         z = where(i==index);
         if(!numberof(z)) grow,fit,i;
      }
   }
   dms = dimsof(im);

   d = distances( dms(2), dms(3), xpos, ypos );
   w = where( d < radius );
   ann = where( d > radius & d < 1.5*radius );
   nw = numberof(w);
   xarr = span(1,dms(2),dms(2))(,-:1:dms(3));
   yarr = span(1,dms(3),dms(3))(-:1:dms(2),);

   p = array(pdat,nw)
   p.x = xarr(w);
   p.y = yarr(w);
// define initial values
   a = array(0.0,9)
   a(1) = max(im(w));
   a(2) = xpos;
   a(3) = ypos;
   a(4) = 1.0;
   a(5) = 0.1*a(1);
   a(6) = 3.0;
   a(7) = avg(im(ann));
   a(8) = 0.0;
   a(9) = 0.0;
// overwrite with frozen values
   if(n) a(index) = fvals;
   weight = array(1.0,nw);

   r = lmfit( ftepf1, p, a, im(w), weight, fit=fit );

   rim = im;
   rim(w) = ftepf1(p,a);

   grow, a, a(1)*2*pi*a(4)^2;

   if( am_subroutine() ) {
      write,"Resulting fit parameters (DP for depression valley):";
      write,format=" Amplitude      %12.5f\n", a(1);
      write,format=" X position     %12.5f\n", a(2);
      write,format=" Y position     %12.5f\n", a(3);
      write,format=" Sigma          %12.5f\n", a(4);
      write,format=" Amplitude DP   %12.5f\n", a(5);
      write,format=" Sigma DP       %12.5f\n", a(6);
      write,format=" Bkg constant * %12.5f\n", a(7)+a(8)*a(2)+a(9)*a(3);
      write,format=" Bkg X-slope    %12.5f\n", a(8);
      write,format=" Bkg Y-slope    %12.5f\n", a(9);
      write,format=" Counts in peak %12.5f\n", a(10);
      write,"     (*) at peak position";
      return;
   } else {
      return a;
   }
}

/* Function curpeakfit */

func curpeakfit( im, radius )
{
   radius = double(radius);
   dms = dimsof(im);
   fr = [5,0.0,6,10.0];
   disp,im,pane=0;
   while( !is_void((res = curmark1(nomark=1))) ) {
      r = distances(dms(2),dms(3), res(1), res(2));
      w = where( r < radius );
      d = where( im(w) == max(im(w)) )(1);
      write,format="Click %10.3f %10.3f\n", res(1), res(2);
      x = double(w(d) % dms(2));
      y = double(w(d) / dms(2));
      write,format="Max found %5.0f %5.0f\n", x, y;
      peakfit1,im,x,y,radius,rim,freeze=fr;
      c = peakfit1(im,x,y,radius,rim,freeze=fr);
      window,1;
      i1 = long(c(2)-2*radius); if( i1 < 1 ) i1 = 1;
      i2 = long(c(2)+2*radius); if( i2 > dms(2) ) i2 = dms(2);
      j = long(c(3)+0.5);
      plot,indgen(i1:i2),im(i1:i2,j),ps=10,title="X cross sect";
      i1 = long(c(2)-radius); if( i1 < 1 ) i1 = 1;
      i2 = long(c(2)+radius); if( i2 > dms(2) ) i2 = dms(2);
      oplot,indgen(i1:i2),rim(i1:i2,j),ps=10,color="green";
      window,2;
      j1 = long(c(3)-2*radius); if( j1 < 1 ) j1 = 1;
      j2 = long(c(3)+2*radius); if( j2 > dms(3) ) j2 = dms(3);
      i = long(c(2)+0.5);
      plot,indgen(j1:j2),im(i,j1:j2),ps=10,title="Y cross sect";
      j1 = long(c(3)-radius); if( j1 < 1 ) j1 = 1;
      j2 = long(c(3)+radius); if( j2 > dms(3) ) j2 = dms(3);
      oplot,indgen(j1:j2),rim(i,j1:j2),ps=10,color="green";
      window,0;
   }
}

%FILE% peakfit2.i
/*
 *  Expect 11 elements of 'a'
 */

func ftepf2( im, a )
/* DOCUMENT y = ftepf2( im, a )

    where 'x' is an array of struct 'pdat' and 'a' is a 11 element
    vector. Auxiliary function for peakfit2.
    Describes a main peak standing on a broader peak on a
    background that is a (tilted) plane.
    Returns the model image.

    2010-04-07/NJW
*/
{
   tmpl = im*0.0;
   main_peak = add_peak( tmpl, a(2), a(3), a(4), a(5), peak=a(1) );
   broad_peak = add_peak( tmpl, a(2), a(3), a(7), a(8), peak=a(6) );
   dms = dimsof(im);
   background = a(9) + a(10)*indgen(dms(2))(,-:1:dms(3)) + a(11)*indgen(dms(3))(-:1:dms(2),);

   return main_peak + broad_peak + background;
}


func peakfit2( im, xpos, ypos, radius, weight, freeze=, out=, nocor= )
/* DOCUMENT coefs = peakfit2( im, xpos, ypos, radius, weight, freeze=, out=, nocor= )

  Fits two coinciding gaussian peaks to an image using integrated gaussian
  values.
  'radius' is the limit of the source extent
  'weight' may be omitted, then a least square fit will be done. Else it should
           be given as 1/variance for the image (same dimensions).

  Returns array with:

     1: amplitude of main peak c1*exp(-0.5*((x-c2)^2+(y-c3)^2)/c4^2)
     2: x position of peak
     3: y position of peak
     4: sigmax of main peak
     5: sigmay of main peak
     6: amplitude of broad peak, usually a fraction of c1
     7: sigmax of broad peak, usually larger than c4
     8: sigmay of broad peak, usually larger than c4
     9: constant background level
    10: slope af background in x direction
    11: slope af background in y direction
    12: Number of counts in main peak (c1*c4^2*2*pi)

  Keyword 'freeze' is an a double array with
     [index1, fixed value1, index2, fixed value2, ... ]
  Keyword 'out' : Used for the call of lmfit_outres; either a filename,
                  a stream, or void.
  Keyword 'nocor' : Suppresses writing of correllation matrix

   Uses: ftepf2, lmfit, lmfit_outres;

   2010-04-07/NJW, adapted from peakfit1
*/
{
   //+ require, "lmfit.i";

   if( is_void(freeze) ) {
      fit=[];
      n = 0;
   } else {
      n = numberof(freeze);
      index = int(freeze(1:n:2));
      fvals = freeze(2:n:2);
      // make sure that the 'fit' contains the indices of not frozen parm's
      fit = [];
      for(i=1;i<=11;i++) {
         z = where(i==index);
         if(!numberof(z)) grow,fit,i;
      }
   }
   dms = dimsof(im);

   d = distances( dms(2), dms(3), xpos, ypos );
   bkg_region = where( d > radius );
// define initial values
   a = array(0.0,11)
   a(1) = max(im); // amplitude (both peaks together)
   a(2) = xpos;   // peak x position in im
   a(3) = ypos;   // peak y position in im
   a(4) = 1.0;    // sigmax main peak
   a(5) = 1.0;    // sigmay main peak
   a(6) = 0.1*a(1); // amplitude of broad peak
   a(7) = 3.0;    // sigmax broad peak
   a(8) = 3.0;    // sigmay broad peak
   a(9) = avg(im(bkg_region)); // constant level
   a(10) = 0.0;   // slope in x direction
   a(11) = 0.0;   // slope in y direction
// overwrite with frozen values
   if(n) a(index) = fvals;

   r = lmfit( ftepf2, im, a, im, weight, stdev=1, correl=1, fit=fit );
   lmfit_outres, r, out, nocor=nocor;

   grow, a, a(1)*2*pi*a(4)*a(5);

   if( am_subroutine() ) {
      write,"Resulting two peak fit parameters :";
      write,format=" Amplitude      %12.5f\n", a(1);
      write,format=" X position     %12.5f\n", a(2);
      write,format=" Y position     %12.5f\n", a(3);
      write,format=" Sigmax         %12.5f\n", a(4);
      write,format=" Sigmay         %12.5f\n", a(5);
      write,format=" Amplitude broad%12.5f\n", a(6);
      write,format=" Sigmax broad   %12.5f\n", a(7);
      write,format=" Sigmay broad   %12.5f\n", a(8);
      write,format=" Bkg constant   %12.5f\n", a(9);
      write,format=" Bkg X-slope    %12.5f\n", a(10);
      write,format=" Bkg Y-slope    %12.5f\n", a(11);
      write,format=" Counts in peak %12.5f\n", a(12);
      return;
   } else {
      return a;
   }
}

/* Function curpeakfit2 */

func curpeakfit2( im, radius )
{
   radius = double(radius);
   dms = dimsof(im);
   fr = [5,0.0,6,10.0];
   disp,im,pane=0;
   while( !is_void((res = curmark1(nomark=1))) ) {
      r = distances(dms(2),dms(3), res(1), res(2));
      w = where( r < radius );
      d = where( im(w) == max(im(w)) )(1);
      write,format="Click %10.3f %10.3f\n", res(1), res(2);
      x = double(w(d) % dms(2));
      y = double(w(d) / dms(2));
      write,format="Max found %5.0f %5.0f\n", x, y;
      peakfit2,im,x,y,radius,freeze=fr;
      c = peakfit2(im,x,y,radius,freeze=fr);
      window,1;
      i1 = long(c(2)-2*radius); if( i1 < 1 ) i1 = 1;
      i2 = long(c(2)+2*radius); if( i2 > dms(2) ) i2 = dms(2);
      j = long(c(3)+0.5);
      //+ plot,indgen(i1:i2),im(i1:i2,j),ps=10,title="X cross sect";
      //+ i1 = long(c(2)-radius); if( i1 < 1 ) i1 = 1;
      //+ i2 = long(c(2)+radius); if( i2 > dms(2) ) i2 = dms(2);
      //+ oplot,indgen(i1:i2),rim(i1:i2,j),ps=10,color="green";
      //+ window,2;
      //+ j1 = long(c(3)-2*radius); if( j1 < 1 ) j1 = 1;
      //+ j2 = long(c(3)+2*radius); if( j2 > dms(3) ) j2 = dms(3);
      i = long(c(2)+0.5);
      //+ plot,indgen(j1:j2),im(i,j1:j2),ps=10,title="Y cross sect";
      //+ j1 = long(c(3)-radius); if( j1 < 1 ) j1 = 1;
      //+ j2 = long(c(3)+radius); if( j2 > dms(3) ) j2 = dms(3);
      //+ oplot,indgen(j1:j2),rim(i,j1:j2),ps=10,color="green";
      //+ window,0;
   }
}

%FILE% photflux2spec.i
/***************************************************

   A function to turn photflux table into a spectrum
   as observed with an ideal telescope.

****************************************************/

func photflux2spec( photflux_file, rmf_file )
/* DOCUMENT photflux2spec, photflux_file, rmf_file

*/
{
   extern Eline, Flux;

   rd_photflux, photflux_file; // saves energy and flux to 'Eline' and 'Flux'
   rdm = rdfitscol( rmf_file+"[MATRIX]","matrix");
   energ_lo = rdfitscol( rmf_file+"[MATRIX]","energ_lo");
   energ_hi = rdfitscol( rmf_file+"[MATRIX]","energ_hi");
   e_min = rdfitscol( rmf_file+"[EBOUNDS]","e_min");
   e_max = rdfitscol( rmf_file+"[EBOUNDS]","e_max");

   ener = sqrt(energ_lo*energ_hi);
   flux = interpl(Flux,Eline,ener);
   de = delta(ener);
   rate = rdm(,+) * (flux*de)(+);
   rate_err = rate * sqrt(e_max) * 0.9 / sqrt(e_max(0));

   spec2phaii, "ispec.fits", rate, rate_err, exposure=100., \
        name=photflux_file, ancrfile="iarf.fits",type="net", \
        respfile=rmf_file,telescop="ideal",instrume="ideal";
   arf2phaii, "iarf.fits", array(1.,numberof(energ_lo)), energ_lo, \
        energ_hi,telescop="ideal",instrume="ideal";
}
%FILE% phsp.i
func phsp( i )
{
   extern Phs;
   s = Phs(i);
   write,format="       status  :  %4i\n", s.status;
   write,format="         flag  :  %4i\n", s.flag;
   write,format="Position    E  :  %9.4f %9.4f %9.4f\n", s.E(1), s.E(2), s.E(3);
   write,format="Direction   R  :  %9.4f %9.4f %9.4f\n", s.R(1), s.R(2), s.R(3);
   write,format="Angle in  1    :  %9.4f arcmin\n", s.angle_in1*3437.75;
   write,format="Angle out 1    :  %9.4f arcmin\n", s.angle_out1*3437.75;
   write,format="Angle in  2    :  %9.4f arcmin\n", s.angle_in2*3437.75;
   write,format="Angle out 2    :  %9.4f arcmin\n", s.angle_out2*3437.75;
   write,format="       rcoef   :  %9.4f\n", s.rcoef;
   write,format="       energy  :  %9.4f\n", s.energy;
   write,format="       mirror  :  %4i\n", s.mirror;
   write,format="Entry  OM 1 E1 :  %9.4f %9.4f %9.4f\n", s.E1(1), s.E1(2), s.E1(3);
   write,format="Entry  OM 2 E2 :  %9.4f %9.4f %9.4f\n", s.E2(1), s.E2(2), s.E2(3);
   write,format="Impact OM 1 I1 :  %9.4f %9.4f %9.4f\n", s.I1(1), s.I1(2), s.I1(3);
   write,format="Impact OM 2 I2 :  %9.4f %9.4f %9.4f\n", s.I2(1), s.I2(2), s.I2(3);
   write,format="Direc entry D1 :  %9.4f %9.4f %9.4f\n", s.D1(1), s.D1(2), s.D1(3);
   write,format="Direc betwe D2 :  %9.4f %9.4f %9.4f\n", s.D2(1), s.D2(2), s.D2(3);
}
%FILE% plcm.i
func plcm( z, y, x, cmin=, cmax=, sz=, shape= ) {
/* DOCUMENT plcm   Plot markers z,y,x where z will be color coded

   Plots a scatter plot where z determines the color of the marker. 
   z,y, and x must all be the same size. sz= the size in NDC coords of the
   marker.  If shape= is defined as anything it will cause plcm to 
   generate squares.  If shape= is not defined plcm will generate triangles.

   This function is useful for plotting data that's a function of three 
   variables.  In my case, it's frequently latitude, longitude, and 
   elevation where elevation variations are shown as varying colors.

   C. W. Wright 11/7/1999  wright@web-span.com
*/
 local xx,yy,zz,nn;		// 

 if ( is_void(sz) ) {
   sz = 0.001;
 }
 if ( is_void(shape) ) {
   px = [0,-sz,sz];		// define a triangle
   py = [sz,-sz,-sz];
 } else {
   px = [sz,-sz,-sz,sz];	// define a square
   py = [sz,sz,-sz,-sz];
 }
 
 n = array(1, numberof(z) );	// Use special case
 n(1) = numberof(px);		// a triangle (3 corners)
 grow, xx, px, x 		// glue the triangle to the
 grow, yy, py, y		// front of the data
 grow, zz, array(0, numberof(px)), z	// 
 grow, nn, n, array(0, numberof(px))	// 
  nn(0) = 1;
 plfp, zz,yy,xx, nn, cmin=cmin, cmax=cmax
}


%FILE% plcrabgain.i
n = numberof(list);
res = [];
x = [];
for(i = 1; i <= n; i++ ) {
   if( ! file_test(list(i)) ) {
      write,format="%s does not exist\n", list(i);
      continue;
   }
   revol= atof(strpart(swids(i),1:4))+atof(strpart(swids(i),5:8))/100;
   dol = list(i)+"+1";
   if( is_void( (gvec = rdfitscol(dol,"gain")) ) ) {
      write,format="%s has no rows\n", dol;
      continue;
   }
   gain = avg(gvec);
   grow,x,revol;
   grow,res,gain;
}
%FILE% plcrabgaindetail.i
window,1,style="boxed.gs";
plot,x-239,res,ps=2,title="JMX1 239",xtitle="Revol",ytitle="gain [keV/PHA]",xr=[0,1.3],yr=[14,25];
window,2,style="boxed.gs";
plot,x-300,res,ps=2,title="JMX1 300",xtitle="Revol",ytitle="gain [keV/PHA]",xr=[0,1.3],yr=[14,25];
window,3,style="boxed.gs";
plot,x-365,res,ps=2,title="JMX1 365",xtitle="Revol",ytitle="gain [keV/PHA]",xr=[0,1.3],yr=[14,25];
window,4,style="boxed.gs";
plot,x-422,res,ps=2,title="JMX1 422",xtitle="Revol",ytitle="gain [keV/PHA]",xr=[0,1.3],yr=[14,25];
window,5,style="boxed.gs";
plot,x-541,res,ps=2,title="JMX1 541",xtitle="Revol",ytitle="gain [keV/PHA]",xr=[0,1.3],yr=[14,25];
window,6,style="boxed.gs";
plot,x-605,res,ps=2,title="JMX1 605",xtitle="Revol",ytitle="gain [keV/PHA]",xr=[0,1.3],yr=[14,25];
%FILE% plot.i
/* Function plotdoc */

extern plotdoc;
/* DOCUMENT ******************************************
 *
 *     A package of extra plot functions
 *
 *      2004-11-11/NJW
 *

       add_hgraph                 plh                        
       add_vgraph                 plhis                      
       annot                      plhisc                     
       curtext                    plhisv                     
       curve_edit                 plot                       
       d3plot
       dataplot                   plot_p2spec                
       dataplotf                  plot_spectrum              
       def_sym                    plotcomments               
       devicetitles               plotdate                   
       esc_uscore                 plotname                   
       mcoord_conv                plotsign                   
       mlogxy                     plthis                     
       mplot_setup                poly_fill                  
       odataplot                  poly_fillc                 
       odataplotf                 qdp                        
       oplot                      wplot                      
       oplot_spectrum             xyouts                     
       oplthis                    zps                        
       owplot                     

   extern Logxy_flags_content, Logxy_flags_values;
                          // used in 'mlogxy' (to be used in stead of logxy)
   extern _Annot_text, _Annot_ps, _Annot_li, _Annot_symsize;
			  // used in 'annot'
   extern Def_sym_size_x, Def_sym_size_y, Def_sym_number, Def_sym_x, Def_sym_y;
			  // used in 'plot' and 'def_sym'
   extern PLOTCOMMENTS_YLEV; // array with 8 elements; used in 'plotcomments'

   Defines red, blue, green, black, and dtured

*******************************************************/

red = "red";
blue = "blue";
green = "green";
black = "black";
dtured = [200,50,30];


/* Function annot */

func annot( text, mode=, ps=, li=, thick=, symsize=, color=, fill=, pos=, height= )
/* DOCUMENT annot, text, mode=, ps=, li=, thick=, symsize=, color=, fill=, pos=, height=

   Make annotations in the plot in a similar way as 'legend' in IDL.
   See example below.

   mode "i"  initialize
   mode "u" or "a" update (not required if the 'text' argument is given as a string)
   mode "x"  execute i.e. put on plot (not required if n 'text' and no 'mode="i"')

   'height' must be one of 8, 10, 12, 14, 16, 18, 24, or 36
     and represents the character height in points; 1 point = 0.0013 NDC units

   'pos' is a two-element array with (x,y) of the lower left corner of
    the annotation box in virtual coordinates i.e. where the viewing port
    is between (0,0) and (1,1).

   The keywords 'pos' and 'height' are only active in "execute" mode.

   Each time "annot" is invoked in update mode the text string is added to
   a buffer that is shown on the plot when invoked in "execute" mode.

   Example:
      > annot,mode="i"; // initialization
      > annot,"First curve",li=2,color="green"; // updates only
      > annot,"Points",ps=3,color="blue"; // updates only
      > annot,pos=[0.5,0.0],height=24;     // puts the annotations on the plot

   2008-08-15/NJW
   2008-10-24/NJW allow for composite symbols
   2012-06-12/NJW Use [r,g,b] representation of color

*/
{
   extern _Annot_text, _Annot_ps, _Annot_li, _Annot_symsize, \
          _Annot_thick, _Annot_color, _Annot_fill, _Annot_id;

   // _Annot_color is an integer matrix with dimension 3 x <number of colors>

   local x_wor, y_wor;  // result from mcoord_conv
   local x1_wor, x2_wor;  // result from mcoord_conv
   local px_ndc, py_ndc;  // result from mcoord_conv

   if( !is_void(mode) ) {
      if( mode != "i" && mode != "u" && mode != "a" && mode != "x" ) {
         write,"ANNOT: Illegal 'mode' keyword";
         return;
      }
   }

   if( is_void(text) ) { // -- 'text' is absent, only initialization or execution
      if( is_void(mode) ) {
         mode = "x"; // no arguments given, will execute
      } else {
         if( mode == "u" || mode == "a" ) {
            write,"ANNOT: Illegal arguments";
            return;
         }
      }
   } else { // -----  here 'text' contains something
      if( is_void(mode) ) {
         mode = "u"; //     just update
      }
   }

   if( is_void(height) ) {
      height = 14;
   } else {
      h = height;
      height = 36;
      if( h <= 30.0 ) height = 24;
      if( h <= 21.0 ) height = 18;
      if( h <= 17.0 ) height = 16;
      if( h <= 15.0 ) height = 14;
      if( h <= 13.0 ) height = 12;
      if( h <= 11.0 ) height = 10;
      if( h <=  9.0 ) height =  8;
   }
   // Compute character height in NDC units but
   // add 10% for separation of characters
   h_charsize = 1.1 * height * 0.0013;
   //+ x_text_offset = 0.1; // **
   x_text_offset = 0.06
   x_symbol_offset = 0.5 * x_text_offset;
   y_symbol_offset = 0.3 * h_charsize;
   y_line_offset =   0.3 * h_charsize;
   x1_line_offset =   0.1 * x_text_offset;
   x2_line_offset =   0.8 * x_text_offset;

   if( mode == "i" ) {
      _Annot_text = _Annot_ps = _Annot_li = _Annot_id = [];
      _Annot_symsize = _Annot_color = _Annot_fill = _Annot_thick = [];
   } else if( mode == "u" || mode == "a" ) {
      // find next identifier
      n_id = numberof(_Annot_id);
      if( n_id ) {
         next_id = _Annot_id(0) + 1; // 1 larger than latest
      } else next_id = 1;
      // find the non-void keywords and define multiplicity
      n_ps =  is_void(ps) ? 0 : numberof(ps);
      n_li =  is_void(li) ? 0 : numberof(li);
      n_thick =  is_void(thick) ? 0 : numberof(thick);
      n_symsize =  is_void(symsize) ? 0 : numberof(symsize);

      // Special handling of color

      if( is_void(color) ) {
         color = reform([0,0,0],3,1);
      } else {
         if( typeof(color) == "string" ) {
            color = resolve_color( color );
         }
         if( dimsof(color)(1) < 2 ) color = reform(color,3,1);
      }
      n_color =  dimsof(color)(3);
      multi = max([n_ps,n_li,n_thick,n_symsize,n_color]);
      if( n_ps > 0 && n_ps != multi ) error,"Bad ps multiplicity";
      if( n_li > 0 && n_li != multi ) error,"Bad li multiplicity";
      if( n_thick > 0 && n_thick != multi ) error,"Bad thick multiplicity";
      if( n_symsize > 0 && n_symsize != multi ) error,"Bad symsize multiplicity";
      if( n_color > 0 && n_color != multi ) error,"Bad color multiplicity";

      if( is_void(ps) ) ps = array(-1,multi);
      if( is_void(li) ) li = array(-1,multi);
      thick =  is_void(thick) ? array(-1.0,multi) : double(thick);
      symsize = is_void(symsize) ? array(1.0,multi) : double(symsize);
      if( is_void(fill) ) fill = array(0,multi);

      grow, _Annot_text, array(text,multi);
      grow, _Annot_ps, ps;
      grow, _Annot_li, li;
      grow, _Annot_thick, thick;
      grow, _Annot_symsize, symsize;
      grow, _Annot_color, color;
      grow, _Annot_fill, fill;
      grow, _Annot_id, array(next_id, multi);

   } else if( mode == "x" ) { // Put annotations on the plot

      // Check if there are any

      if( numberof(_Annot_id) ) {

         // calculate default annotation origin
         mcoord_conv, 0.0, 0.0, px_ndc, py_ndc, from="vir", to="ndc";
         if( !is_void(pos) ) {
            if( numberof(pos) != 2 ) {
               write,"'pos' has illegal dimensionality, disregard";
               pos = [];
            }
            mcoord_conv, pos(1), pos(2), px_ndc, py_ndc,from="vir",to="ndc";
         }

         u_id = uniq(_Annot_id);
         //+ n = numberof(_Annot_text);
         n = _Annot_id(0);
         for(i=1;i<=n;i++) {
            // determine multiplicity
            multi = i < n ? u_id(i+1)-u_id(i) : numberof(_Annot_id)-u_id(i)+1;
            j = u_id(i);
            //  Put the text on the plot
            y_ndc = (n-i+1)*h_charsize + py_ndc;
            x_ndc = x_text_offset + px_ndc;
            //+ print,"text xy ndc:", x_ndc, y_ndc;
            plt,_Annot_text(j),x_ndc,y_ndc,tosys=0,height=height;
            //  Add a symbol?
            for( k = j; k < j+multi; k++ ) {
               if( _Annot_ps(k) > -1 ) {
                  x_ndc = x_symbol_offset + px_ndc;
                  y_ndc = (n-i+1)*h_charsize + py_ndc + y_symbol_offset;
                  //+ print,"symbol xy ndc:",x_ndc, y_ndc;
                  mcoord_conv, x_ndc, y_ndc, x_wor, y_wor, from="ndc", to="wor";
                  //+ print,"symbol xy wor:", x_wor, y_wor;
                  clr = _Annot_color(,k);
                  fll = _Annot_fill(k) == 0 ? [] : _Annot_fill(k);
                  oplot,[x_wor],[y_wor],ps=_Annot_ps(k),symsize=_Annot_symsize(k),color=clr,fill=fll;
               }
               //  Add a line?
               if( _Annot_li(k) > -1 ) {
                  x1_ndc = x1_line_offset + px_ndc;
                  x2_ndc = x2_line_offset + px_ndc;
                  y_ndc = (n-i+1)*h_charsize + py_ndc + y_line_offset;
                  //+ print,"line xy ndc:",x1_ndc, x2_ndc, y_ndc;
                  mcoord_conv, x1_ndc, y_ndc, x1_wor, y_wor, from="ndc", to="wor";
                  mcoord_conv, x2_ndc, y_ndc, x2_wor, y_wor, from="ndc", to="wor";
                  //+ print,"line xy wor:", x1_wor, x2_wor, y_wor;
                  clr = _Annot_color(,k);
                  thk = _Annot_thick(k) < 0 ? [] : _Annot_thick(k);
                  oplot,[x1_wor,x2_wor],[y_wor,y_wor],li=_Annot_li(k),thick=thk,color=clr;
               }
            }
         }
      }
   } // terminates 'put annotations on plot'

}

/* Function plot */

func plot( x, y, li=, ps=, color=, xr=, yr=, symsize=, \
              itype=, thick=, title=, xtitle=, ytitle=, mpl=, dbg=, \
              fill=, titleheight=, xytitleheight=, xyadjust=, titlefont= )
/* DOCUMENT plot, x, y, li=, ps=, color=, xr=, yr=,\
              itype=, symsize=, thick=, title=, xtitle=, ytitle=, mpl=, \
              dbg=, fill=, titleheight=, xytitleheight=, xyadjust=, titlefont=

   A function similar to the IDL 'plot' function. The Yorick
   'fma' call is included so that the plot is renewed. For
   overplot use 'oplot'.
   If only one argument is given then it is interpreted as 'y'
   and the x will be indgen(numberof(y)).

   KEYWORDS: li, ps, color, xr, yr, symsize, thick, title,
             xtitle, ytitle, itype, mpl, dbg, fill,
             titleheight, xytitleheight, xyadjust, titlefont

             li             Linetype
             ps             Plot symbol
             color          Color
             xr             Range in X (two element array)
             yr             Range in Y (two element array)
             symsize        Symbol size
             thick          Line thickness
             title          Plot title
             xtitle         Title for abscissa
             ytitle         Title for ordinate
             itype          Flag for axis transforms: 0(linlin), 1(linlog), 2(loglin), 3(loglog)
             mpl            Number of subframe
             dbg            Switch on debugging output
             fill           Flag for symbol filling whenever possible
             titleheight    Font size for plot title
             xytitleheight  Font size for axis titles
             xyadjust
             titlefont      Font for titles

   SEE ALSO: oplot, plg, mplot_setup, dataplot, dataplotf

   2007-02-28/NJW update with itype keyword
   2010-10-03/NJW update with fill keyword
*/

{

   extern Def_sym_size_x, Def_sym_size_y, Def_sym_number, Def_sym_x, Def_sym_y;
   extern pltitle_height, pltitle_font;

   // Save plot title externals
   Pltitle_height = pltitle_height;
   Pltitle_font = pltitle_font;

   // Check arguments

   if( is_void(y) ) {
      y = x;
      x = indgen(numberof(y));
   }
   // dbg
   if( dbg ) {
      if( is_void(mpl) ) {
         write,"PLOT called with void 'mpl'";
      } else {
         write,format="PLOT called with mpl = %i\n", mpl;
         write,format="PLOT ##2## plsys = %i\n", plsys();
      }
   }

   if( numberof(mpl) ) {
      // dbg
      if( dbg ) write,"PLOT calling plsys";
      plsys,mpl;
      if( dbg ) write,format="PLOT ##3## plsys = %i\n", plsys();
   } else {
      // dbg
      if( dbg ) write,"PLOT resetting frame";
      fma; // resets the frame i.e. current plotting window
   }

   // Define the plot type (lin-lin, lin-log, log-lin, log-log)

   it = is_void(itype) ? 0: itype;
   xlog = it > 1 ? 1 : 0;
   ylog = it % 2 ? 1 : 0;
   mlogxy, xlog, ylog, mpl=mpl,dbg=dbg;


   limits; // restarts axis range limits
   // dbg
   if( dbg ) write,format="PLOT ##4## plsys = %i\n", plsys();
   if( numberof(xr) ) {
      limits,xr(1),xr(2);
   } else {
      if( xlog ) {
         difference = log(max(x) / min(x));
         mx = max(x) * exp(0.05*difference);
         mn = min(x) / exp(0.05*difference);
      } else {
         difference = max(x) - min(x);
         mx = max(x) + 0.05*difference;
         mn = min(x) - 0.05*difference;
      }
      limits, mn, mx;
   }
   if( numberof(yr) ) {
      limits,,,yr(1),yr(2);
   } else {
      if( ylog )  {
         w = where(y > 0.0);
         difference = log(max(y(w)) / min(y(w)));
         mx = max(y) * exp(0.05*difference);
         mn = min(y) / exp(0.05*difference);
      } else {
         difference = max(y) - min(y);
         mx = max(y) + 0.05*difference;
         mn = min(y) - 0.05*difference;
      }
      limits,,, mn, mx;
   }
   // dbg
   if( dbg ) write,format="PLOT ##5## plsys = %i\n", plsys();

   if( ps ) {
      if( ps == 10 ) {
         plhis, y, x, marks=0, type=li, color=color, width=thick;
      } else if( ps == 100 ) {
         plhisv, y, x, marks=0, type=li, color=color, width=thick;
      } else if( abs(ps) > 10 ) {
         if( ps < 0 ) {
            // plot the curve
            plg, y, x, marks=0, type=li, color=color, msize=symsize, \
                   legend="", width=thick;
            ps = -ps;
         }
         // plot individual points
         wcoor = limits();
         if( is_void(symsize) ) symsize = 1.0;
         if( xlog ) {
            Def_sym_size_x = log(wcoor(2) / wcoor(1))*0.05*symsize;
         } else {
            Def_sym_size_x = (wcoor(2) - wcoor(1))*0.05*symsize;
         }
         if( ylog ) {
            Def_sym_size_y = log(wcoor(4) / wcoor(3))*0.05*symsize;
         } else {
            Def_sym_size_y = (wcoor(4) - wcoor(3))*0.05*symsize;
         }

         // Define the external arrays Def_sym_x/y
         def_sym, ps;
         possible_fills = [13,19,20,21,22,23,24,25,26,27];

         for(i=1;i<=numberof(x);i++) {
            if( xlog ) {
               xarr = x(i)*exp(Def_sym_x);
            } else {
               xarr = x(i)+Def_sym_x;
            }
            if( ylog ) {
               yarr = y(i)*exp(Def_sym_y);
            } else {
               yarr = y(i)+Def_sym_y;
            }
            dmsx = dimsof(xarr);
            if( dmsx(1) == 2 ) { // When the symbol consists of more than a single
                                 // polygon or line e.g. a cross
               for(j=1;j<=dmsx(3);j++) {
                  plg, yarr(,j), xarr(,j), marks=0, type=1, color=color, \
                    legend="",width=thick;
               }
            } else if( fill && nallof(ps - possible_fills) ) {
               poly_fillc, xarr, yarr, color=color;
            } else {
               plg, yarr, xarr, marks=0, type=1, color=color, \
                 legend="",width=thick;
            }
     /* Some of the symbols can be plotted as filled:
      *       
      *   13 - Circle                  23 - Star 6
      *   19 - Square                  24 - Star 7
      *   20 - Triangle on bottom      25 - Star 6
      *   21 - Triangle on tip         26 - Star 9
      *   22 - Star                    27 - Diamond
      */
         }
      } else {
         if( ps < 0 ) {
            // plot the curve
            plg, y, x, marks=0, type=li, color=color, msize=symsize, \
                   legend="", width=thick;
            ps = -ps;
         }
         // plot individual points
         plg, y, x, marks=0, type=0, marker=ps, color=color, \
                   legend="", msize=symsize, width=thick;
      }
   } else {
      plg, y, x, marks=0, type=li, color=color, msize=symsize, \
                   legend="", width=thick;
   }
   if( numberof(title) ) {
      if( !is_void(titleheight) ) pltitle_height = titleheight;
      if( !is_void(titlefont) ) pltitle_font = titlefont;
      pltitle,title;
   }
   if( is_void(xtitle) ) xtitle = "";
   if( is_void(ytitle) ) ytitle = "";
   if( !is_void(xytitleheight) ) pltitle_height = xytitleheight;
   if( !is_void(titlefont) ) pltitle_font = titlefont;
   xytitles,xtitle,ytitle,xyadjust;

   plotcomments, init=1; // initializes the text position on the page
       // by external PLOTCOMMENTS_YLEV

   // Reset default title height and font

   pltitle_font = Pltitle_font;
   pltitle_height = Pltitle_height;

}

/* Function oplot */

func oplot( x, y, li=, ps=, color=, symsize= ,thick=, fill= )
/* DOCUMENT oplot, x, y, li=, ps=, color=, symsize= ,thick=, fill=

   A function similar to the IDL 'oplot' function.
   For new plot use 'plot'.

   If only one argument is given then it is interpreted as 'y'
   and the x will be indgen(numberof(y)).

   KEYWORDS: li, ps, color, symsize, thick, fill
   SEE ALSO: plot, plg
*/

{

   extern Def_sym_size_x, Def_sym_size_y, Def_sym_number, Def_sym_x, Def_sym_y;

   // Check arguments

   if( is_void(y) ) {
      y = x;
      x = indgen(numberof(y));
   }


   if( ps ) {
      if( ps == 10 ) {
         plhis, y, x, marks=0, type=li, color=color, width=thick;
      } else if( ps == 100 ) {
         plhisv, y, x, marks=0, type=li, color=color, width=thick;
      } else if( abs(ps) > 10 ) {
         if( ps < 0 ) {
            // plot the curve
            plg, y, x, marks=0, type=li, color=color, msize=symsize, \
                   legend="", width=thick;
            ps = -ps;
         }
         // Get log plotting flags

         local xlog, ylog;
         mlogxy, xlog, ylog, get=1;

         // plot individual points
         wcoor = limits();
         if( is_void(symsize) ) symsize = 1.0;
         if( xlog ) {
            Def_sym_size_x = log(wcoor(2) / wcoor(1))*0.05*symsize;
         } else {
            Def_sym_size_x = (wcoor(2) - wcoor(1))*0.05*symsize;
         }
         if( ylog ) {
            Def_sym_size_y = log(wcoor(4) / wcoor(3))*0.05*symsize;
         } else {
            Def_sym_size_y = (wcoor(4) - wcoor(3))*0.05*symsize;
         }
         // Define plotting symbol external variables: Def_sym_x/y
         def_sym, ps;
         possible_fills = [13,19,20,21,22,23,24,25,26,27];

         for(i=1;i<=numberof(x);i++) {
            if( xlog ) {
               xarr = x(i)*exp(Def_sym_x);
            } else {
               xarr = x(i)+Def_sym_x;
            }
            if( ylog ) {
               yarr = y(i)*exp(Def_sym_y);
            } else {
               yarr = y(i)+Def_sym_y;
            }
            dmsx = dimsof(xarr);
            if( dmsx(1) == 2 ) {
               for(j=1;j<=dmsx(3);j++) {
                  plg, yarr(,j), xarr(,j), marks=0, type=1, color=color, \
                    legend="",width=thick;
               }
            } else if( fill && nallof(ps - possible_fills) ) {
               poly_fillc, xarr, yarr, color=color;
     /* Some of the symbols can be plotted as filled:
      *       
      *   13 - Circle                  23 - Star 6
      *   19 - Square                  24 - Star 7
      *   20 - Triangle on bottom      25 - Star 6
      *   21 - Triangle on tip         26 - Star 9
      *   22 - Star                    27 - Diamond
      */
            } else {
               plg, yarr, xarr, marks=0, type=1, color=color, \
                 legend="",width=thick;
            }
         }
      } else {
         if( ps < 0 ) {
            plg, y, x, marks=0, type=li, color=color, msize=symsize, \
                legend="", width=thick;
            ps = -ps;
         }
         plg, y, x, marks=0, type=0, marker=ps, color=color, \
                   legend="", msize=symsize, width=thick;
      }
   } else {
      plg, y, x, marks=0, type=li, color=color, msize=symsize, \
                   legend="", width=thick;
   }
}

/* Function plh  */

func plh( y, x, marks=, color=, type=, width=)
/* DOCUMENT plh, y, x
   plot a histogram of Y versus X. If X has one more element
   than Y, the plot will begin and end with a horizontal segment;
   if Y has one more element than X, the plot will begin and and
   with a vertical segment. The keywords are a subset of those for
   plg.
   KEYWORDS: marks, color, type, width
   SEE ALSO: plg, plhis, plhisc, plhisv, plthis
*/
{
   //  Define x array if not given
   if( numberof(x) == 0 ) {
      x = span(0.0,1.0*numberof(y),numberof(y)+1);
   }

   swap = numberof(x)<numberof(y);
   if( swap ) { yy = y; y = x; x = yy; }
   yy = xx = array(0.0,2*min(numberof(y),numberof(x)));
   yy(1:-1:2) = yy(2:0:2) = y;
   xx(2:-2:2) = xx(3:-1:2) = x(2:-1);
   xx(1) = x(1);
   xx(0) = x(0);
   if( swap ) { y = yy; yy = xx; xx = y; }
   plg, yy, xx, marks=marks, color=color, type=type, \
                legend="", width=width;
}

/* Function plhis  */

func plhis( y, x, marks=, color=, type=, width=)
/* DOCUMENT plhis, y, x, marks=, color=, width=

   Plot a histogram where x and y have the same number of
   elements

   KEYWORDS: marks, color, type, width
   SEE ALSO: plh, plg, plhisc, plhisv, plthis, [plot,..,ps=10]
*/

{
   require,"idlx.i";

   if( numberof(x) == 0 ) x = span(0.5,0.5+numberof(y)-1,numberof(y));
   yy = xx = array(double,2*numberof(y));
   yy(1:-1:2) = yy(2:0:2) = y;
   z = shift(x,1);
   xx(2:-2:2) = xx(3:-1:2) = 0.5*(x(1:-1)+z(1:-1));
   xx(1) = x(1);
   xx(0) = x(0);
   plg,yy,xx,marks=marks, color=color, type=type, \
                legend="", width=width;
}

/* Function plthis */

func plthis( x1, x2, y, li=, color=, xr=, yr=, \
              itype=, thick=, title=, xtitle=, ytitle=, mpl=, dbg=, \
              titleheight=, xytitleheight=, xyadjust=, titlefont= )
/* DOCUMENT plthis, x1, x2, y
    or      plthis, x, y  {in this version x may have one more element than y}

     Keywords: li=, color=, xr=, yr=,
               itype=, thick=, title=, xtitle=, ytitle=, mpl=, dbg=,
               titleheight=, xytitleheight=, xyadjust=, titlefont=

     Plot a histogram where x1,x2 give the channel boundaries

     Alternatively: x has one more element that y so that
         x1 = x(1:-1) & x2 = x(2:)
     Alternatively: x same number of elements as y so that
         x1 = [x(1),x(zcen)] & x2 = [x(zcen),x(0)]

    SEE ALSO: plh, plg, plhis, plhisc, plhisv, [plot,..,ps=10]
*/
{
   nx1 = numberof(x1);
   if( is_void(y) ) { // can it be the alternative version?
      if( numberof(x2) + 1 == nx1 ) { // fine, go ahead
         x = x1;
         y = x2;
         x1 = x(1:-1);
         x2 = x(2:0);
         nx1--;
      } else if( numberof(x2) == nx1 ) { // also fine, go ahead
         x = x1;
         y = x2;
         x1 = grow(x(1),x(zcen));
         x2 = grow(x(zcen),x(0));
      }
   }

   if( nx1 != numberof(x2) ) error,"Mismatching array size x1 x2";
   if( nx1 != numberof(y) ) error,"Mismatching array size x1 y";

   yout = y(indgen(2:2*nx1+1)/2);
   xout = grow(x1(1),x2(indgen(2:2*nx1)/2));

   plot, xout, yout, li=li, color=color, xr=xr, yr=yr, \
              itype=itype, thick=thick, title=title, xtitle=xtitle, \
              ytitle=ytitle, mpl=mpl, dbg=dbg, \
              titleheight=titleheight, xytitleheight=xytitleheight, \
              xyadjust=xyadjust, titlefont=titlefont;

}
  
/* Function oplthis */

func oplthis( x1, x2, y, li=, color=, thick= )
/* DOCUMENT oplthis, x1, x2, y, li=, color=, thick=
     or      oplthis, x, y     {x may have one more element than y}

     Overplot a histogram where x1,x2, give the channel boundaries

     Alternatively: x has one more element that y so that
         x1 = x(1:-1) & x2 = x(2:)
     Alternatively: x same number of elements as y so that
         x1 = [x(1),x(zcen)] & x2 = [x(zcen),x(0)]
*/
{
   nx1 = numberof(x1);
   if( is_void(y) ) { // can it be the alternative version?
      if( numberof(x2) + 1 == nx1 ) { // fine, go ahead
         x = x1;
         y = x2;
         x1 = x(1:-1);
         x2 = x(2:0);
         nx1--;
      } else if( numberof(x2) == nx1 ) { // also fine, go ahead
         x = x1;
         y = x2;
         x1 = grow(x(1),x(zcen));
         x2 = grow(x(zcen),x(0));
      }
   }
   if( nx1 != numberof(x2) ) error,"Mismatching array size x1 x2";
   if( nx1 != numberof(y) ) error,"Mismatching array size x1 y";

   yout = y(indgen(2:2*nx1+1)/2);
   xout = grow(x1(1),x2(indgen(2:2*nx1)/2));

   oplot, xout, yout, li=li, color=color, thick=thick;

}

/* Function plhisv  */

func plhisv( y, x, marks=, color=, type=, width= )
/* DOCUMENT plhisv, y, x, marks=, color=, width=

   Plot a 'vertical' histogram where x and y have the same number of
   elements

   KEYWORDS: marks, color, type, width
   SEE ALSO: plh, plg, plhis
*/

{
   if( numberof(x) == 0 ) x = span(0.5,0.5+numberof(y)-1,numberof(y));
   yy = xx = array(double,2*numberof(y));
   yy(1:-1:2) = yy(2:0:2) = y;
   z = shift(x,1);
   xx(2:-2:2) = xx(3:-1:2) = 0.5*(x(1:-1)+z(1:-1));
   xx(1) = x(1);
   xx(0) = x(0);
   plg,xx,yy,marks=marks, color=color, type=type, \
                legend="", width=width;
}

/* Function plhisc  */

func plhisc( y, x, color=, y0=)
/* DOCUMENT plhisc, y, x

   Plot a histogram where x and y have the same number of
   elements

   KEYWORDS: color, y0

   SEE ALSO: plh, plg, plhis, plhisv, plthis [plot,..,ps=10]
*/

{
   require,"idlx.i";
   if( is_void(color) ) color="black";
   if( is_void(y0) ) y0=min(y);

   if( numberof(x) == 0 ) x = span(0.5,0.5+numberof(y)-1,numberof(y));
   yy = xx = array(double,2*numberof(y)+2);
   yy(1:-3:2) = yy(2:-2:2) = y;
   z = shift(x,1);
   xx(2:-4:2) = xx(3:-3:2) = 0.5*(x(1:-1)+z(1:-1));
   xx(1) = x(1);
   xx(-2) = x(0);

   yy(-1) = yy(0) = y0;
   xx(-1) = xx(-2);
   xx(0)  = xx(1);
   poly_fillc, xx, yy, color=color;
}

/* Function dataplot */

func dataplot( x, y, dy, xr= , yr= , ps= , mpl=, \
                 xbar= , fxbar= , itype=, color=, thick=, \
                 xtitle=, ytitle=, title=, symsize=, dbg=, \
                 titleheight=, xytitleheight=, titlefont=, xyadjust= )
/* DOCUMENT dataplot, x, y, dy, xr=,yr=,ps=,mpl=,xbar=,fxbar=,thick=,\
                  itype=,xtitle=,ytitle=,title=,color=, symsize=, dbg=,
                  titleheight=, xytitleheight=, titlefont=, xyadjust=

  Plot of datapoints with 'errorbars' in x-direction defined
  by channel limits derived from spacing between points.
  In the y-direction the length of the error bars are given by '+-dy'
  In the x-direction bars only appear if keyword 'xbar' has been
  specified

  The type of plot is indicated with the keyword 'itype'
    itype = 0  :    x lin - y lin (default)
    itype = 1  :    x lin - y log
    itype = 2  :    x log - y lin
    itype = 3  :    x log - y log

    ~1995/NJW
    2004-09-28/NJW  Updated with better error message
    2005-05-27/NJW  Included keyword 'fxbar': fixed x-bar
    2006-02-20/NJW  Yorick version

*/
{

   nx = numberof(x);
   if( (nx != numberof(y)) || (nx != numberof(dy)) ) {
     write,"DATAPLOT error: The arrays have different dimensions !\n";
     return;
   }

   // Define the plot type (lin-lin, lin-log, log-lin, log-log)

   it = is_void(itype) ? 0 : itype;
   xlog = it > 1 ? 1 : 0;
   ylog = it % 2 ? 1 : 0;

   // Define boundaries between abscissa values;

   if( nx > 1 ) {
      sx = shift(x,-1);
      sxl = array(double,nx+1);
      if( xlog ) {
         sx = sqrt(x*sx);
         sxl(1:nx) = sx;
         sxl(1) = sqrt(x(1)^3 / x(2));
         sxl(0) = sqrt(x(0)^3 / x(-1));
      } else {
         sx = 0.5*(x + sx);
         sxl(1:nx) = sx;
         sxl(1) = (3*x(1) - x(2))*0.5;
         sxl(0) = (3*x(0) - x(-1))*0.5;
      }
   }

   // Define abscissa plot range;

   xdmin = min(x);
   xdmax = max(x);
   if( numberof(xbar) && nx > 1 ) {
      xdmin = min(sxl);
      xdmax = max(sxl);
   }
   if( numberof(fxbar) ) {
      xdmin = xdmin - fxbar;
      xdmax = xdmax + fxbar;
   }
   if( !numberof(xr) ) {
      if( xlog ) {
         xmin = xdmin^1.05 / xdmax^0.05;
         xmax = xdmax^1.05 / xdmin^0.05;
      } else {
         xmin = xdmin - 0.05 * (xdmax - xdmin);
         xmax = xdmax + 0.05 * (xdmax - xdmin);
      }
      xrg = [xmin,xmax];
   } else xrg = xr;

   // Define ordinate plot range;

   if( !numberof(yr) ) {
      if( ylog ) {
         positive = where( y - dy > 0 );
         ymin = min(y(positive)-dy(positive))^1.05 / max(y+dy)^0.05;
         ymax = max(y+dy)^1.05 / min(y(positive)-dy(positive))^0.05;
      } else {
         ymin = min(y-dy) - 0.05 * (max(y+dy) - min(y-dy));
         ymax = max(y+dy) + 0.05 * (max(y+dy) - min(y-dy));
      }
      yrg = [ymin,ymax];
   } else yrg = yr;

   // Set up plot

   plot,[1],[1],xr=xrg,yr=yrg,itype=itype,title=title,xtitle=xtitle, \
                ytitle=ytitle,mpl=mpl,dbg=dbg,titleheight=titleheight, \
                xytitleheight=xytitleheight, titlefont=titlefont, xyadjust=xyadjust;
   //+ mlogxy,xlog,ylog;
   //+ limits,xrg(1),xrg(2),yrg(1),yrg(2);
   // dbg
   if( dbg ) write,format="DATAPLOT: After call of plot - plsys = %i\n", plsys();
   if( numberof(mpl) ) plsys, mpl;
   if( dbg ) write,format="DATAPLOT: After call of plsys - plsys = %i\n", plsys();


   for( i = 1; i <= nx; i++ ) {
     //  horizontal pieces (only if requested)
     if( numberof(xbar) && nx > 1 ) oplot,sxl(i:i+1),[y(i),y(i)],color=color,thick=thick;
     // vertical pieces
     oplot,[x(i),x(i)],[y(i)-dy(i),y(i)+dy(i)],color=color,thick=thick;
   }

   // Plot fixed horizontal piece if requested;

   if( !is_void(fxbar) ) {
      for( i = 1; i<= nx; i++ ) {
         oplot,[x(i)-fxbar,x(i)+fxbar],[y(i),y(i)],color=color,thick=thick;
      }
   }

   if( !is_void(ps) ) oplot,x,y,ps=ps,color=color,symsize=symsize,thick=thick;

}


/* Function odataplot */

func odataplot( x, y, dy, ps= , xbar= , fxbar= , color=, thick= )
/* DOCUMENT odataplot, x, y, dy, ps=, xbar=, fxbar=, color=, thick=

  Overplot of datapoints with 'errorbars' in x-direction defined
  by channel limits derived from spacing between points.
  In the y-direction the length of the error bars are given by '+-dy'
  In the x-direction bars only appear if keyword 'xbar' has been
  specified

    2007-02-28/NJW  Yorick version

*/
{
   if( is_void(dy) ) {
      write,"Syntax: odataplot, x, y, dy[, ps=]";
      write,"              [,xbar=][,fxbar=][,color=]";
      return;
   }
   nx = numberof(x);
   if( (nx != numberof(y)) || (nx != numberof(dy)) ) {
     write,"ODATAPLOT error: The arrays have different dimensions !";
     return;
   }

   // Define boundaries between abscissa values;

   if( nx > 1 ) {
      logset = long(limits()(5));
      xlog = logset & 128;
      sx = shift(x,-1);
      sxl = array(double,nx+1);
      if( xlog ) {
         sx = sqrt(x*sx);
         sxl(1:nx) = sx;
         sxl(1) = sqrt(x(1)^3 / x(2));
         sxl(0) = sqrt(x(0)^3 / x(-1));
      } else {
         sx = 0.5*(x + sx);
         sxl(1:nx) = sx;
         sxl(1) = (3*x(1) - x(2))*0.5;
         sxl(0) = (3*x(0) - x(-1))*0.5;
      }
   }


   for( i = 1; i <= nx; i++ ) {
     //  horizontal pieces (only if requested)
     if( numberof(xbar) && nx > 1 ) oplot,sxl(i:i+1),[y(i),y(i)],color=color,thick=thick;
     // vertical pieces
     oplot,[x(i),x(i)],[y(i)-dy(i),y(i)+dy(i)],color=color,thick=thick;
   }

   // Plot fixed horizontal piece if requested;

   if( !is_void(fxbar) ) {
      for( i = 1; i<= nx; i++ ) {
         oplot,[x(i)-fxbar,x(i)+fxbar],[y(i),y(i)],color=color,thick=thick;
      }
   }

   if( !is_void(ps) ) oplot,x,y,ps=ps,color=color,thick=thick;

}

/* Function dataplotf */

func dataplotf( x1,x,x2,y1,y,y2, xr=, yr=, ps=, mpl=, itype=, color=, thick=, \
         xtitle=, ytitle=, title=, titleheight=, xytitleheight=, xyadjust=, titlefont= )
/* DOCUMENT dataplotf, x1,x,x2,y1,y,y2, xr=, yr=, ps=, mpl=, itype=, color=, thick=,
         xtitle=, ytitle=, title=, titleheight=, xytitleheight=, xyadjust=, titlefont=

   Lin-lin plot of datapoints with 'errorbars' in x-direction defined
   by start and stop arrays x1 and x2. Similarly
   in the y-direction the length of the error bars are given by
   lower and upper values y1 and y2

   The type of plot is indicated with the keyword 'itype'
     itype = 0  :    x lin - y lin (default)
     itype = 1  :    x lin - y log
     itype = 2  :    x log - y lin
     itype = 3  :    x log - y log

  SEE ALSO: dataplot

*/
{
   if( is_void(y2) ) {
      write,"dataplotf, x1, x, x2, y1, y, y2[,keywords]";
      return;
   }
   nx = numberof(x);
   nx1 = numberof(x1);
   nx2 = numberof(x2);
   ny = numberof(y);
   ny1 = numberof(y1);
   ny2 = numberof(y2);

   // Check out of input;

   if( (nx != nx1) || (nx != nx2) || (nx != ny) || (nx != ny1) || (nx != ny2) ) {
     write,"DATAPLOTF error: The arrays have different dimensions !";
     return;
   }

   // Set plot type

   if( is_void(itype) ) itype = 0;
   xlog = (itype > 1);
   ylog = itype % 2;

   iypos = where( y1 > 0 );
   n_iypos = numberof(iypos);

   if( is_void(xr) ) {
      if( xlog ) {
         xmin = min(x1)^1.05 / max(x2)^0.05;
         xmax = max(x2)^1.05 / min(x1)^0.05;
      } else {
         xmin = min(x1) - 0.05 * (max(x2) - min(x1));
         xmax = max(x2) + 0.05 * (max(x2) - min(x1));
      }
      xr = [xmin,xmax];
   }
   if( is_void(yr) ) {;
      if( ylog ) {
         if( n_iypos > 0 ) {
            ymin = min(y1(iypos))^1.05 / max(y2)^0.05;
            ymax = max(y2)^1.05 / min(y1(iypos))^0.05;
         } else {
            ymax = 1.3 * max(y2);
            ymin = 0.001 * ymax;
         }
      } else {
         ymin = min(y1) - 0.05 * (max(y2) - min(y1));
         ymax = max(y2) + 0.05 * (max(y2) - min(y1));
      }
      yr = [ymin,ymax];
   }

   // Set up plot;

   plot,[1],[1],xr=xr,yr=yr, mpl=mpl, itype=itype, xtitle=xtitle, \
           ytitle=ytitle, title=title, titleheight=titleheight, \
           xyadjust=xyadjust, xytitleheight=xytitleheight, titlefont=titlefont;
   // dbg
   if( dbg ) write,format="DATAPLOTF: After call of plot - plsys = %i\n", plsys();
   if( numberof(mpl) ) plsys, mpl;
   if( dbg ) write,format="DATAPLOTF: After call of plsys - plsys = %i\n", plsys();

   // Do the plotting;

   for( i = 1; i <= nx; i++)  {
      oplot,[x1(i),x2(i)],[y(i),y(i)],color=color,thick=thick;
      oplot,[x(i),x(i)],[y1(i),y2(i)],color=color,thick=thick;
      if( numberof(ps) ) oplot,[x(i)],[y(i)],ps=ps,color=color,thick=thick;
   }
}



/* Function odataplotf */

func odataplotf( x1,x,x2,y1,y,y2, ps=, color=, thick= )
/* DOCUMENT odataplotf, x1,x,x2,y1,y,y2, ps=, color=, thick=

   Plot of datapoints with 'errorbars' in x-direction defined
   by start and stop arrays x1 and x2. Similarly
   in the y-direction the length of the error bars are given by
   lower and upper values y1 and y2

   2008-02-01/NJW cloned from dataplotf

*/
{
   if( is_void(y2) ) {
      write,"Syntax: odataplotf, x1, x, x2, y1, y, y2[,keywords]";
      return;
   }
   nx = numberof(x);
   nx1 = numberof(x1);
   nx2 = numberof(x2);
   ny = numberof(y);
   ny1 = numberof(y1);
   ny2 = numberof(y2);

   // Check out of input;

   if( (nx != nx1) || (nx != nx2) || (nx != ny) || (nx != ny1) || (nx != ny2) ) {
     write,"DATAPLOTF error: The arrays have different dimensions !";
     return;
   }


   iypos = where( y1 > 0 );
   n_iypos = numberof(iypos);

   // Do the plotting;

   for( i = 1; i <= nx; i++)  {
     oplot,[x1(i),x2(i)],[y(i),y(i)],color=color,thick=thick;
     oplot,[x(i),x(i)],[y1(i),y2(i)],color=color,thick=thick;
     if( numberof(ps) ) oplot,[x(i)],[y(i)],ps=ps,color=color,thick=thick;
   }
}


/* Function plotsign */

func plotsign( pos= )
/* DOCUMENT plotsign[, pos=]
   Prints the string NSI/DTU/YYYY-MM-DD/NJW in the upper right
   corner of the plot.

   Keyword 'pos' will override the standard position in NDC (two elements).

   2006-11-17/NJW, updated 2011-10-19/NJW
*/
{
   if( numberof(pos) == 2 ) {
      plt,"NSI/DTU/"+ndate(2)+"/NJW",pos(1),pos(2),justify="RA",height=8;
   } else {
      port = viewport();
      plt,"NSI/DTU/"+ndate(2)+"/NJW",port(2),port(4)+0.01,justify="RA",height=8;
   }
}

/* Function plotdate */

func plotdate(pos=)
/* DOCUMENT plotdate[,pos=]
   Prints the string YYYY-MM-DD in the upper right
   corner of the plot.
   2011-05-27/NJW
*/
{
   if( numberof(pos) == 2 ) {
      plt,ndate(2),pos(1),pos(2),justify="RA",height=8;
   } else {
      port = viewport();
      plt,ndate(2),port(2),port(4)+0.01,justify="RA",height=8;
   }
}

/* Function esc_uscore */

func esc_uscore( strng )
/* DOCUMENT new_strng = esc_uscore( strng )

   "Escape underscore" which means remove special significance
   of the underscore character in a text string to be written
   in a plot e.g. by 'plt' or 'xyouts'
   2007-10-31/NJW
*/
{
   // Identify the occurrences of '_'
   newstring = strng;
   spos = 1;
   pos = strpos(strng,"_",1);
   if( pos > 0 ) {
      newstring = "";
      while( pos > 0 ) {
         if( pos == 1 ) {
            newstring += "!_";
         } else {
            newstring += strpart(strng,spos:pos-1)+"!_";
         }
         spos = pos + 1;
         pos = strpos(strng,"_",spos);
      }
      newstring += strpart(strng,spos:0);
   }

   return newstring;

}

/* Function plotname */

func plotname(name)
/* DOCUMENT plotname, name
   Prints the string 'name' in the upper left
   corner of the plot. The underscore character is kept. i.e. its
   special meaning for formatting (starting subscript) is lost here.
   2006-11-17/NJW
*/
{
   // Use function esc_underscore to eliminate unexpected consequences
   // of '_'
   port = viewport();
   plt,esc_underscore(name),port(1),port(4)+0.005,justify="LA",height=8;
}

/* Function plotcommments */

func plotcomments( a, file=, str=, init=, keep= )
/* DOCUMENT plotcomments, file=, str=, init=, keep=

   Prints the string array (given with keyword 'str')
   or the contents of a textfile (given with keyword 'file')
   below the plot. This is meant for a standard plot on A4 paper
   in portrait orientation.

   Keyword 'init' 1 : Reset y-position of text to just below viewport
                 double: y-position of text in normalized coordinates

   Keyword 'keep' will keep the formatting symbols (like '^', '_', and '!')
                  in the text string

   The external PLOTCOMMENTS_YLEV keeps track of the line positions for each
           of the 8 possible windows

   2006-11-17/NJW
   2010-05-10/NJW, updated with new init keyword
*/
{

   extern PLOTCOMMENTS_YLEV; // array with 8 elements, one for each
                             // possible window

   if( !is_void(file) ) {
      if( !file_test(file) ) {
         write,format="%s does not exist\n", file;
         return;
      }
      text = read_slist( file );
   }
   if( !is_void(str) ) text = str;

   if( is_void(text) && is_void(init) ) {
      write,"PLOTCOMMENTS: Text info is missing, skip ...";
      return;
   }

   if( !is_void(text) ) {
      if( keep ) {
         line = strjoin( text, "\n" );
      } else {
         line = strjoin( esc_underscore(text), "\n" );
      }
   }

   win_idx = window() + 1;
   port = viewport();
   dy = port(4)-port(3);

   if( is_void(init) ) init = 0;
   if( typeof(init) == "double" ) {
      y_ndc = init;
   } else {
      y_ndc = port(3) - 0.1;
   }

  /*
   *   PLOTCOMMENTS_YLEV is an array with the y-position of
   *   where to place the next line
   */

   if( is_void(PLOTCOMMENTS_YLEV) ) {
      PLOTCOMMENTS_YLEV = array(port(3) - 0.1, 8);
   }
   if( init ) {
      PLOTCOMMENTS_YLEV(win_idx) = y_ndc;
   }
//    plt handles new-lines (line shifts) by itself
   if( !is_void(text) ) {
      plt, line, port(1), PLOTCOMMENTS_YLEV(win_idx), height=10,justify="LT";

//  update for next call of plotcomments:

      PLOTCOMMENTS_YLEV(win_idx) -= 0.015*numberof(text);
   }
}


/* Function zps */

func zps( &filename, outfile=, pr=, noc=, gv= )
/* DOCUMENT zps, >filename, outfile=, pr=, noc=, gv=
   Dump plot to next hard copy file from pattern yplot_????.ps
   unless keyword 'outfile' is given.

   Keyword 'pr' will send plot to a develop printer with this number.
   Keyword 'noc' will prevent name listing in plot file. noc=1 is the
                 default setting.
   Keyword 'gv' will cause a ghostview display of the plotfile.

   2006-06-13/NJW
*/
{
   require, "basic.i";

   if( typeof(outfile) == "string" ) {
      filename = outfile;
   } else {
      filename = get_next_filename("yplot_????.ps",dir=".");
   }
   write,format="New plot file name: %s\n", filename;
   if( is_void(noc) ) noc = 1; // setting default
   if(noc) {
      plotcomments,init=1;
   } else {
      plotcomments,str=swrite(format="This plotfile is %s", fullpath(filename));
   }
   hcp_file, filename;
   hcp;
   hcp_finish;
   if( is_void(pr) ) pr = 0;
   if( nallof(pr - [1,2,3]) ) {
      system,"lpr -Pdevelop"+itoa(pr)+" "+filename;
      write,"Has executed lpr -Pdevelop"+itoa(pr)+" "+filename;
   }
   if( gv ) system,"gv "+filename;
}

/* Function def_sym */

func def_sym( sym_number )
/* DOCUMENT def_sym, sym_number

   where 'sym_number' must be larger than 10.
   Sets the user defined plot symbols.

   11 - Cross       15 - Backslash         19 - Square
   12 - Plus        16 - Empty plus        20 - Triangle on bottom
   13 - Circle      17 - Horizontal line   21 - Triangle on tip
   14 - Slash       18 - Vertical line     22 - Star 5
   23 - Star 6      24 - Star 7            25 - Star 8
   26 - Star 9      27 - Diamond

   2008-08-07/NJW, updated 2010-10-05/NJW
*/
{
   extern Def_sym_size_x, Def_sym_size_y, Def_sym_number, Def_sym_x, Def_sym_y;

   if( is_void(sym_number) ) sym_number = 0;
   if( sym_number < 11 || sym_number > 27 ) {
      write,"DEF_SYM argument out of limits";
      return [];
   }

   dx = Def_sym_size_x/2;
   dy = Def_sym_size_y/2;

   staro = 1.1;
   stari = 0.5;
   if( sym_number == 11 ) { // Cross
      Def_sym_x = dx*0.707*[[-1,1],[-1,1]];
      Def_sym_y = dy*0.707*[[-1,1],[1,-1]];
   } else if( sym_number == 12 ) { // Plus
      Def_sym_x = dx*[[-1,1],[0,0]];
      Def_sym_y = dy*[[0,0],[1,-1]];
   } else if( sym_number == 13 ) { // Circle
      v = span(0,2*pi,50);
      Def_sym_x = dx*cos(v);
      Def_sym_y = dy*sin(v);
   } else if( sym_number == 14 ) { // Slash
      Def_sym_x = dx*0.707*[-1,1];
      Def_sym_y = dy*0.707*[-1,1];
   } else if( sym_number == 15 ) { // Backslash
      Def_sym_x = dx*0.707*[-1,1];
      Def_sym_y = dy*0.707*[1,-1];
   } else if( sym_number == 16 ) { // Empty plus
      Def_sym_x = dx*[[-1,-0.5],[0.5,1],[0,0],[0,0]];
      Def_sym_y = dy*[[0,0],[0,0],[-1,-0.5],[0.5,1]];
   } else if( sym_number == 17 ) { // Horizontal line
      Def_sym_x = dx*[-1,1];
      Def_sym_y = dy*[0,0];
   } else if( sym_number == 18 ) { // Vertical line
      Def_sym_x = dx*[0,0];
      Def_sym_y = dy*[-1,1];
   } else if( sym_number == 19 ) { // Square
      Def_sym_x = dx*[-1,1,1,-1,-1];
      Def_sym_y = dy*[-1,-1,1,1,-1];
   } else if( sym_number == 20 ) { // Triangle on bottom
      Def_sym_x = dx*[-0.866,0.866,0,-0.866];
      Def_sym_y = dy*[-0.5,-0.5,1,-0.5];
   } else if( sym_number == 21 ) { // Triangle on tip
      Def_sym_x = dx*[-0.866,0.866,0,-0.866];
      Def_sym_y = dy*[0.5,0.5,-1,0.5];
   } else if( sym_number >= 22 && sym_number <= 26 ) { // Five - to nine fold stars
      n = sym_number - 17;
      v = span(0,2*pi,n+1);
      Def_sym_x = array(double,2*n+1);
      Def_sym_y = array(double,2*n+1);
      Def_sym_x(1:2*n+1:2) = -staro*dx*sin(v);
      Def_sym_y(1:2*n+1:2) =  staro*dy*cos(v);
      Def_sym_x(2:2*n:2) = -stari*dx*sin(v(zcen));
      Def_sym_y(2:2*n:2) =  stari*dy*cos(v(zcen));
   } else if( sym_number == 27 ) { // Diamond
      Def_sym_x = dx*[-1,0,1,0,-1];
      Def_sym_y = dy*[0,1,0,-1,0];
   }

   Def_sym_number = sym_number;

}

/* Function mlogxy */

func mlogxy( &xflag, &yflag, mpl=, win=, get=, dbg= )
/* DOCUMENT mlogxy, (>)xflag, (>)yflag, mpl=, win=, get=, dbg=

   Same functionality as 'logxy' except that the external variables
   Logxy_flags_content and Logxy_flags_values are updated.
   When keyword 'get' is set then the values are returned in stead.

   Logxy_flags_content = mpl*10 + win

   If none of these keywords are given then the current values will
   be used.

   Log_flags_values is like 'itype': 0,1,2,3 for lin-lin, lin-log, log-lin, log-log

   2008-08-08/NJW
   2011-06-14/NJW updated to include the plsys functionality
*/
{
   //+ extern Log_flags_x, Log_flags_y;
   extern Logxy_flags_content, Logxy_flags_values;

   if( is_void(win) ) win = window();
   if( is_void(mpl) ) {
      mpl = plsys();
   } else {
      plsys,mpl;
   }
   if( dbg ) write,format="MLOGXY ##17## win = %i, mpl = %i\n", win, mpl;

   reference = 10*mpl + win;

   if( get ) { // Retrieve values

      if( is_void( Logxy_flags_content ) ) {
         xflag = 0;
         yflag = 0;
      } else {
         // Look for reference
         w = where( reference == Logxy_flags_content );
         if( numberof(w) ) { // It was indeed found
            xflag = Logxy_flags_values(w(1))/2;
            yflag = Logxy_flags_values(w(1))%2;
         } else { // Not found, not defined in this session
            xflag = 0;
            yflag = 0;
         }
      }

   } else {    // Store values and define plotting

      if( is_void(xflag) || is_void(yflag) ) error,"MLOGXY: missing argument(s)";
      value = 2*xflag + yflag;
      if( is_void(Logxy_flags_content) ) {
         grow, Logxy_flags_content, reference;
         grow, Logxy_flags_values, value;
      } else {
         // Look if reference already exists
         w = where( reference == Logxy_flags_content );
         if( numberof(w) ) { // It was indeed found
            Logxy_flags_values(w(1)) = value;
         } else { // not found, add to list
            grow, Logxy_flags_content, reference;
            grow, Logxy_flags_values, value;
         }
      }
      logxy, xflag, yflag;

   }

}

/* Function mcoord_conv */

func mcoord_conv( p_in, q_in, &p_out, &q_out, from=, to= )
/* DOCUMENT mcoord_conv, p_in, q_in, >p_out, >q_out, from=, to=

   Convert coordinates between NDC (Normalized Device Coordinates)
   keyword value "ndc", virtual coordinates (keyword value "vir")
   and world (i.e. data space) (keyword value "wor") coordinates.
   The (A4) device coordinates have been expanded by a factor of
   sqrt(2) in the y direction compared to NDC. [not implemented]

   2008-08-13/NJW
*/
{
   if( is_void(from) ) {
      write,"Keyword 'from' not defined";
      return;
   }
   if( is_void(to) ) {
      write,"Keyword 'to' not defined";
      return;
   }
   v = viewport()(1:4);
   w = limits()(1:4);
   wind = 1 + window();
   local xlog, ylog;
   mlogxy, xlog, ylog,get=1;

   from = strlowcase(from);
   to = strlowcase(to);
   if( from == "ndc" ) fco = v;
   if( from == "vir" ) fco = [0.,1.,0.,1.];
   if( from == "wor" ) fco = w;
   if( to == "ndc" ) tco = v;
   if( to == "vir" ) tco = [0.,1.,0.,1.];
   if( to == "wor" ) tco = w;

   if( from == "wor" ) {
      // World to linear
      if( xlog ) {
         fco(1) = log(fco(1));
         fco(2) = log(fco(2));
         p_in = log(p_in);
      }
      if( ylog ) {
         fco(3) = log(fco(3));
         fco(4) = log(fco(4));
         q_in = log(q_in);
      }
   }
   if( to == "wor" ) {
      // linear to world
      if( xlog ) {
         tco(1) = log(tco(1));
         tco(2) = log(tco(2));
      }
      if( ylog ) {
         tco(3) = log(tco(3));
         tco(4) = log(tco(4));
      }
   }
   fac = (p_in - fco(1))/(fco(2)-fco(1));
   p_out = tco(1) + fac*(tco(2) - tco(1));
   fac = (q_in - fco(3))/(fco(4) - fco(3));
   q_out = tco(3) + fac*(tco(4) - tco(3));

   if( to == "wor" ) {
      if( xlog ) p_out = exp(p_out);
      if( ylog ) q_out = exp(q_out);
   }

   return;
}

/* Function plot_spectrum */

func plot_spectrum( eb1, eb2, rate, rate_err, perkev=, itype=, \
                    xr=, yr=, color=, title=, ytitle= )
/* DOCUMENT plot_spectrum, eb1, eb2, rate, rate_err, perkev=, \
                    itype=, xr=, yr=, color=, title=, ytitle=

  Plot one or more spectra as cnt/keV/s

  eb1 : lower energy boundaries
  eb2 : upper energy boundaries
  rate : counts per channel per s
  rate_err : error in counts per channel per s

  Several spectra can be given dimensions are: (nchan, nspectra)

  Keywords:   perkev     set if rate and error are given as /keV/s

              itype      0 : lin-lin
                         1 : log-lin
                         2 : lin-log
                         3 : log-log

     The remaining keywords are as for 'plot'.

   2008-02-01/NJW translated to Yorick from IDL
*/
{

   sz = dimsof(rate);
   sze = dimsof(rate_err);
   if( sz(1) != 1 && sz(1) != 2 ) {
      write,"PLOT_SPECTRUM: The spectral array has bad dimensions";
      return [];
   }

   if( sz(1) != sze(1) ) {
      write,"PLOT_SPECTRUM: Mismatch of dimensions in rate and rate_err arrays";
      return [];
   }
   if( anyof(sz-sze) ) {
      write,"PLOT_SPECTRUM: Mismatch of dimensions in rate and rate_err arrays";
      return [];
   }


   if( numberof(eb1) != numberof(eb2) ) {
      write,"The channel boundary arrays have different number of elements";
      return [];
   }

   nchan = sz(2);
   nspec = sz(1) == 2 ? sz(3) : 1;

   if( numberof(eb1) != nchan ) {
      write,"The number of channel boundaries does not match spectral array";
      return [];
   }

   if( ! perkev ) {
      spec = rate / (eb2 - eb1)(,-);
      erra = rate_err / (eb2 - eb1)(,-);
   }

   ymax = 1.05*max(spec+erra);
   aux = spec - erra;
   ymin = 0.95*min(aux(where(aux > 0)));

   xtitle = "Energy [keV]";
   if( is_void(ytitle) ) ytitle = "Counts [/keV/s]";

   eb = eb1(1) <=  0.0 ? 0.5*(eb1 + eb2) : sqrt(eb1*eb2);

   if( ! numberof(xr) ) xr=[0.95*min(eb1),1.05*max(eb2)];
   if( ! numberof(yr) ) yr=[ymin,ymax];
   plot,[1],[1],xr=xr,yr=yr,itype=itype,title=title, xtitle=xtitle,ytitle=ytitle;

   for( i = 1; i <= nspec; i++ ) {

      y1 = spec(,i) - erra(,i);
      y2 = spec(,i) + erra(,i);
      y = spec(,i);

      odataplotf,eb1,eb,eb2,y1,y,y2,color=color;

   }

   //+ plotsign;
   //+ plotname,"plot_spectrum";
}

/* Function oplot_spectrum */

func oplot_spectrum( eb1, eb2, rate, rate_err, perkev=, color= )
/* DOCUMENT oplot_spectrum, eb1, eb2, rate, rate_err, perkev=, color=

   Plot one or more spectra as cnt/keV/s

  eb1 : lower energy boundaries
  eb2 : upper energy boundaries
  rate : counts per channel per s
  rate_err : error in counts per channel per s

  Several spectra can be given dimensions are: (nchan, nspectra)

  Keywords:   perkev     set if rate and error are given as /keV/s


   2008-02-01/NJW cloned from plot_spectrum
*/
{

   sz = dimsof(rate);
   sze = dimsof(rate_err);
   if( sz(1) != 1 && sz(1) != 2 ) {
      write,"OPLOT_SPECTRUM: The spectral array has bad dimensions";
      return [];
   }

   if( sz(1) != sze(1) ) {
      write,"OPLOT_SPECTRUM: Mismatch of dimensions in rate and rate_err arrays";
      return [];
   }
   if( anyof(sz-sze) ) {
      write,"OPLOT_SPECTRUM: Mismatch of dimensions in rate and rate_err arrays";
      return [];
   }


   if( numberof(eb1) != numberof(eb2) ) {
      write,"The channel boundary arrays have different number of elements";
      return [];
   }

   nchan = sz(2);
   nspec = sz(1) == 2 ? sz(3) : 1;

   if( numberof(eb1) != nchan ) {
      write,"The number of channel boundaries does not match spectral array";
      return [];
   }

   //+ spec = rate;
   //+ erra = rate_err;
   if( ! perkev ) {
      //+ for( i = 1; i <= nspec; i++ ) {
      //+    spec(,i) = rate(,i) / (eb2 - eb1);
      //+    erra(,i) = rate_err(,i) / (eb2 - eb1);
      //+ }
      spec = rate / (eb2 - eb1)(,-);
      erra = rate_err / (eb2 - eb1)(,-);
   }

   eb = eb1(1) <=  0.0 ? 0.5*(eb1 + eb2) : sqrt(eb1*eb2);

   for( i = 1; i <= nspec; i++ ) {

      y1 = spec(,i) - erra(,i);
      y2 = spec(,i) + erra(,i);
      y = spec(,i);

      odataplotf,eb1,eb,eb2,y1,y,y2,color=color;

   }

   //+ plotsign;
   //+ plotname,"plot_spectrum";
}

/* Function mplot_setup */

func mplot_setup( dims, pane=, spacing=, vport=, hideticklabels=, \
                  vrelsize=, hrelsize=, ticklen= )
/* DOCUMENT mplot_setup, dims, pane=, spacing=, vport=, hideticklabels=, \
                  vrelsize=, hrelsize=, ticklen=

   Defines a mplot.gs file in /home/njw/yorick/yorick-2.1/g
   with 'dims'/10 rows of frames and 'dims'%10 columns.
   Order is row by row.

   Keywords:
      pane      window number. Default 0.

      spacing   Spacing between frames in NDC.
                If given as 2 element array then
                'spacing(1)' will be the row spacing and
                'spacing(2)' the column spacing
                Default spacing is 0.1.

      vport     The exterior frame defined as 'viewport' in NDC
                coordinates [xmin, xmax, ymin, ymax]
                Default: [0.1, 0.7, 0.1, 0.95]

      hideticklabels  Will eliminate ticklabels between frames.

      vrelsize  Array of vertical relative framesizes. Must have
                the same number of elements as the requested number
                of rows (dims/10).

      hrelsize  Array of horizontal relative framesizes. Must have
                the same number of elements as the requested number
                of columns (dims%10).

      ticklen   Resize the tickLen with this relative size as compared to
                default.

   Hint: The keyword 'mpl' for the plot command is used to decide where
         to plot.

   2009-11-02/NJW
*/
{

   if( is_void(pane) ) pane = 0;

   n_rows = dims/10;
   n_cols = dims%10;

   n_frames = n_rows*n_cols;

   // GISTDIR is an external variable defined when envoking Yorick
   gs = rdfile(GISTDIR+"mplot_tpl.gs");
   gs1 = gs(1:53);
   gs2 = gs(54:0);

   // -- Take care of tick lengths

   if( numberof(ticklen) ) {
      w = where( strmatch(gs1,"tickLen") );
      if( numberof(w) == 2 ) {
         for( i = 1; i <= 2; i++ ) {
            line = gs1(w(1));
            p1 = strpos( line, "{" );
            p2 = strpos( line, "}" );
            l1 = strpart(line,1:p1);
            l2 = strpart(line,p1+1:p2-1);
            l3 = strpart(line,p2:0);
            tok = strsplit( l2, "," );
            ftok = atof( tok ) * ticklen;
            for( j = 1; j <= numberof(tok); j++ ) {
               l1 = l1 + ftoa(ftok(j));
               if( j < numberof(tok) ) l1 = l1 + ", ";
            }
            l1 = l1 + l3;
            gs1(w(i)) = l1;
         }
      } else {
         write,"Warning, less than two tickLen definitions found in mplot_tpl.gs";
      }
   }

   // -- Take care of spacing

   if( is_void(spacing) ) {
      vspace = 0.1;
      hspace = 0.1;
   } else {
      if( numberof(spacing) > 1 ) {
         vspace = spacing(1);
         hspace = spacing(2);
      } else {
         hspace = vspace = spacing;
      }
   }

   if( is_void(vrelsize) ) {
      vrelsize = array(1.,n_rows);
   } else {
      if( numberof(vrelsize) != n_rows ) error,"Illegal dimension of vrelsize";
   }
   vrelsize /= sum(double(vrelsize));

   if( is_void(hrelsize) ) {
      hrelsize = array(1.,n_cols);
   } else {
      if( numberof(hrelsize) != n_cols ) error,"Illegal dimension of hrelsize";
   }
   hrelsize /= sum(double(hrelsize));

   if( is_void(vport) ) vport = [0.1, 0.7, 0.1, 0.95];

   // Make arrays with frame sizes in NDC
   vunit = (vport(4) - vport(3) - vspace*(n_rows-1)) * vrelsize;
   hunit = (vport(2) - vport(1) - hspace*(n_cols-1)) * hrelsize;

   // Define the systems row by row

   for( irow = 1; irow <= n_rows; irow++ ) {
      //+ vp4 = vport(4) - (irow-1)*vunit*(1+vspace);
      // calculating from top
      sum_vunit = irow == 1 ? 0.0 : sum(vunit(1:irow-1));
      vp4 = vport(4) - (irow-1)*vspace - sum_vunit;
      vp3 = vp4 - vunit(irow); 
      for( icol = 1; icol <= n_cols; icol++ ) {
         //+ vp1 = vport(1) + (icol-1)*hunit*(1+hspace);
         // calculating from left side
         sum_hunit = icol == 1 ? 0.0 : sum(hunit(1:icol-1));
         vp1 = vport(1) + (icol-1)*hspace + sum_hunit; 
         vp2 = vp1 + hunit(icol); 
         line = swrite(format="system={viewport={ %.4f, %.4f, %.4f, %.4f}", \
                  vp1, vp2, vp3, vp4);
         if( hideticklabels ) {
            if( irow == n_rows && icol == 1 ) {  // lower left frame -> no change
               line += "}";
            } else if( irow == n_rows && icol > 1 ) { // bottom frame, skip vert tick labels
               grow,line,"    ticks= {";
               grow,line,"    vert= {";
               grow,line,"    flags= 0x0b }}}";
            } else if( irow < n_rows && icol == 1 ) { // left frame, skip horiz tick labels
               grow,line,"    ticks= {";
               grow,line,"    horiz= {";
               grow,line,"    flags= 0x0b }}}";
            } else {                             // 'inner' frame, skip both tick labels
               grow,line,"    ticks= {";
               grow,line,"    horiz= {";
               grow,line,"    flags= 0x0b }";
               grow,line,"    vert= {";
               grow,line,"    flags= 0x0b }}}";
            }
         } else line += "}"; // Finish up line if all tick labels are wanted
         grow, gs1, line;
      }
   }

   grow, gs1, gs2;

   //+ prstrarr, gs1;

   write_slist,GISTDIR+"mplot.gs", gs1;

   window,pane,style=GISTDIR+"mplot.gs";

}

/* Function curtext */

struct s_Curtext {
   double xpos;
   double ypos;
   string text_string;
   double align;
   double charsize;
   string color;
   string font;
   string cosys;
}

func curtext( text_string, align=, charsize=, color=, font=, replay=, cosys= )
/* DOCUMENT curtext, text_string, align=, charsize=, color=, font=, replay=, cosys=

   Asks for a cursor input where to put the text in the
   textstring.

   Keywords as for 'xyouts'

   Previous input saved in external 'Curtext_arr' which is an array of
   the struct 's_Curtext' with elements: xpos, ypos, text_string, align, charsize, color, font.

   Keyword 'replay' will add Curtext_arr(replay) to the current plot.

   Keyword 'cosys' defines the coordinate system, "vir" for virtual, "wor" for world,
                   and "ndc" for normalized device coordinates. Default is "wor".

   SEE ALSO: curmark1

   2010-06-14/NJW
*/
{
   extern Curtext_arr;

   if( !is_void(replay) ) {
      n = numberof(Curtext_arr);
      if( replay > n ) error,"Plot text index out of range";
      if( replay == 0 ) {
         rep1 = 1;
         rep2 = n;
      } else { rep1 = rep2 = replay; }

      for( repl = rep1; repl <= rep2; repl++ ) {
         xpos = Curtext_arr(repl).xpos;
         ypos = Curtext_arr(repl).ypos;
         align = Curtext_arr(repl).align;
         charsize = Curtext_arr(repl).charsize;
         color = Curtext_arr(repl).color;
         font = Curtext_arr(repl).font;
         cosys = Curtext_arr(repl).cosys;
         align = align == -99.0 ? [] : align;
         charsize = charsize == -99.0 ? [] : charsize;
         font = font == "none" ? [] : font;
         vir = device = [];
         if( cosys == "vir" ) {
            vir = 1;
         } else if( cosys == "ndc" ) {
            device = 1;
         } 
         xyouts,xpos,ypos,Curtext_arr(repl).text_string,align=align, \
              charsize=charsize,color=color,font=font,device=device, vir=vir;
      }
   } else {
      pos = curmark1(style=0,prompt="Mark text position ...",nomark=1);
      s = s_Curtext();
      xyouts,pos(1),pos(2),text_string,align=align,charsize=charsize,color=color,font=font;
      s.xpos = pos(1); s.ypos = pos(2); s.text_string = text_string;
      align = is_void(align) ? -99.0 : align;
      s.align = align;
      charsize = is_void(charsize) ? -99.0 : charsize;
      s.charsize = charsize;
      color = is_void(color) ? "black" : color;
      s.color = color;
      font = is_void(font) ? "none" : font;
      s.font = font;
      cosys = is_void(cosys) ? "wor" : cosys;
      s.cosys = cosys;
      // Change coordinates is cosys is'nt 'wor'
      local q1, q2;
      if( cosys == "vir" ) {
         mcoord_conv, pos(1), pos(2), q1, q2, from="wor", to="vir";
         s.xpos = q1; s.ypos = q2;
      } else if( cosys == "ndc" ) {
         mcoord_conv, pos(1), pos(2), q1, q2, from="wor", to="ndc";
         s.xpos = q1; s.ypos = q2;
      }
      grow, Curtext_arr, s;
   }
}

/* Function wplot */

func wplot( lon, lat, pane=, ps=, symsize=, color= )
/* DOCUMENT wplot, lon, lat, ps=, symsize=, color=

   "World plot"

   Plot in Aitoff projection with longitude (lon) and
   latitude (lat) in degrees.

   Keywords: As for 'plot'

   2010-07-28/NJW, Copied from 'pointing_plot'
*/

{

   window,pane,style="nobox.gs";

   /*  Plot the grid */

   plot,[0],[0],xr=[180,-180],yr=1.4*[-90,90];

   /* longitude grid */

   b = span(-90,90,100);
   for( longi = -179.99; longi < 180.1; longi += 89.99 ) {
      l = array(0,100) + longi;
      xy = aitoff(l,b);
      listy = 2;
      if( longi < -179 || longi > 179 ) listy = 1;
      oplot,xy(1,),xy(2,),li=listy;
   }

   /* latitude grid */

   l = span(-179.999,180,100);
   for( lati = -60.; lati < 60.01; lati += 30. ) {
      b = array(0,100) + lati;
      xy = aitoff(l,b);
      oplot,xy(1,),xy(2,),li=2;
   }

   xy = aitoff(lon,lat);

   oplot, xy(1,), xy(2,), ps=ps, symsize=symsize, color=color;

}

/* Function owplot */

func owplot( lon, lat, pane=, ps=, symsize=, color= )
/* DOCUMENT owplot, lon, lat, ps=, symsize=, color=

   Overplot "World plot"

   Plot in Aitoff projection with longitude (lon) and
   latitude (lat) in degrees.

   Keywords: As for 'plot'

   2010-07-28/NJW, Copied from 'pointing_plot'
*/

{

   xy = aitoff(lon,lat);

   oplot, xy(1,), xy(2,), ps=ps, symsize=symsize, color=color;

}

/* Function poly_fill */

func poly_fill( x, y, cval )
/* DOCUMENT poly_fill, x, y, cval
    Fills the polygon defined by x and y with the color 'cval' from
    the current palette.

    SEE ALSO: poly_fillc
*/
{
   plfp, [1.], y, x, [numberof(y)], top=cval;
}

/* Function poly_fillc */

func poly_fillc( x, y, color= )
/* DOCUMENT poly_fillc, x, y, color=
    Fills the polygon defined by x and y with the color defined
    either as "red", "green", ..., or as a three element array.

    SEE ALSO: poly_fill
*/
{
   if( typeof(color) == "string" ) {
      if( color == "red" ) {
         color_arr = [255,0,0];
      } else if( color == "green" ) {
         color_arr = [0,255,0];
      } else if( color == "blue" ) {
         color_arr = [0,0,255];
      } else if( color == "cyan" ) {
         color_arr = [0,255,255];
      } else if( color == "magenta" ) {
         color_arr = [255,0,255];
      } else if( color == "yellow" ) {
         color_arr = [255,255,0];
      } else if( color == "black" ) {
         color_arr = [0,0,0];
      } else if( color == "white" ) {
         color_arr = [255,255,255];
      } else error,"Illegal color name";
   } else if( numberof(color) == 3 ) {
      color_arr = long(color);
   }
   z = char(color_arr)(,-);
   plfp, z, y, x, [numberof(y)];
}

/* Function plot_p2spec */

func plot_p2spec( spec_dol, spec_num, frac=, itype=, xr=, yr=, color=, title=, ytitle= )
/* DOCUMENT plot_p2spec, spec_dol, spec_num, frac=, itype=, xr=, yr=, color=, title=, ytitle=

  Plot one or more PHAII spectra as cnt/keV/s.
  If 'spec_num' is not given then the first spectrum is plotted.
  If 'spec_num' is zero than all spectra are plotted.
  'spec_num' may be an array with spectrum numbers.

  Several spectra can be given dimensions are: (nchan, nspectra)

  Each spectrum will be rebinned so that rate_err/rate < frac (defaults to 0.2)

  Keywords:   itype      0 : lin-lin
                         1 : log-lin
                         2 : lin-log
                         3 : log-log (default)

     The remaining keywords are as for 'plot'.

   SEE ALSO:  oplot_p2spec

   2010-11-23/NJW
*/
{
   local filename, extno;
   local ob1, ob2, orate, orate_err;

   if( is_void(frac) ) frac = 0.2;
   if( is_void(itype) ) itype = 3;

   get_exten_no, spec_dol, filename, extno;

   if( !file_test(filename) ) {
      write,"Did not find "+filename;
      return;
   }

   if( is_void(spec_num) ) spec_num = 1;

   hdr = headfits( spec_dol );
   nrows = fxpar( hdr, "naxis2" );
   if( spec_num == 0 ) spec_num = indgen(nrows); // for all spectra
   if( anyof(spec_num > nrows) ) {
      write,"You have requested a non-existing spectrum number";
      return;
   }
   nspec = numberof(spec_num);

   rate = rdfitscol( spec_dol, "rate" );
   rate_err = rdfitscol( spec_dol, "stat_err" );
   respfile = fxpar( hdr, "respfile" );

   // select the requested spectra

   rate = rate(,spec_num);
   rate_err = rate_err(,spec_num);

   if( !file_test(respfile) ) {
      write,"Did not find response file: "+respfile;
      return;
   }

   e_min = rdfitscol( respfile+"[EBOUNDS]", "e_min" );
   e_max = rdfitscol( respfile+"[EBOUNDS]", "e_max" );

   for( i = 1; i <= nspec; i++ ) {
      specrebinninga, e_min, e_max, rate(,i), rate_err(,i), frac, ob1, ob2, orate, orate_err;
      if( i == 1 ) {
         xmax = ob2(0);
         xmin = ob1(1);
         ymax = max( (orate+orate_err)/(ob2-ob1) );
         ymin = min( (orate-orate_err)/(ob2-ob1));
      } else {
         xmax = max( xmax, ob2(0) );
         xmin = min( xmin, ob1(1) );
         ymax = max( ymax, max((orate+orate_err)/(ob2-ob1)) );
         ymin = min( ymin, min((orate-orate_err)/(ob2-ob1)) );
      }
   }

   if( is_void(xr) ) {
      xr = [xmin/exp(0.05*log(xmax/xmin)),xmax*exp(0.05*log(xmax/xmin))];
   }
   if( is_void(yr) ) {
      yr = [ymin/exp(0.05*log(ymax/ymin)),ymax*exp(0.05*log(ymax/ymin))];
   }

   xtitle = "Energy [keV]";
   if( is_void(ytitle) ) ytitle = "Counts [/keV/s]";

   for( i = 1; i <= nspec; i++ ) {
      specrebinninga, e_min, e_max, rate(,i), rate_err(,i), frac, ob1, ob2, orate, orate_err;
      if( i == 1 ) {
         dataplotf, ob1, sqrt(ob1*ob2), ob2, (orate - orate_err)/(ob2-ob1), \
              orate/(ob2-ob1), (orate + orate_err)/(ob2-ob1), itype=itype, \
              xr=xr, yr=yr, xtitle=xtitle, ytitle=ytitle, color=color;
      } else {
         odataplotf, ob1, sqrt(ob1*ob2), ob2, (orate - orate_err)/(ob2-ob1), \
              orate/(ob2-ob1), (orate + orate_err)/(ob2-ob1), color=color;
      }
   }
}

/* Function oplot_p2spec */

func oplot_p2spec( spec_dol, spec_num, frac=, color= )
/* DOCUMENT oplot_p2spec, spec_dol, spec_num, frac=, color=

  Plot one or more PHAII spectra as cnt/keV/s.
  If 'spec_num' is not given then the first spectrum is plotted.
  If 'spec_num' is zero than all spectra are plotted.
  'spec_num' may be an array with spectrum numbers.

  Several spectra can be given, dimensions are: (nchan, nspectra)

  Each spectrum will be rebinned so that rate_err/rate < frac (defaults to 0.2)

     The remaining keywords are as for 'plot'.

   SEE ALSO:  plot_p2spec

   2010-11-23/NJW
*/
{
   local filename, extno;
   local ob1, ob2, orate, orate_err;

   if( is_void(frac) ) frac = 0.2;

   get_exten_no, spec_dol, filename, extno;

   if( !file_test(filename) ) {
      write,"Did not find "+filename;
      return;
   }

   if( is_void(spec_num) ) spec_num = 1;

   hdr = headfits( spec_dol );
   nrows = fxpar( hdr, "naxis2" );
   if( spec_num == 0 ) spec_num = indgen(nrows); // for all spectra
   if( anyof(spec_num > nrows) ) {
      write,"You have requested a non-existing spectrum number";
      return;
   }
   nspec = numberof(spec_num);

   rate = rdfitscol( spec_dol, "rate" );
   rate_err = rdfitscol( spec_dol, "stat_err" );
   respfile = fxpar( hdr, "respfile" );

   // select the requested spectra

   rate = rate(,spec_num);
   rate_err = rate_err(,spec_num);

   if( !file_test(respfile) ) {
      write,"Did not find response file: "+respfile;
      return;
   }

   e_min = rdfitscol( respfile+"[EBOUNDS]", "e_min" );
   e_max = rdfitscol( respfile+"[EBOUNDS]", "e_max" );

   for( i = 1; i <= nspec; i++ ) {
      specrebinninga, e_min, e_max, rate(,i), rate_err(,i), frac, ob1, ob2, orate, orate_err;
      odataplotf, ob1, sqrt(ob1*ob2), ob2, (orate - orate_err)/(ob2-ob1), \
              orate/(ob2-ob1), (orate + orate_err)/(ob2-ob1), color=color;
   }
}

/* Function qdp */

func qdp( name, x, y, dy, dy2, dx=, ps=, li=, symsize= )
/* DOCUMENT qdp, name, x, y[, dy, [dy2]], dx=, ps=, li=, symsize=

   writes a text file by name of <name>.qdp for interpretation by QDP

   2011-05-03/NJW
*/
{
   nx = numberof(x);
   ymode = "none";
   xmode = "none";
   if( numberof(dy) ) {
      if( numberof(dy) != nx ) error,"Non compliant number of elements in dy";
      ymode = "serr"; // symmetrical errors
   }
   if( numberof(dy2) ) {
      if( numberof(dy2) != nx ) error,"Non compliant number of elements in dy2";
      ymode = "terr"; // two-sided errors
   }
   if( numberof(y) != nx ) error,"Non compliant number of elements in y";
   if( numberof(dx) ) {
      if( numberof(dx) != nx ) error,"Non compliant number of elements in dx";
      xmode = "serr"; // symmetrical errors in x
   }

   if( typeof(name) != "string" ) error,"First argument must be a string";

   outfile = name+".qdp";
   f = open( outfile, "w" );
   write,f,format="cpd /%s\n", "xw"; // Change plot device command
   // plot symbols - markers in PLT parlance
   if( !is_void(ps) ) {
      if( ps < 0 ) {
         write,f,format="lines %s\n","on";
         ps = -ps;
      }
      if( ps == 10 ) {
         write,f,format="lines %s\n","step";
      } else write,f,format="marker %i on\n",ps;
   }
   if( xmode != "none" ) write,f,format="read %s 1\n", xmode; 
   if( ymode != "none" ) write,f,format="read %s 2\n", ymode; 

   for( i = 1; i <= nx; i++ ) {
      write,f,format="%15.6e", double(x(i));
      if( numberof(dx) ) write,f,format=" %15.6e", double(dx(i));
      write,f,format=" %15.6e", double(y(i));
      if( numberof(dy) ) write,f,format=" %15.6e", double(dy(i));
      if( numberof(dy2) ) write,f,format=" %15.6e", double(dy2(i));
      write,f,"";
   }

   close, f;

   write,outfile," has been written ...";

}

/* Function devicetitles */

func devicetitles( title, titpos, xtitle, xtitpos, ytitle, ytitpos, \
                   height=, font=, align=, color= )
/* DOCUMENT devicetitles, title, titpos, xtitle, xtitpos, ytitle, ytitpos, \
                   height=, font=, align=, color=

    Default titpos  : [0.4,0.9]
            xtitpos : [0.4,0.05]
            ytitpos : [0.05,0.5]

    Keywords: height   Face value for title, 2 smaller for xtitle and ytitle
              font, align, color
*/
{
   if( is_void(height) ) height = 16;
   if( is_void(font) ) font = "schoolbook";
   if( is_void(color) ) color = "black";
   if( is_void(align) ) {
      justify = "CA";
   } else {
     if( align < 0.25 ) {
        justify = "LA";
     } else if( align < 0.75 ) {
        justify = "CA";
     } else justify = "RA";
   }
   xheight = height - 2;
   
   if( !is_void(title) ) {
      if( structof(title) != string ) error,"'title' must be a string";
      if( is_void(titpos) ) {
         titpos = [0.4,0.9];
      } else {
         if( numberof(titpos) != 2 ) error,"'titpos' must have 2 elements";
      }
      plt,title,titpos(1),titpos(2),orient=0,height=height,font=font,justify=justify;
   }
   if( !is_void(xtitle) ) {
      if( structof(xtitle) != string ) error,"'xtitle' must be a string";
      if( is_void(xtitpos) ) {
         xtitpos = [0.4,0.05];
      } else {
         if( numberof(xtitpos) != 2 ) error,"'xtitpos' must have 2 elements";
      }
      plt,xtitle,xtitpos(1),xtitpos(2),orient=0,height=xheight,font=font,justify=justify;
   }
   if( !is_void(ytitle) ) {
      if( structof(ytitle) != string ) error,"'ytitle' must be a string";
      if( is_void(ytitpos) ) {
         ytitpos = [0.05,0.5];
      } else {
         if( numberof(ytitpos) != 2 ) error,"'ytitpos' must have 2 elements";
      }
      plt,ytitle,ytitpos(1),ytitpos(2),orient=1,height=xheight,font=font,justify=justify;
   }
}

/* Function xyouts */

func xyouts( x, y, text, align=, charsize=, ndc=, vir=, color=, font= )
/* DOCUMENT xyouts, x, y, text, align=, charsize=, ndc=, vir=, color=, font=

   Write text in plot. 'align' can be 0, 0.5, or 1.0.
   If keyword 'ndc' is set to 1 then x,y will be considered
   to be "ndc" coordinates.
   If keyword 'vir' is set to 1 then virtual coordinates (0 - 1) are used.

*/

{
   local xnew, ynew;

   csz = 1.;
   tosys = numberof(ndc) ? [] : 1;
   if( numberof(charsize) ) csz = charsize;
   // Keyword 'vir' will override 'ndc'
   if( vir ) {
      mcoord_conv, x, y, xnew, ynew, from="vir", to="wor";
      x = xnew;
      y = ynew;
      tosys = 1;
   }
   if( numberof(align) ) {
      if( align < 0.25 ) {
         plt, text, x, y, tosys=tosys, justify="LA",height=14.*csz, \
                  color=color, font=font;
      } else if( align >= 0.25 && align < 0.75 ) {
         plt, text, x, y, tosys=tosys, justify="CA",height=14.*csz, \
                  color=color, font=font;
      } else {
         plt, text, x, y, tosys=tosys, justify="RA",height=14.*csz, \
                  color=color, font=font;
      }
   } else {
      plt, text, x, y, tosys=tosys,height=14.*csz, \
                  color=color, font=font;
   }

}

/* Function curve_edit */

func curve_edit( x, y, &newx, &newy, aux=, step=, itype=, xr=, yr= )
/* DOCUMENT curve_edit, x, y, >newx, >newy, aux=, step=, itype=, xr=, yr=

     When points are entered with the cursor, no change will happen
     outside min x and max x. Between these the returned curve will be
     linearly interpolated to match the new y-values.

     The pointed-to x values will stick to the nearest existing x value.

     Always returns arrays of type double.

     The 'aux' keyword gives the option of showing an addition curve
     e.g. as a guide. Must have same dimension as x and y.
*/
{
   if( is_void(step) ) step = 1;
   if( is_void(itype) ) itype = 0;

   plot,x,y,xr=xr,yr=yr,itype=itype;
   oplot,x,y,ps=2;
   if( numberof(aux) ) oplot,x,aux,li=2;

   newx = double(x);
   newy = double(y);

   pts = curmark();
   npts = numberof(pts);
   xpts = pts(1:npts:2);
   ypts = pts(2:npts:2);
   npts /= 2;

   is = sort(xpts);
   xpts = xpts(is);
   ypts = ypts(is);

   for( i = 1; i <= npts; i++ ) xpts(i) = newx(abs(xpts(i)-newx)(mnx));
   // avoid duplicate xpts
   newxpts = xpts(1);
   for( i = 2; i <= npts; i++ ) {
      if( xpts(i-1) == xpts(i) ) { // average y value
         if( itype%2 == 1 ) {
            ypts(i-1) = sqrt(ypts(i-1)*ypts(i));
         } else {
            ypts(i-1) = 0.5*(ypts(i-1) + ypts(i));
         }
      } else {
         grow, newxpts, xpts(i);
      }
   }
   npts = numberof(newxpts);
   xpts = newxpts;
   ypts = ypts(1:npts);

   oplot,xpts,ypts,ps=3,color="blue";
   i1 = where( xpts(1) == newx )(1);
   i2 = where( xpts(0) == newx )(1);
   ir = indgen(i1:i2);
   newy(ir) = interp(ypts,xpts,newx(ir));

   oplot, newx, newy, color="red";

}

/* Function add_vgraph */

func add_vgraph( im, ampl=, ia=, ixr=, wxr=, color=, zero= )
/* DOCUMENT add_vgraph, im, ampl=, ia=, ixr=, wxr=, color=, zero=

    Adds a vertical histogram of image values summed
    in the range ixr(1) thru ixr(2) in image dimensions.
    Alternative the range can be set in the world coordinates
    by using 'wxr'.
    In stead the cursor can be used to set the span by setting
    keyword 'ia' in which case you'll be asked to use the mouse
    to define the range.
    If 'ixr' ('wxr') has only a single value im(ixr,) will be plotted.

    The amplitude (in world coordinate) is set by keyword 'ampl',
    that defaults to the middle of the x-range.

    Keyword 'zero' will show the histogram from zero, otherwise it
    is shown from the minimum value.

    Typically this function is used following a 'disp,im' command.

   2012-05-03/NJW
*/
{
   // Check for conflict
   if( !ia && (numberof(ixr) && numberof(wxr)) ) error,"xr conflict!";

   dms = dimsof(im);

   // get the current limits for the plot

   lims = limits(); // [xmin,xmax,ymin,ymax]

   //  x(world) * a + b = ix(image)
   a = b = array(double,2);
   a(1) = (dms(2) - 1) / (lims(2) - lims(1));
   b(1) = 1 - lims(1)*a(1);
   a(2) = (dms(3) - 1) / (lims(4) - lims(3));
   b(2) = 1 - lims(3)*a(2);

   if( is_void(ampl) ) ampl = (lims(1) + lims(2))/2;

   // see if 'wxr' has been set and - if so - derive 'ixr'
   if( numberof(wxr) ) {
      wxr = double(wxr);
      if( numberof(wxr) == 1 ) wxr = [wxr,wxr];
      ixr = long(wxr*a(1) + b(1) + 0.5);
   }
   // 'ixr' may also be set directly
   if( is_void(ixr) ) ixr = [1,dms(2)];
   ixr = long(ixr + 0.5);
   if( numberof(ixr) == 1 ) ixr = [ixr,ixr];

   if( ia ) {
      s = curmark1();
      ixr1 = long(s(1)*a(1)+b(1)+0.5);
      s = curmark1();
      ixr2 = long(s(1)*a(1)+b(1)+0.5);
      if( ixr1 > ixr2 ) { ix = ixr1; ixr1 = ixr2; ixr2 = ix; }
      ixr = [ixr1, ixr2];
   }
   x = (indgen(dms(3))-b(2))/a(2);
   q = im(ixr(1):ixr(2),);
   y = q(sum,);
   local plin, qlin;
   miny = zero ? 0.0 : min(y);
   linscale, miny, max(y), lims(1), ampl, plin, qlin;
   plhisv,y*plin+qlin,x,color=color,marks=0;
}

/* Function add_hgraph */

func add_hgraph( im, ampl=, ia=, ixr=, wxr=, color=, zero= )
/* DOCUMENT add_hgraph, im, ampl=, ia=, ixr=, wxr=, color=, zero=

    Adds a hirizontal histogram of image values summed
    in the range ixr(1) thru ixr(2) in image dimensions.
    Alternative the range can be set in the world coordinates
    by using 'wxr'.
    In stead the cursor can be used to set the span by setting
    keyword 'ia' in which case you'll be asked to use the mouse
    to define the range.
    If 'ixr' ('wxr') has only a single value im(,ixr) will be plotted.

    The amplitude (in world coordinate) is set by keyword 'ampl',
    that defaults to the middle of the x-range.

    Keyword 'zero' will show the histogram from zero, otherwise it
    is shown from the minimum value.

    Typically this function is used following a 'disp,im' command.

   2012-05-03/NJW
*/
{
   // Check for conflict
   if( !ia && (numberof(ixr) && numberof(wxr)) ) error,"xr conflict!";

   dms = dimsof(im);

   // get the current limits for the plot

   lims = limits(); // [xmin,xmax,ymin,ymax]

   //  x(world) * a + b = ix(image)
   a = b = array(double,2);
   a(1) = (dms(2) - 1) / (lims(2) - lims(1));
   b(1) = 1 - lims(1)*a(1);
   a(2) = (dms(3) - 1) / (lims(4) - lims(3));
   b(2) = 1 - lims(3)*a(2);

   if( is_void(ampl) ) ampl = (lims(3) + lims(4))/2;

   // see if 'wxr' has been set and - if so - derive 'ixr'
   if( numberof(wxr) ) {
      wxr = double(wxr);
      if( numberof(wxr) == 1 ) wxr = [wxr,wxr];
      ixr = long(wxr*a(2) + b(2) + 0.5);
   }
   // 'ixr' may also be set directly
   if( is_void(ixr) ) ixr = [1,dms(3)];
   ixr = long(ixr + 0.5);
   if( numberof(ixr) == 1 ) ixr = [ixr,ixr];

   if( ia ) {
      s = curmark1();
      ixr1 = long(s(2)*a(2)+b(2)+0.5);
      s = curmark1();
      ixr2 = long(s(2)*a(2)+b(2)+0.5);
      if( ixr1 > ixr2 ) { ix = ixr1; ixr1 = ixr2; ixr2 = ix; }
      ixr = [ixr1, ixr2];
   }
   x = (indgen(dms(2))-b(1))/a(1);
   q = im(,ixr(1):ixr(2));
   y = q(,sum);
   local plin, qlin;
   miny = zero ? 0. : min(y);
   linscale, miny, max(y), lims(3), ampl, plin, qlin;
   plhis,y*plin+qlin,x,color=color,marks=0;
}

/* Function resolve_color */

func resolve_color( strcolor )
/* DOCUMENT int_color = resolve_color( strcolor )

    Returns 3-element long array for the color representation
    given by a string value.

*/
{
   if( typeof(strcolor) != "string" ) return strcolor; // NoOp if not a string

   n = numberof(strcolor);
   res = array(long,3,n);
   for( i = 1; i <= n; i++ ) {
      res(,i) = [0,0,0]; // black is default
      if( strcolor(i) == "white" ) res(,i) = [255,255,255];
      if( strcolor(i) == "red" ) res(,i) = [255,0,0];
      if( strcolor(i) == "green" ) res(,i) = [0,255,0];
      if( strcolor(i) == "blue" ) res(,i) = [0,0,255];
      if( strcolor(i) == "magenta" ) res(,i) = [255,0,255];
      if( strcolor(i) == "cyan" ) res(,i) = [0,255,255];
      if( strcolor(i) == "yellow" ) res(,i) = [255,255,0];
      if( strcolor(i) == "black" ) res(,i) = [0,0,0];
   }
   return res;
}

/* Function d3plot */

#include "plwf.i"

func d3plot( image, pane=, theta=, phi=, cage=, pal=, shade=, edges= )
/* DOCUMENT d3plot, image, pane=, theta=, phi=, cage=, pal=, shade=, edges=

    keywords:

       theta     Tilt in radians (default 0.3)
       phi       Rotation in radians (default 0.6)
       cage      cage or no cage (Boolean)
       pal       Name of palette, omitting .gp
       shade     shade or no shade (Boolean)
       edges     edges or no edges (Boolean)

    2013-01-08/NJW
*/
{
   if( is_void(pane) ) pane = 0;
   window,pane,style="nobox.gs";
   if( is_void(theta) ) theta = 0.3;
   if( is_void(phi) ) phi = 0.6;
   if( is_void(cage) ) cage = 0;
   if( is_void(pal) ) {
      palette,"gray.gp";
   } else {
      palette,pal+".gp";
   }
   orient3,phi,theta;
   cage3,cage;
   plwf,image, shade=shade, edges=edges;
}
%FILE% plotdist.i
/* Function plotdist */

func plotdist( x, y, x0, y0 )
/* DOCUMENT r = plotdist( x, y, x0, y0 )

   Returns array of distances normalized to max(x)-min(x)
   and max(y)-min(y)

   x and y are arrays of the same dimension; x0 and y0
   are scalars.

   2006-12-29/NJW

*/
{

   scalx = max(x) - min(x);
   scaly = max(y) - min(y);
   if( scalx == 0.0 ) scalx = 1.0;
   if( scaly == 0.0 ) scaly = 1.0;

   return sqrt(((x-x0)/scalx)^2 + ((y-y0)/scaly)^2);

}
%FILE% polyrotsmooth.i
func polyrotsmooth( &xar, &yar, angle, ndegree, nfit=, nres= )
/* DOCUMENT polyrotsmooth, (>)xar, (>)yar, angle, ndegree, nfit=, nres=

   A curve given by (xar,yar) is rotated 'angle' degrees, fitted with
   a polynomium of degree 'ndegree'. The resulting fit is rotated back
   and returned in 'xar' and 'yar'.

   The curve is resampled to 'nfit' points (default is 40) to lend more
   weight to long stretches between original points. The returned fit
   is given in 'nres' points (default 100).

   2009-07-30/NJW
*/
{

   if( is_void(nfit) ) nfit = 40;
   if( is_void(nres) ) nres = 100;

   x = xar;
   y = yar;

   // rotate by angle 'angle' around (0,0)
   vscalrot, x, y, [0.,0.], angle;

   // resample the curve
   xxx = span(x(1),x(0),nfit);
   yy = interp(y,x,xxx);

   // do the polynomial fitting
   xx = span(x(1),x(0),nres);
   res = poly_fit( xxx, yy, ndegree, xfit=xx );

   // rotate back to original position
   vscalrot, xx, res, [0.,0.], angle, inv=1;

   // and return variables
   xar = xx;
   yar = res;

}
%FILE% pr_contrast.i
func pr_contrast( ima )
{
   m = max(ima);
   w = where( ima > m/2 );
   ima(w) = m;
   w = where( ima <= m/2 );
   ima(w) = 0;
}
%FILE% pr_hori_line.i
func pr_hori_line( ima )
{
   dms = dimsof(ima);
   m = double(max(ima));

   margin = 10;
   spacing = 20;
   n_points = (dms(2) - 2*margin)/spacing;
   idx = indgen(margin:dms(2)-margin:spacing);
   n_idx = numberof(idx);

   red_ima = ima(idx,);
   score = red_ima(sum,)/(m*n_idx);

%FILE% prime.i
func prime_factors( number )
{
   limit = long(sqrt(number));
   for( j = 2; j <= limit; j++ ) {
      if( number%j == 0 ) {
         number = number / j;
         write,format=" %i\n", j;
         prime_factors, number;
         return;
      }
   }
   write,format=" %i\n", number;
}

func is_prime( number )
{
   limit = long(sqrt(number));
   for( j = 2; j <= limit; j++ ) {
      if( number%j == 0 ) return 0;
   }
   return 1;
}

func next_prime( number )
{
   if( number%2 == 0 ) {
      number++;
   } else {
      number += 2;
   }
   while( !is_prime(number) ) number += 2;
   return number;
}
%FILE% privat.i
struct event {
   long day;
   long month;
   long year;
   string text;
}

func raise_flag( days_before )
/* DOCUMENT flag = raise_flag( days_before )

   Returns number of events in the next 'days_before' days
   Input is taken from /home/njw/maerkedage/huskedag.txt
   Output goes to /home/njw/maerkedage/idag.txt

   2008-11-27/NJW
*/
{
   fname = "/home/njw/maerkedage/huskedag.txt";
   f = open( fname, "r" );

   ymd_now = ndate(4);
   year_now = strpart(ndate(2), 1:4 );
   ynow = atoi(year_now);
   days_now = dattim2ijd(year_now+swrite(format="-%02i-%02iT00", ymd_now(2), ymd_now(3) ));
   year_next = swrite(format="%4i",ynow+1);

   sum_ndays = [];
   sum_text = [];
   sum_age = [];

   while( (line = rdline(f)) ) {
      //+ write, line;
      line = strtrim(line);
      if( strpart(line,1:1) == "#" ) continue;
      r = _hd_parse( line );
      dt = dattim2ijd(year_now+swrite(format="-%02i-%02iT00", r.month, r.day ));
      if( dt < days_now ) { // event has passed this year, try next year
         dtn = dattim2ijd(year_next+swrite(format="-%02i-%02iT00", r.month, r.day ));
         y = ynow+1;
         ndays = dtn - days_now;
         //+ write,format="%7.2f days to event: %s\n", dtn - days_now, r.text;
      } else {
         y = ynow;
         ndays = dt - days_now;
         //+ write,format="%7.2f days to event: %s\n", dt - days_now, r.text;
      }
      if( ndays <= days_before ) {
         grow, sum_ndays, ndays;
         grow, sum_text, r.text;
         grow, sum_age, y - r.year;
      }
   }
   close, f;

   foutname = "/home/njw/maerkedage/idag.txt";
   n = numberof(sum_ndays);
   if( n > 0 ) {
      fout = open( foutname,"w");
      is = sort(sum_ndays);
      sum_ndays = sum_ndays(is);
      sum_text  = sum_text(is);
      sum_age   = sum_age(is);
      for( i = 1; i <= n; i++ ) {
         age_str = sum_age(i) > 0 ? swrite(format=" (%i aar)", sum_age(i)) : "" ;
         if( sum_ndays(i) < 0.5 ) {
            write,format="TODAYs event !! : %s%s\n", sum_text(i), age_str;
            write,fout,format="TODAYs event !! : %s%s\n", sum_text(i), age_str;
         } else {
            write,format="%6.0f days to event: %s%s\n", sum_ndays(i), sum_text(i), age_str;
            write,fout,format="%6.0f days to event: %s%s\n", sum_ndays(i), sum_text(i), age_str;
         }
      }
   } else remove, foutname;

   return n;

}

func _hd_parse( line )
/* DOCUMENT s = _hd_parse( line )

    where 'line' is a string "dd/mm year text text ..."
    Returns struct with elements: day(long), month(long), year(long), text(string)

    Auxiliary function for 'raise_flag'

    2008-11-27/NJW
*/
{
   res = event();
   pos1 = strpos( line, "/", 1 );
   day = strtrim(strpart(line,1:pos1-1));
   res.day = atoi(day);
   pos2 = strpos( line, " ", pos1 );
   month = strtrim(strpart(line,pos1+1:pos2-1));
   res.month = atoi(month);
   while( strpart(line,pos2:pos2) == " " ) pos2++;
   pos3 =strpos( line, " ", pos2 );
   year = strpart( line, pos2:pos3-1 );
   res.year = atoi(year);
   text = strtrim(strpart( line, pos3:0 ));
   res.text = text;
 
   return res;
}
%FILE% privat_dk.i
/*************************************************************
 *
 *  Et huske system
 * /home/njw/maerkedage/huskedag.txt med linjer i formatet:
 *
 *    <dag>/<maaned> aarstal tekststreng [n1,n2,n3,n4,..]
 *
 * hvor tekststrengen kan indeholde mellemrum, men ikke '['
 * Dette tegn markerer nemlig starten paa listen af
 * "hvor mange dage i forvejen, der skal gives besked", som kan
 * indeholde op til 11 muligheder (komma-adskilt).
 *
 *    2010-02-19/NJW (opdateret, startet ca. 2008)
 *    2012-04-12/NJW (opdateret til at være tavs om fremtidige begivenheder)
 **************************************************************/

struct event {
   long day;
   long month;
   long year;
   long remind(11);
   string text;
}

func raise_flag( void )
/* DOCUMENT flag = raise_flag( void )

   Returns number of events that will occur in one of the 'remind'
   days.
   Input is taken from /home/njw/maerkedage/huskedag.txt
   Output goes to /home/njw/maerkedage/idag.txt

   2008-11-27/NJW
*/
{
   fname = "/home/njw/maerkedage/huskedag.txt";
   f = open( fname, "r" );

   ymd_now = ndate(4);
   year_now = strpart(ndate(2), 1:4 );
   ynow = atoi(year_now);
   days_now = dattim2ijd(year_now+swrite(format="-%02i-%02iT00", ymd_now(2), ymd_now(3) ));
   year_next = swrite(format="%4i",ynow+1);

   sum_ndays = [];
   sum_text = [];
   sum_age = [];

   while( (line = rdline(f)) ) {
      //+ write, " --------  Next line:   "+line;
      line = strtrim(line);
      if( strpart(line,1:1) == "#" ) continue;
      if( strlen(line) < 10 ) continue;
      r = _hd_parse( line );
      dt = dattim2ijd(year_now+swrite(format="-%02i-%02iT00", r.month, r.day ));
      if( dt < days_now ) { // event has passed this year, try next year
         dtn = dattim2ijd(year_next+swrite(format="-%02i-%02iT00", r.month, r.day ));
         y = ynow+1;
         ndays = dtn - days_now;
         //+ write,format="%7.2f days to event: %s\n", dtn - days_now, r.text;
      } else {
         y = ynow;
         ndays = dt - days_now;
         //+ write,format="%7.2f days to event: %s\n", dt - days_now, r.text;
      }
      if( r.year > y ) ndays = 555.;
      if( anyof( ndays == r.remind ) ) {
         grow, sum_ndays, ndays;
         grow, sum_text, r.text;
         grow, sum_age, y - r.year;
      }
   }
   close, f;

   foutname = "/home/njw/maerkedage/idag.txt";
   n = numberof(sum_ndays);
   if( n > 0 ) {
      fout = open( foutname,"w");
      is = sort(sum_ndays);
      sum_ndays = sum_ndays(is);
      sum_text  = sum_text(is);
      sum_age   = sum_age(is);
      for( i = 1; i <= n; i++ ) {
         age_str = sum_age(i) > 0 ? swrite(format=" (%i år)", sum_age(i)) : "" ;
         if( sum_ndays(i) < 0.5 ) {
            write,format="DET ER I DAG !! : %s%s\n", sum_text(i), age_str;
            write,fout,format="DET ER I DAG !! : %s%s\n", sum_text(i), age_str;
         } else {
            if( sum_ndays(i) > 1.5 ) {
               write,format="%6.0f dage til %s%s\n", sum_ndays(i), sum_text(i), age_str;
               write,fout,format="%6.0f dage til %s%s\n", sum_ndays(i), sum_text(i), age_str;
            } else {
               write,format="%6.0f dag til %s%s\n", sum_ndays(i), sum_text(i), age_str;
               write,fout,format="%6.0f dag til %s%s\n", sum_ndays(i), sum_text(i), age_str;
            }
         }
      }
   } else remove, foutname;

   return n;

}

func _hd_parse( line )
/* DOCUMENT s = _hd_parse( line )

    where 'line' is a string "dd/mm year text text ..."
    Returns struct with elements: day(long), month(long), year(long), text(string)

    Auxiliary function for 'raise_flag'

    2008-11-27/NJW
*/
{
   res = event();
   res.remind = 999;

   // find dato

   pos1 = strpos( line, "/", 1 );
   day = strtrim(strpart(line,1:pos1-1));
   res.day = atoi(day);
   pos2 = strpos( line, " ", pos1 ); // foerste mellemrum efter dato
   month = strtrim(strpart(line,pos1+1:pos2-1));
   res.month = atoi(month);

   // gaa til start af aarstal

   while( strpart(line,pos2:pos2) == " " ) pos2++;
   pos3 =strpos( line, " ", pos2 );
   year = strpart( line, pos2:pos3-1 );
   res.year = atoi(year);

   // teksten er resten af linjen indtil '['

   pos4 = strpos( line, "[", pos3 );
   text = strtrim(strpart( line, pos3:pos4-1 ));
   res.text = text;

   // 'remind' er resten af linjen indtil ']'

   pos5 = strpos( line, "]", pos4+1 );
   sstr = strpart(line,pos4+1:pos5-1);
   sstr_tok = strsplit( sstr, "," );
   n_tok = numberof(sstr_tok);
   for(i=1;i<=n_tok;i++) res.remind(i) = atoi(sstr_tok(i));
 
   return res;
}
%FILE% privat_uk.i
struct event {
   long day;
   long month;
   long year;
   string text;
}

func raise_flag( days_before )
/* DOCUMENT flag = raise_flag( days_before )

   Returns number of events in the next 'days_before' days
   Input is taken from /home/njw/maerkedage/huskedag.txt
   Output goes to /home/njw/maerkedage/idag.txt

   2008-11-27/NJW
*/
{
   fname = "/home/njw/maerkedage/huskedag.txt";
   f = open( fname, "r" );

   ymd_now = ndate(4);
   year_now = strpart(ndate(2), 1:4 );
   ynow = atoi(year_now);
   days_now = dattim2ijd(year_now+swrite(format="-%02i-%02iT00", ymd_now(2), ymd_now(3) ));
   year_next = swrite(format="%4i",ynow+1);

   sum_ndays = [];
   sum_text = [];
   sum_age = [];

   while( (line = rdline(f)) ) {
      //+ write, line;
      line = strtrim(line);
      if( strpart(line,1:1) == "#" ) continue;
      r = _hd_parse( line );
      dt = dattim2ijd(year_now+swrite(format="-%02i-%02iT00", r.month, r.day ));
      if( dt < days_now ) { // event has passed this year, try next year
         dtn = dattim2ijd(year_next+swrite(format="-%02i-%02iT00", r.month, r.day ));
         y = ynow+1;
         ndays = dtn - days_now;
         //+ write,format="%7.2f days to event: %s\n", dtn - days_now, r.text;
      } else {
         y = ynow;
         ndays = dt - days_now;
         //+ write,format="%7.2f days to event: %s\n", dt - days_now, r.text;
      }
      if( ndays <= days_before ) {
         grow, sum_ndays, ndays;
         grow, sum_text, r.text;
         grow, sum_age, y - r.year;
      }
   }
   close, f;

   foutname = "/home/njw/maerkedage/idag.txt";
   n = numberof(sum_ndays);
   if( n > 0 ) {
      fout = open( foutname,"w");
      is = sort(sum_ndays);
      sum_ndays = sum_ndays(is);
      sum_text  = sum_text(is);
      sum_age   = sum_age(is);
      for( i = 1; i <= n; i++ ) {
         age_str = sum_age(i) > 0 ? swrite(format=" (%i aar)", sum_age(i)) : "" ;
         if( sum_ndays(i) < 0.5 ) {
            write,format="TODAYs event !! : %s%s\n", sum_text(i), age_str;
            write,fout,format="TODAYs event !! : %s%s\n", sum_text(i), age_str;
         } else {
            write,format="%6.0f days to event: %s%s\n", sum_ndays(i), sum_text(i), age_str;
            write,fout,format="%6.0f days to event: %s%s\n", sum_ndays(i), sum_text(i), age_str;
         }
      }
   } else remove, foutname;

   return n;

}

func _hd_parse( line )
/* DOCUMENT s = _hd_parse( line )

    where 'line' is a string "dd/mm year text text ..."
    Returns struct with elements: day(long), month(long), year(long), text(string)

    Auxiliary function for 'raise_flag'

    2008-11-27/NJW
*/
{
   res = event();
   pos1 = strpos( line, "/", 1 );
   day = strtrim(strpart(line,1:pos1-1));
   res.day = atoi(day);
   pos2 = strpos( line, " ", pos1 );
   month = strtrim(strpart(line,pos1+1:pos2-1));
   res.month = atoi(month);
   while( strpart(line,pos2:pos2) == " " ) pos2++;
   pos3 =strpos( line, " ", pos2 );
   year = strpart( line, pos2:pos3-1 );
   res.year = atoi(year);
   text = strtrim(strpart( line, pos3:0 ));
   res.text = text;
 
   return res;
}
%FILE% profile.i

local profiler;
/* DOCUMENT profiler.i --- Routines for profiling execution time

   List of routines
 * timer_init:    initialization
 * timer_call:    function call
 * timer_return:  function return
 * timer_show:    display
 *
 * Modified: 11 Sep 1997, R. Saravanan
 *
 */

// Maximum calling stack size (for timing info)
TIMER_MAXCALL= 256;

TIMER_STACK= array(long,TIMER_MAXCALL);
TIMER_START= array(double,3,TIMER_MAXCALL);
TIMER_NEST=  array(double,3,TIMER_MAXCALL);

// Maximum recursion level (for timing info)
TIMER_RECLEV= 10;

TIMER_NAMES= [];

struct timer_struc{    // Timer structure
long count, curlev;
double accum(3,TIMER_RECLEV);
}

func timer_init(track=,ignore=)
/* DOCUMENT  timer_init,track=,ignore=
   Initialize (or reset) execution time counters for functions.
   Should be called from the main program.
   Calls to function name strings TRACK, if specified, are stratified based
   upon the calling function.
   Calls to function name strings IGNORE, if specified, are ignored
   (i.e., their timings are lumped with that of the calling function)
   SEE ALSO: timer_call, timer_return, timer_show, timer
 */
{
  extern TIMER_STACK, TIMER_START, TIMER_NEST, TIMER_TRACK, TIMER_IGNORE,
         TIMER_CALLNO, TIMER_CURFUN, TIMER_CALLFUN, TIMER_NAMES, TIMER_PARS;

// Initialize calling stack index
  TIMER_CALLNO= 0;

// Initialize timing operations
  TIMER_NAMES= "*main*";
  TIMER_PARS=  timer_struc();

  TIMER_TRACK= track;
  TIMER_IGNORE= ignore;

  TIMER_CURFUN= "";
  TIMER_CALLFUN= "";

  timer_call, "*main*";

  return;
}

func timer_call( func_name )
/* DOCUMENT  timer_call( func_name )
   Log a function call to FUNC_NAME for execution timing.
   (If FUNC_NAME == "", ignore this call)
   SEE ALSO: timer_init, timer_return, timer_show, timer
 */
{
  extern TIMER_STACK, TIMER_START, TIMER_NEST, TIMER_TRACK, TIMER_IGNORE,
         TIMER_CALLNO, TIMER_CURFUN, TIMER_CALLFUN, TIMER_NAMES, TIMER_PARS;

  if (is_void(TIMER_NAMES) || (func_name == "") ||
      anyof(TIMER_IGNORE == func_name) ) return;

  if (anyof(TIMER_TRACK == func_name)) {
    stack_name= TIMER_CALLFUN+"->"+func_name;
    if (stack_name != TIMER_CURFUN)
      stack_name= TIMER_CURFUN+"->"+func_name;

  } else {
    stack_name= func_name;
  }

// Set name of calling function (excluding immediate recursive calls)
  if (TIMER_CURFUN != stack_name) TIMER_CALLFUN= TIMER_CURFUN;

// Name of current function call
  TIMER_CURFUN= stack_name;

// Locate function name
  list= where(TIMER_NAMES == stack_name);

  if (!numberof(list)) {
//  Add new function name to list
    grow, TIMER_NAMES, stack_name;
    grow, TIMER_PARS,  timer_struc();
    ifun= numberof(TIMER_NAMES);
  } else {
    ifun= list(1);
  }

// Stack call
  TIMER_CALLNO += 1;
  if (TIMER_CALLNO > TIMER_MAXCALL)
    error, "Too many function calls";
  TIMER_STACK(TIMER_CALLNO)= ifun;

// Save start time for this call
  elapsed= array(double,3);
  timer, elapsed;
  TIMER_START(,TIMER_CALLNO)= elapsed;
  TIMER_NEST(,TIMER_CALLNO)= 0.;

// Increment calling level and count for function
  curlev= TIMER_PARS(ifun).curlev;
  curlev+= 1;
  if (curlev > TIMER_RECLEV)
    error, "Too many recursion levels for function '"+func_name+"'";

  TIMER_PARS(ifun).curlev= curlev;
  TIMER_PARS(ifun).count= TIMER_PARS(ifun).count + 1;

  return;
}

func timer_return( func_name, return_value )
/* DOCUMENT  timer_return( func_name, return_value )
   Log a return from function FUNC_NAME for execution timing,
   with optional RETURN_VALUE, which is simply returned as it is.
   (If FUNC_NAME == "", ignore this call, and return RETURN_VALUE)
   (May also be invoked as a subroutine)
   SEE ALSO: timer_init, timer_call, timer_show, timer
 */
{
  extern TIMER_STACK, TIMER_START, TIMER_NEST, TIMER_TRACK, TIMER_IGNORE,
         TIMER_CALLNO, TIMER_CURFUN, TIMER_CALLFUN, TIMER_NAMES, TIMER_PARS;

  if (is_void(TIMER_NAMES) || (func_name == "") ||
      anyof(TIMER_IGNORE == func_name) ) return return_value;

  if (anyof(TIMER_TRACK == func_name))
    stack_name= TIMER_CALLFUN+"->"+func_name;
  else
    stack_name= func_name;

  ifun= TIMER_STACK(TIMER_CALLNO);

  if (TIMER_NAMES(ifun) != stack_name)
    error, "Called '"+TIMER_NAMES(ifun)+"' but returning from '"+stack_name;

// Compute time spent in this function
  elapsed= TIMER_START(,TIMER_CALLNO);
  split= array(double,3);
  timer, elapsed, split;

// Accumulate time spent in this function (but not in nested calls)
  curlev= TIMER_PARS(ifun).curlev;
  if (curlev < 1)
    error, "Attempt to return without calling from function '"+func_name+"'";
  TIMER_PARS(ifun).accum(,curlev)= TIMER_PARS(ifun).accum(,curlev) -
                                   TIMER_NEST(,TIMER_CALLNO) + split;
  curlev -= 1;
  TIMER_PARS(ifun).curlev= curlev;

// Pop call, and accumulate time spent on nested call for calling function
  TIMER_CALLNO -= 1;
  TIMER_NEST(,TIMER_CALLNO)= TIMER_NEST(,TIMER_CALLNO) + split;

// Reset name of current function call
  TIMER_CURFUN= TIMER_NAMES(TIMER_STACK(TIMER_CALLNO));

// Set name of calling function (excluding immediate recursive calls)
  icallno= TIMER_CALLNO-1;
  while ((icallno > 1) && (TIMER_CURFUN==TIMER_NAMES(TIMER_STACK(icallno))))
    icallno--;

  TIMER_CALLFUN= TIMER_NAMES(TIMER_STACK(icallno));

  return return_value;
}

func timer_show( ndisp, recursion=, sort_count= )
/* DOCUMENT  timer_show, ndisp, recursion=0/1, sortcount=0/1
   Display sorted timing statistics for all logged function calls,
   starting from the function that takes the most execution time.
   The optional parameter NDISP determines the number of functions to
   be displayed (the default is to display the top 20).
   If RECURSION==1, then execution times for different levels of recursive
   function calls are also reported separately
   (in addition to the total for the function).
   If SORT_COUNT==1, then sort by number of calls.

   NOTE:
   Execution times for functions whose calls are not logged using
   TIMER_CALL/TIMER_RETURN are lumped together with the execution times
   for the functions within which these calls originated.
   For calls from the main program, unlogged function call timings
   are lumped together with the execution time for *main*.

   SEE ALSO: timer_init, timer_call, timer_return, timer
 */
{
  extern TIMER_STACK, TIMER_START, TIMER_NEST, TIMER_TRACK, TIMER_IGNORE,
         TIMER_CALLNO, TIMER_CURFUN, TIMER_CALLFUN, TIMER_NAMES, TIMER_PARS;

  if (is_void(ndisp)) ndisp= 20;

  if (is_void(TIMER_NAMES))
    error, "Timing counters should be initialized by calling TIMER_INIT";

// Time main program
  elapsed= TIMER_START(,1);
  split= array(double,3);
  timer, elapsed, split;

// Compute time spent in main program (but not in nested calls)
  TIMER_PARS(1).accum(,1)= split - TIMER_NEST(,1);

  countall= TIMER_PARS().count;
  accumall= TIMER_PARS().accum;
  if ((dimsof(accumall))(1) == 2) accumall= accumall(..,-);

  write, format="%29s   %10s  %10s  %10s  %10s\n",
    "Function", "CPU sec", "System sec", "Wall sec", "Call count"

  write, format="%29s   %10.3f  %10.3f  %10.3f\n",
    "*TOTAL*", accumall(1,sum,sum), accumall(2,sum,sum), accumall(3,sum,sum)

// Sort in reverse order of execution times
  if (param_set(sort_count)) {
    isort= sort( -countall );
  } else {
    isort= sort( -accumall(1,sum,) );
  }

  nfun= min([numberof(TIMER_NAMES), ndisp]);
  for (j=1; j<=nfun; j++) {
    ifun= isort(j);

//  Display total time for function calls
    write, format="%29s   %10.3f  %10.3f  %10.3f  %10d\n", TIMER_NAMES(ifun),
      accumall(1,sum,ifun), accumall(2,sum,ifun),
      accumall(3,sum,ifun), countall(ifun);

    nlev= sum( accumall(sum,,ifun) > 0 );
    if ((nlev > 1) && param_set(recursion)) {
//    Display time for different recursion levels
      for (ilev=1; ilev<=nlev; ilev++) {
        write, format="%29d   %10.3f  %10.3f  %10.3f\n", ilev,
          accumall(1,ilev,ifun), accumall(2,ilev,ifun),
          accumall(3,ilev,ifun);
      }
    }
  }
}
%FILE% proj.i
extern projdoc;
/* DOCUMENT  Auxiliary package to 'do_project'

   2008-01-25/NJW

   First > do_project 1 q123
   Then  Yorick> ana_proj_run, 1, "q123",detail=1
       If errors are reported then do
               > update_proj
   which will redefine q123/swid.list to contain the SWIDs that were not run
   because jemx_science_analysis was halted prematurely.

   Functions in package:

      ana_proj_run   : Tracks SWIDs and Error_'s in the log files resulting from
                       a call of 'do_project'
      update_proj    : Will update proj/swid.list with SWIDs to be rerun
      check_status   : Update status files in JEM-X local archive /jemx/arc/rev_3
      j_logsects     : Locates the sections in the log file pertaining to a single SWID
      j_logsplit     : Splits the log file in pieces named log_nnn for each SWID
      scan_expo_update : Updates the EXPOSURE_Ji, SHD_Ji columns in pointings_RRRR.fits
      scan_gain_update : Updates the GAIN_Ji column in pointings_RRRR.fits
*/

/* Function ana_proj_run */

func ana_proj_run( jemxNum, proj, &listdone, &listredo, &listblack, \
           bdir=, block=, detail=, init=, chat=, nof= )
/* DOCUMENT ana_proj_run, jemxNum, proj, >listdone, >listredo, >listblack, 
                      bdir=, block=, detail=, init=, chat=, nof=

   returns the indices where a new runnning of jemx_scw_analysis
   starts
   Keyword 'bdir'   to be set if /scratch is not the 'bottom' directory
                    e.g. bdir="/r11" if a tesla run has been done
   Keyword 'detail' causes info on appearing errors
   Keyword 'block'  limits analysis to that particular block
   Keyword 'init'   will cause a reset of listdone, listredo, and listblack
   Keyword 'chat'   0 : Minimal output (only reporting errors)
                    1 : Basic output
                    2 : Extra information
   Keyword 'nof'    (no file) prevents writing of a log file

   2008-01-16/NJW
*/
{
   local idxbeg, idxend, swids;
   extern LISTREDO, LISTBLACK, LISTDONE, JEMXNUM, PROJ;

   if( is_void(proj) ) {
      write,"Syntax: ana_proj_run, jemxNum, proj, >listdone, >listredo, >listblack, ";
      write,"    block=, detail=, init=, chat=, nof=";
      return;
   }

   ana9basdir = "/r9/njw/jemx/";
   outbasdir = "/scratch/jemx/njw/";
   if( typeof(bdir) == "string" ) outbasdir = bdir+outbasdir;

   if( is_void(block) ) { // Go through all blocks
      bdirs = file_search( proj+"_??", outbasdir, dir=1 );
      nbdirs = numberof(bdirs);
      if( nbdirs == 0 ) {
         write,format="No directories for project %s\n", proj;
         return [];
      }
      bdirs = bdirs(sort(bdirs));
   } else {
      if( typeof(block) != "string" ) block = swrite(format="%02i", block);
      bdirs = outbasdir+proj+"_"+block;
      nbdirs = file_test(bdirs);
      if( !nbdirs ) {
         write,format="Directory %s_%s does not exist\n", outbasdir+proj, block;
         return [];
      }
   }
   if( typeof(jemxNum) != "string" ) jemxNum = swrite(format="%1i", jemxNum);

   if( init ) {
      listdone = [];
      listredo = []
      listblack = [];
   }
   PROJ = proj;
   JEMXNUM = jemxNum; // string
   num_not_accounted_for = 0;

   if( !chat ) chat = 0;
   lg = nof ? 0 : 1;
   if( lg ) {
      lgname = get_next_filename("apr_log_????.txt");
      flg = open( lgname, "w" );
   }
   

   for( bl = 1; bl <= nbdirs; bl++ ) {

      block = strpart(bdirs(bl),-1:0);
      log_file_name = outbasdir+proj+"_"+block+"/obs/"+proj+"_"+jemxNum+"_block_"+block+"/log";
   
      if( !file_test(log_file_name) ) {
         write,format="Sorry, %s does not exist\n", log_file_name;
         if(lg)write,flg,format="Sorry, %s does not exist\n", log_file_name;
         continue;
      }
      if( chat > 0 ) {
         write,format="Analyzing log file: %s\n", log_file_name;
         if(lg)write,flg,format="Analyzing log file: %s\n", log_file_name;
      }
   
     /*
      *   Get the list of expected SWIDs to find
      */
   
      blockfile = ana9basdir+"analysis9/"+proj+"/block_"+block;
      bb = read_slist( blockfile );
      swids_exp = strpart(bb,1:12);
      nbb = numberof(bb);
   
      if( chat > 0 ) {
         write,format="Expect to find following SWIDs:%s\n","";
         for( i = 1; i <= nbb; i++ ) write,format="     %s\n", swids_exp(i);
         if( lg ) {
            write,flg,format="Expect to find following SWIDs:%s\n","";
            for( i = 1; i <= nbb; i++ ) write,flg,format="     %s\n", swids_exp(i);
         }
      }
   
   
      llog = read_slist( log_file_name );
      w = strmatch( llog, "jemx_scw_analysis" );
      nw = numberof( w );
      if( !sum(w) ) {
         write,"Never started jemx_scw_analysis";
         grow, listredo, swids_exp;
         continue;
      }
   
      nsects = j_logsects( llog, idxbeg, idxend, swids );

      for( i = 1; i <= nsects; i++ ) {
         swid = swids(i);
         grow, swids_found, swid;
         n = sum(strmatch(llog(idxbeg(i):idxend(i)), "Error_" ));
         if( n > 0 || chat > 0 ) {
            write,format="Section#%i, %s with %i errors\n", i, swid, n;
            if(lg)write,flg,format="Section#%i, %s with %i errors\n", i, swid, n;
         }
         if( n == 0 ) {
            grow, listdone, swid;
         } else {
            grow, listblack, swid;
         }
      }
   
      if( detail ) {
         for( i = 1; i <= nsects; i++ ) {
            s = strmatch(llog(idxbeg(i):idxend(i)), "Error_" );
            w = where(s);
            n = sum(s);
            if( n > 0 ) {
               write,format="Section#%i with %i errors\n", i, n;
               for( j = 1; j <= n; j++ ) {
                  write,format="Line#%6i %s\n", idxbeg(i)+w(j)-1, llog(idxbeg(i)+w(j)-1);
               }
               if( lg ) {
                  write,flg,format="Section#%i with %i errors\n", i, n;
                  for( j = 1; j <= n; j++ ) {
                     write,flg,format="Line#%6i %s\n", idxbeg(i)+w(j)-1, llog(idxbeg(i)+w(j)-1);
                  }
               }
            }
         }
      }
   
      fd = filter_done( swids_found, swids_exp );
      num_fd = numberof(fd);
      if( num_fd ) {
         num_not_accounted_for += num_fd;
         grow, listredo, fd;
         write,"List of SWIDs  NOT ACCOUNTED for:";
         for( i = 1; i <= numberof(fd); i++ ) write,format="  %s\n", fd(i);
         if( lg ) {
            write,flg,"List of SWIDs  NOT ACCOUNTED for:";
            for( i = 1; i <= numberof(fd); i++ ) write,flg,format="  %s\n", fd(i);
         }
      } else {
         write,"All expected SWIDs were found in log file for block "+block;
         if(lg)write,flg,"All expected SWIDs were found in log file for block "+block;
      }

   }

   LISTREDO  = listredo;
   LISTDONE  = listdone;
   LISTBLACK = listblack;

   write,format=" --------------- %s -----------------\n", "Summary";
   if(lg)write,flg,format=" --------------- %s -----------------\n", "Summary";
   if( num_not_accounted_for ) {
      write,format="   %i SWIDs are not accounted for\n", num_not_accounted_for;
      if(lg)write,flg,format="   %i SWIDs are not accounted for\n", num_not_accounted_for;
   } else {
      write,"     All SWIDs have been dealt with - no further action needed";
      if(lg)write,flg,"     All SWIDs have been dealt with - no further action needed";
   }
   write,"-----------------------------------------";
   if(lg)write,flg,"-----------------------------------------";

   if(lg) close, flg;

   return num_not_accounted_for;

}

/* Function update_proj */

func update_proj( revol, update= )
/* DOCUMENT update_proj, revol, update=
     (takes no arguments, uses the external variables defined
      in 'ana_proj_run')

   2008-02-22/NJW
   2011-04-27/NJW, updated for rev_3
   2011-12-08/NJW, updated for rev_3/scw_lists
*/
{

  /*
   *  Assume that 'ana_proj_run' has been run. It has found the
   *  fate of the SWIDs and updated the externals LISTREDO etc.
   *  i.e. the fresh series
   *
   *  The old results from previous runs of 'do_project' followed by
   *  yorick 'ana_proj_run' are stored in files jxmi_redo.list in the
   *  appropriate archive directory. These are to be combined with
   *  the fresh results and then updated.
   */

   extern PROJ, JEMXNUM, LISTREDO, LISTDONE, LISTBLACK; // fresh results

   if( is_void(PROJ) ) write,"External PROJ is missing ...";
   if( is_void(JEMXNUM) ) write,"External JEMXNUM is missing ...";
   if( is_void(PROJ) || is_void(JEMXNUM) ) return;

   jemxNum = JEMXNUM; // string
   if( typeof(revol) != "string" ) revol = swrite(format="%04i", revol);

   arcdir = "/jemx/arc/rev_3/scw_lists/"+revol;

   fndone = arcdir+"/jmx"+jemxNum+"_done.list";   // from earlier runs
   fnblack = arcdir+"/jmx"+jemxNum+"_black.list";
   fnredo = arcdir+"/jmx"+jemxNum+"_redo.list";
   ftdo = file_test(fndone);
   ftbl = file_test(fnblack);
   ftre = file_test(fnredo);

   listdone = [];
   listredo = [];
   listblack = [];
   n_listdone = 0;
   n_listredo = 0;
   n_listblack = 0;

   if( ftdo ) {
      listdone = read_slist( fndone );
      // combine old results with fresh results
      grow, listdone, LISTDONE;
      // make allowance for double entries
      if( numberof(listdone) ) {
         listdone = listdone(sort(listdone));
         listdone = listdone(uniq(listdone));
      }
   } else {
      listdone = LISTDONE;
   }
   n_listdone = numberof( listdone );

   if( ftre ) {
      listredo = read_slist( fnredo );
      // some of the old to-be-redone might now be done or
      // blacklisted, so remove those
      listredo = filter_done( grow(LISTDONE,LISTBLACK), listredo );
   } else {
      listredo = LISTREDO;
   }
   n_listredo = numberof( listredo );

   if( ftbl ) {
      listblack = read_slist( fnblack );
      // combine old results with fresh results
      grow, listblack, LISTBLACK;
      // make allowance for double entries
      if( numberof(listblack) ) {
         listblack = listblack(sort(listblack));
         listblack = listblack(uniq(listblack));
      }
   } else {
      listblack = LISTBLACK;
   }
   n_listblack = numberof( listblack );

   if( update ) {

      write_slist, fndone, listdone;
      write_slist, fnredo, listredo;
      write_slist, fnblack, listblack;

      write,"Updating of files in archive has been done";

   }

  /*
   * Position in project directory for update of 'swid.list'
   * and 'swid.blacklist'
   */

   dir = "/r9/njw/jemx/analysis9/"+PROJ;
   curdir = get_cwd();
   cd, dir;

   //+ back, "swid.list";
   write_slist,"swid.list", listredo;
   write,format="%i SWIDs written to %s\n", n_listredo, \
                 dir+"/swid.list";

   //+ back, "swid.blacklist";
   write_slist,"swid.blacklist", listblack;
   write,format="%i SWIDs written to %s\n", n_listblack, \
              dir+"/swid.blacklist";

   cd, curdir;

   return n_listredo;
}

/* Function j_logsects */

func j_logsects( logtxt, &idxbeg, &idxend, &swids )
/* DOCUMENT nidxbeg = j_logsects( logtxt, >idxbeg, >idxend, >swids )

   Returns the number of SWIDs appearing in the (text of the) logfile. In addition,
   idxbeg and idxend are the linenumbers of begin and end of the SWID reported in
   the array 'swids'.

   2008-02-22/NJW
*/
{

   nlogtxt = numberof(logtxt);

   slen = strlen(logtxt);

   //  Look for simultaneous occurrences of 'jemx_science_analysis' and 'jemx_scw_analysis'

   s1 = strmatch( logtxt, "jemx_science_analysis" );
   s2 = strmatch( logtxt, "jemx_scw_analysis" );
   idxbeg = where( s1 & s2 );
   idxend = idxbeg;
   if( numberof(idxbeg) == 0 ) error,"J_LOGSECTS ##3## no match found";
   nidxbeg = numberof(idxbeg);
   swids = array( string, nidxbeg );

   if( idxbeg(1) == 1 ) error,"J_LOGSECTS ##4## unexpected problem";

   for( i = 1; i <= nidxbeg; i++ ) {
      idxend(i) = i == nidxbeg ? nlogtxt : idxbeg(i+1)-1;
      pick_swid_str, logtxt(idxbeg(i):idxend(i)), swid;
      swids(i) = most_freq_elem( swid );
   }

   return nidxbeg;

}

/* Function j_logsplit */

func j_logsplit( jemxNum, proj, block, logfile= )
/* DOCUMENT j_logsplit, jemxNum, proj, block, logfile=

    Separates the logfile into parts with just a single SWID

    Bimodal operation:
    1) Keyword 'logfile' is not given.
       Assume that 'do_project' has been run and the resulting files
       still reside at the expected places
          jemxNum: 1 or 2 or "1" or "2"
          proj: something like "q132"
          block: either a number (long or int) or a two-digit string
    2) Keyword 'logfile' indicates a log file
       The parameters are disregarded and the function operates on
       the named logfile.

   2008-09-30/NJW   updated with keyword 'logfile'
*/
{
   if( typeof(logfile) == "string" ) {
      logtxt = read_slist( logfile );
      dir = ".";
   } else {
      if( is_void(block) ) {
         write,"Syntax: j_logsplit, jemxNum, proj, block";
         return [];
      }
      if( typeof(jemxNum) != "string" ) jemxNum = swrite(format="%1i",jemxNum);
      if( typeof(block) != "string" ) block = swrite(format="%02i",block);

      // indicate standard directory for 'do_project'
      //+ dir = "/r9/njw/jemx/"+proj+"_"+block+"/obs/"+proj+"_"+jemxNum+"_block_"+block;
      dir = "/scratch/jemx/njw/"+proj+"_"+block+"/obs/"+proj+"_"+jemxNum+"_block_"+block;

      logtxt = read_slist( dir+"/log" );
   }
   nlogtxt = numberof(logtxt);

   slen = strlen(logtxt);

   //  Look for simultaneous occurrences of 'jemx_science_analysis' and 'jemx_scw_analysis'

   s1 = strmatch( logtxt, "jemx_science_analysis" );
   s2 = strmatch( logtxt, "jemx_scw_analysis" );
   start = where( s1 & s2 );
   if( numberof(start) == 0 ) error,"J_LOGSPLIT ##3## apparently unfinished log file";
   nstart = numberof(start);

   if( start(1) == 1 ) error,"J_LOGSPLIT ##4## preamble seems to be missing";
   write_slist,dir+"/log_000", logtxt(1:start(1)-1);

   for( i = 1; i <= numberof(start); i++ ) {
      iend = i == numberof(start) ? 0 : start(i+1)-1;
      slog = logtxt(start(i):iend);
      pick_swid_str, slog, swid;
      swid0 = most_freq_elem( swid );
      write,format="Found %s, written to log_%03i\n", swid0, i;
      write_slist, dir+swrite(format="/log_%03i", i), slog;
   }

}

/* Function scan_expo_update */

func scan_expo_update( jemxNum )
/* DOCUMENT  scan_expo_update, jemxNum [string or number]

   Must be run while content of /r9/njw/jemx/shdexpolist holds
   valid information i.e. preferably immediately after running
   the script 'scanf.cgs'. It is also a prerequisite that the
   pointing file 'pointings_RRRR.fits' exists.

   2008-02-12/NJW
*/
{
   listfile = "/r9/njw/jemx/shdexpolist";
   if( !file_test( listfile ) ) {
      write,format="%s does not exist, skip updating exposures\n",\
               listfile;
      return;
   }
   if( is_void(read_slist(listfile)) ) {
      write,format="%s has no lines, skip updating exposures\n",\
               listfile;
      return;
   }

   swids = rscol(listfile, 1, str=1 );
   exposure = rscol(listfile, 2, dble=1 );
   revols = strpart(swids,1:4);

   if( typeof(jemxNum) != "string" ) jemxNum = swrite(format="%1i", jemxNum);

   //  consistency check

   if( numberof(uniq(revols)) > 1 ) {
      write,"Several revolutions present - skip ...";
      return;
   }
   revol = revols(1);

   // pointing file

   pointing_file = "/r6/jemx/pointings/pointings_"+revol+".fits";
   if( !file_test(pointing_file) ) {
      write,format="Pointing file: %s is missing, try to create it ...\n", pointing_file;
      require, "list_pointings.i";
      list_pointings, atoi(revol), ucons=1, fit=1,chat=1;
      if( ! file_test( pointing_file ) ) {
         error,"SCAN_EXPO_UPDATE could not create pointing FITS file";
      }
   }

   fh = headfits( pointing_file+"+1" );
   expocol = fits_colnum( fh, "EXPOSURE_J"+jemxNum );
   shdcol = fits_colnum( fh, "SHD_J"+jemxNum );
   naxis2 = fxpar( fh, "naxis2");
   swid_p = rdfitscol( pointing_file+"+1" , "SWID" );
   exposure_p = rdfitscol( pointing_file+"+1", "EXPOSURE_J"+jemxNum );
   shd_p = rdfitscol( pointing_file+"+1", "SHD_J"+jemxNum );

   nexpo = numberof( exposure ); // values from succesful shd generations

   n_updates = 0;
   for( i = 1; i <= nexpo; i++ ) {
      w = where( swid_p == swids(i) );
      nw = numberof(w);
      if( nw != 1 ) {
         write,format="Warning: SWID %s found %i times in pointing file\n", \
                      swid(i), nw;
         continue;
      }
      exposure_p(w(1)) = exposure(i);
      shd_p(w(1)) = 1;
      n_updates++;
   }

   if( n_updates ) {
      fits_bintable_poke, pointing_file+"+1", 0, expocol, exposure_p;
      fits_bintable_poke, pointing_file+"+1", 0, shdcol, shd_p;
      write,format="Updated %s\n", pointing_file;
   } else {
      write,"No new exposure values, hence no update.";
   }

}


/* Function scan_gain_update */

func scan_gain_update( jemxNum )
/* DOCUMENT  scan_gain_update, jemxNum [string or number]

   Must be run while content of /r9/njw/jemx/shdgainlist holds
   valid information i.e. preferably immediately after running
   the script 'scanf.cgs'. It is also a prerequisite that the
   pointing file 'pointings_RRRR.fits' exists.

   2008-02-27/NJW
*/
{
   listfile = "/r9/njw/jemx/shdgainlist";
   if( !file_test( listfile ) ) {
      write,format="%s does not exist, skip updating gain values\n",\
               listfile;
      return;
   }
   if( is_void(read_slist(listfile)) ) {
      write,format="%s has no lines, skip updating gain values\n",\
               listfile;
      return;
   }
   swids = rscol(listfile, 1, str=1 );
   gain = rscol(listfile, 2, dble=1 );
   revols = strpart(swids,1:4);

   if( typeof(jemxNum) != "string" ) jemxNum = swrite(format="%1i", jemxNum);

   //  consistency check

   if( numberof(uniq(revols)) > 1 ) {
      write,"Several revolutions present - skip ...";
      return;
   }
   revol = revols(1);

   // pointing file

   pointing_file = "/r6/jemx/pointings/pointings_"+revol+".fits";
   if( !file_test(pointing_file) ) {
      write,format="Pointing file: %s is missing, try to create it ...\n", pointing_file;
      require, "list_pointings.i";
      list_pointings, atoi(revol), ucons=1, fit=1,chat=1;
      if( ! file_test( pointing_file ) ) {
         error,"SCAN_GAIN_UPDATE could not create pointing FITS file";
      }
   }

   fh = headfits( pointing_file+"+1" );
   gaincol = fits_colnum( fh, "GAIN_J"+jemxNum );
   naxis2 = fxpar( fh, "naxis2");
   swid_p = rdfitscol( pointing_file+"+1" , "SWID" );
   gain_p = rdfitscol( pointing_file+"+1", "GAIN_J"+jemxNum );

   ngain = numberof( gain ); // values from succesful shd generations

   n_updates = 0;
   for( i = 1; i <= ngain; i++ ) {
      w = where( swid_p == swids(i) );
      nw = numberof(w);
      if( nw != 1 ) {
         write,format="Warning: SWID %s found %i times in pointing file\n", \
                      swid(i), nw;
         continue;
      }
      gain_p(w(1)) = gain(i);
      n_updates++;
   }

   if( n_updates ) {
      fits_bintable_poke, pointing_file+"+1", 0, gaincol, gain_p;
      write,format="Updated %s\n", pointing_file;
   } else {
      write,"No new gain values, hence no update.";
   }

}




/* Function check_status */

func check_status( revol, jemxNum= )
/* DOCUMENT n_to_redo = check_status( revol, jemxNum= )

   2008-02-22/NJW
*/
{
   extern PROJ, JEMXNUM, LISTREDO, LISTDONE, LISTBLACK;

   if( is_void(jemxNum) ) {
      if( is_void(JEMXNUM) ) error,"External JEMXNUM is missing";
      jemxNum = JEMXNUM;
   } else {
      if( typeof(jemxNum) != "string" ) jemxNum = swrite(format="%1i", jemxNum);
   }
   if( typeof(revol) != "string" ) revol = swrite(format="%04i", revol);

   arcdir = "/jemx/arc/rev_3/scw_lists/"+revol;

   fndone = arcdir+"/jmx"+jemxNum+"_done.list";
   fnblack = arcdir+"/jmx"+jemxNum+"_black.list";
   fnredo = arcdir+"/jmx"+jemxNum+"_redo.list";

   listdone = [];
   listredo = [];
   listblack = [];
   n_listdone = 0;
   n_listredo = 0;
   n_listblack = 0;

   if( file_test(fndone) ) {
      listdone = read_slist( fndone );
      n_listdone = numberof( listdone );
      s_listdone = swrite(format="%11i", n_listdone );
   } else {
      s_listdone = "    missing";
   }
   if( file_test(fnredo) ) {
      listredo = read_slist( fnredo );
      n_listredo = numberof( listredo );
      s_listredo = swrite(format="%10i", n_listredo );
   } else {
      s_listredo = "   missing";
   }
   if( file_test(fnblack) ) {
      listblack = read_slist( fnblack );
      n_listblack = numberof( listblack );
      s_listblack = swrite(format="%12i", n_listblack );
   } else {
      s_listblack = "     missing";
   }

   if( am_subroutine() ) {
      write,format="From files in : %s\n", arcdir;
      write,format="%s  listdone  listredo   listblack\n", revol;
      write,format="%s%s%s\n\n", s_listdone, s_listredo, s_listblack;
      write,format="From current memory%s\n", "";
      write,format="%s  LISTDONE  LISTREDO   LISTBLACK\n", "    ";
      write,format="%11i%10i%12i\n\n", numberof(LISTDONE), numberof(LISTREDO), numberof(LISTBLACK);
   } else {
      return n_listredo;
   }
}
%FILE% ps_is_prime_mm.i
#include Y_CODE+"larnum.i"

func ps_is_prime_mm( p_in, nproc, test= )
/* DOCUMENT res = ps_is_prime_mm( p_in, nproc, test= )

   Setup macros to be executed on several machines by shell script 'go_is_prime'
   Tests for 'p_in' being a prime. 'p_in' may be array or string
   representation.

   2009-01-15/NJW
   2009-01-29/NJW independent of machines
*/
{
   local rem, stime;

   if( !test ) test = 0;

   n_proc_tot = nproc;

   if( typeof(p_in) == "string" ) {
      //+ write,"Mark 1";
      pstr = p_in;
      p = str2ln( p_in );
   } else {
      //+ write,"Mark 2";
      pstr = ln2str( p_in );
      p = p_in;
   }
   write,format="PS_IS_PRIME_MM: preparing %s\n", pstr;
   if( !lnodd(p) ) {
      write,"Multiple of 2";
      return 0; // even numbers are rejected at once
   }
   if( !ln5odd(p) ) {
      write,"Multiple of 5";
      return 0; // multiples of 5 are rejected at once
   }
   if( !ln3odd(p) ) {
      write,"Multiple of 3";
      return 0; // multiples of 3 are rejected at once
   }
   if( !ln7odd(p) ) {
      write,"Multiple of 7";
      return 0; // multiples of 7 are rejected at once
   }
   if( !ln11odd(p) ) {
      write,"Multiple of 11";
      return 0; // multiples of 11 are rejected at once
   }
   if( !ln13odd(p) ) {
      write,"Multiple of 13";
      return 0; // multiples of 13 are rejected at once
   }
   q = lnsqrt( p, rem );
   if( noneof(rem(1:-1)) ) return 0;

   //------   from here a real division test is required

   if( !lnodd(q) ) q = sub(q,LNUNIT); // make q odd

   // clean up: remove previous flag files
   //+ write,"Cleaning up";
   /*
    *  'stop.flag' is set by a child process when a divisor has been found
    *  'gip_HOST.flag' is set by script 'go_is_prime' to prevent starting over
    *  'nogo.flag' is set at termination of 'ps_is_prime_mm' to prevent
    *       repeating the prime tests assuming that 'go_is_prime' is started
    *       more or less independently of 'ps_is_prime_mm'
    */
   if( open("stop.flag","r",1) ) {
      // make sure that the stop flag file will remain 15 seconds
      write,"Waiting for stop-flag removal ...";
      pause, 15000;
      timestamp, stime;
      rename, "stop.flag","his_stop_"+swrite(format="%i",stime)+".txt";
   }
   if( open("nogo.flag","r",1) ) remove, "nogo.flag";
   oklist = file_search("ok*.job",".");
   for( i = 1; i <= numberof(oklist); i++ ) remove, oklist(i);
   giplist = file_search("gip*.flag",".");
   for( i = 1; i <= numberof(giplist); i++ ) remove, giplist(i);
   joblist = file_search("*public*.job",".");
   for( i = 1; i <= numberof(joblist); i++ ) remove, joblist(i);

   d = div( q, n_proc_tot );
   if( ln_gt( d, setln(3) ) ) d = sub( d, LNTWO );
   ps = setln(17);
   k_proc = 0;
   for( i = 1; i <= n_proc_tot; i++ ) {
      k_proc++;
      pe = add( ps, d );
      if( ln_gt( pe, q ) ) pe = q;
      if( k_proc == n_proc_tot && ln_gt( q, pe ) ) pe = q;
      if( !lnodd( pe ) ) pe = add( pe, LNUNIT );
      if( test == 1 ) {
         write,format="%3i from %s to %s\n", i, ln2str(ps), ln2str(pe);
      } else {
         s = swrite(format="%03i", i);
         f = open("public_"+s+".job","w");
         //+ write,f,format="#include \"larnum.i\"%s\n","";
         //+ write,f,format="ps_child,%i,\"%s\",\"%s\",\"%s\";\n", i, pstr, ln2str(ps), ln2str(pe);
         //+ write,f,format="quit%s","\n";

         write,f,format="%s\n", pstr;
         write,f,format="%s\n", ln2str(ps);
         write,f,format="%s\n", ln2str(pe);
         close, f;
      }
      ps = add( pe, LNTWO );
   }
   if( test ) return [];
   //
   //-------------------------------------------
   // all macro files have now been setup
   //    - waiting until all processes have come to an end
   //-------------------------------------------
   //
   write,"You can now run 'go_is_prime' on various machines ...";

   // continue until all processes have flagged the result
   // or a stop has occurred
   kount = 0;
   while( ++kount ) {
      n_ok = 0;
      // check the stop flag
      if( open("stop.flag","r",1) ) {
         ff = open("nogo.flag","w");
         write,ff,format="%s\n", ndate(3);
         close,ff;
         return 0;
      }

      // count the ok flags
      oklist = file_search( "ok*.job",".");
      n_ok = numberof(oklist);

      if( n_ok == n_proc_tot ) {
         // no process found a divisor: we have a prime
         ff = open("nogo.flag","w");
         write,ff,format="%s\n", ndate(3);
         close,ff;
         return 1;
      }
      write,format="Still waiting %i, n_ok = %i/%i ...\n", kount, n_ok, n_proc_tot;
      pause,30000;
   }

}
%FILE% ptest.i
func ptesta( a, b)
{

  extern x, y, z;

  print,"Entered ptesta a,b = ", a, b;
  x = a + b;
  y = a - b;
  z = a * b;
  
  return(1);
}

func ptestb(a)
{

  extern z, x, y;

  print,"ptestb got xyz = ", x, y, z;
  
  return(1);
}
%FILE% quadr_eq.i
func quadr_eq( a, b, c, &x1, &x2 )
/* DOCUMENT status = quadr_eq( a, b, c, >x1, >x2 )

   Solves ax^2 + bx + c = 0
   Returns number of solutions except when
   a = b = c = 0 then any x is a solution
        x1 = x2 = 0.0 and 3 is returned.
   a = b = 0 and c != 0 the no solution
        x1 = x2 = [] and 0 is returned

   x1 and x2 are void if no real solution is found
   or a = b = c = 0

   2009-02-09/NJW
*/
{
   a = double(a);
   b = double(b);
   c = double(c);
   if( a == 0.0 ) {
      if( b == 0.0 ) {
         if( c == 0.0 ) {
            x1 = x2 = 0.0;
            return 3;
         } else {
            x1 = x2 = [];
            return 0;
         }
      } else {
         x1 = x2 = -c/b;
         return 1;
      }
   } else { // standard solution
      discr = b^2 - 4*a*c;
      if( discr < 0.0 ) {
         x1 = x2 = [];
         return 0;
      } else if( discr == 0.0 ) {
         x1 = x2 = -b / (2*a);
         return 1;
      } else {
         q = sqrt(discr);
         x1 = (-b + q) / (2*a);
         x2 = (-b - q) / (2*a);
         return 2;
      }
   }
}
%FILE% quadratic_eq.i
/* Function quadratic_eq */

func quadratic_eq( a, b, c)
/* DOCUMENT solutions = quadratic_eq( a, b, c )

       Returns the two solutions to ax^2 + bx + c = 0

*/
{
   if( a == 0.0 ) {
      if( b == 0.0 ) {
         if( c == 0.0 ) {
            write,"All x are solutions";
         } else {
            write,"No solution!";
         }
         return [];
      } else {
         return (-c/b)*[1.,1.];
      }
   } else {
      discr = b^2 - 4.*a*c;
      if( discr >= 0. ) {
         x1 = (-b + sqrt(discr))/(2.*a);
         x2 = (-b - sqrt(discr))/(2.*a);
         return [x1,x2];
      } else {
         require,"mcomplex.i";
         return nthroot(discr,2);
      }
   }
}
%FILE% qvar.i
func qvar(a=)
/* DOCUMENT qvar, a=

   Display variables (query variables) in current Yorick session.

   Keyword 'a' to be set to see all.
   Default operation is to eliminate all starting with
   '_' and 'Y_' assuming that they are intrinsic variables.

   2010-01-04/NJW
*/
{
   b = createb("_asdf.ysav");
   save, b; // Save all external variables
   close,b;
   b = openb("_asdf.ysav");
   n = get_vars(b);
   close,b;
   remove,"_asdf.ysav";
   varnames = *n(1);
   if( !a ) {
      w = where(strpart(varnames,1:1)!="_");
      if(numberof(w)) varnames = varnames(w);
      else error,"QVAR: No variables to show";
      w = where(strpart(varnames,1:2)!="Y_");
      if(numberof(w)) varnames = varnames(w);
      else error,"QVAR: No variables to show";
   }
   write_slist,"_asdf.txt",varnames;
   arrange_words_in_columns, "_asdf.txt",3,25;
   remove,"_asdf.txt";
}
%FILE% qwf.i
func qwf( image, com= )
/* DOCUMENT qwf, image, com=

   "Quick Write Fits" with the option to add one or more comment lines
   Writes to qwf_xxxx.fits

   Keyword 'com' may be a scalar string or a string array
*/
{
   namestr = get_next_filename("qwf_????.fits");
   if( !is_void(com) ) {
      kwds_init;
      n = numberof(com);
      for( i = 1; i <= n; i++ ) {
         kwds_set,"COMMENT",com(i);
      }
   }
   writefits,namestr,image,clobber=1;
   write,format="The array has been written to: %s\n", namestr;
}
%FILE% r44_plots.i
{
if( is_void(detsig) ) {
   detsig = rscol("c:/work/radec_1.list",3,silent=1);
   offa = rscol("c:/work/radec_1.list",4,silent=1);
   flux1 = rscol("c:/work/radec_1.list",5,silent=1);
   flux2 = rscol("c:/work/radec_1.list",6,silent=1);
   flux3 = rscol("c:/work/radec_1.list",7,silent=1);
   flux4 = rscol("c:/work/radec_1.list",8,silent=1);
   flux5 = rscol("c:/work/radec_1.list",9,silent=1);
   print,"Finished reading arrays ...";
}
window,0,style="boxed.gs";
if( plotnum == 1 ) {
   plmk,detsig,off,marker=5,msize=0.4;
   limits,-0.5,5.5,0,max(detsig)*1.1;
   pltitle,"JMX1 Rev44 Crab";
   xytitles,"Offaxis Angle [deg]","DETSIG";
   hcp_file,"c:/yo/jmx1_detsig_offa.ps";
}
if( plotnum == 2 ) {
   plmk,flux1,off,marker=5,msize=0.4;
   limits,-0.5,5.5,0,max(flux1)*1.1;
   pltitle,"JMX1 Rev44 Crab";
   xytitles,"Offaxis Angle [deg]","Flux 3-6 keV";
   hcp_file,"c:/yo/jmx1_flux1_offa.ps";
}
if( plotnum == 3 ) {
   plmk,flux2,off,marker=5,msize=0.4;
   limits,-0.5,5.5,0,max(flux2)*1.1;
   pltitle,"JMX1 Rev44 Crab";
   xytitles,"Offaxis Angle [deg]","Flux 6-10 keV";
   hcp_file,"c:/yo/jmx1_flux2_offa.ps";
}
if( plotnum == 4 ) {
   plmk,flux3,off,marker=5,msize=0.4;
   limits,-0.5,5.5,0,max(flux3)*1.1;
   pltitle,"JMX1 Rev44 Crab";
   xytitles,"Offaxis Angle [deg]","Flux 10-15 keV";
   hcp_file,"c:/yo/jmx1_flux3_offa.ps";
}
if( plotnum == 5 ) {
   plmk,flux4,off,marker=5,msize=0.4;
   limits,-0.5,5.5,0,max(flux4)*1.1;
   pltitle,"JMX1 Rev44 Crab";
   xytitles,"Offaxis Angle [deg]","Flux 15-35 keV";
   hcp_file,"c:/yo/jmx1_flux4_offa.ps";
}
if( plotnum == 6 ) {
   plmk,flux5,off,marker=5,msize=0.4;
   limits,-0.5,5.5,0,max(flux5)*1.1;
   pltitle,"JMX1 Rev44 Crab";
   xytitles,"Offaxis Angle [deg]","Flux 5-27 keV";
   hcp_file,"c:/yo/jmx1_flux5_offa.ps";
}

hcp;
hcp_finish;
}


%FILE% rab.i
ab = rscol("ab.scm",1,str=1,nomem=1);
a = str2ln(ab(1));
b = str2ln(ab(2));
prln,a;
prln,b;
%FILE% radiate.i
#include "larnum.i"
symbfile = "radiate.txt";
filnavn = "radiate.scm";
symbs = rdfile(symbfile)(1);
nbas = strlen(symbs) + 1;
lnbas = setln(nbas);
csymbs = (*pointer(symbs))(1:-1);

func opret( app= )
{
   mode = app ? "a" : "w";
   fil = open(filnavn,mode);
   superpw = "";
   read,prompt="Skriv super ord : ", superpw;
   sp = til_tal(superpw);

   while(1) {
      huord = psord = "";
      read,prompt="Skriv huske ord : ", huord;
      if( huord == "slut" ) break;
      read,prompt="Skriv pas ord : ", psord;
      pp = til_tal( psord );
      ppp = mul( sp, pp );
      sppp = ln2str( ppp );
      write,fil,format="%s  %s\n", sppp, huord;
   }
   close,fil;
}

func find( chat= )
{
   rstab,filnavn,2,sppp,huord,typ="ss",silent=1;
   n = numberof(huord);
   for( i = 1; i <= n; i++ ) {
      write,format="%4i %s\n", i, huord(i);
   }
   read,prompt="Skriv nummer: ... ", n;
   //+ write,"n = "+itoa(n);
   psord = ""
   read,prompt="Skriv super ord: ... ", psord;
   ps = til_tal(psord);
   if( chat ) {
      write,"Superord: psord -> ps";
      prln, ps;
   }
   ppp = str2ln( sppp(n) );
   if( chat ) {
      write,format=" Valgt ord: (%s) ppp:\n", sppp(n);
      prln,ppp;
   }
   pp = div( ppp, ps, r );
   if( chat ) {
      write,"Resultat af division - pp:";
      prln,pp;
   }
   spp = til_tekst( add(pp,r) );
   write,spp;
}

func til_tal( word ) {
   //+ write,word;
   nword = strlen(word);
   cword = (*pointer(word))(1:-1);
   
   lncal = LNUNIT;
   lnword = LNZERO;
   for( i = 1; i <= nword; i++ ) {
      w = where(cword(i) == csymbs)(1);
      lnnext = setln(w);
      lnnextt = mul( lnnext, lncal );
      lnword = add( lnword, lnnextt );
      lncal = mul(lncal,lnbas);
   }
   //+ prln,lnword;
   return lnword;
}

func til_tekst( lnword )
{
   
   // dechiffrer
   
   crec = [];
   lnrest = LNZERO;
   lna = lnword;
   while( ln_gt( lna, LNZERO ) ) {
      lna = div( lna, lnbas, lnrest );
      //+ w = where( lnrest(1) == isym )(1);
      grow,crec, csymbs(lnrest(1));
   }
   grow, crec, 0;
   word = string(&crec);
   //+ write,word;

   return word;
}

func ttest
{
   //+ randomize;
   for(i=1;i<=10000;i++) {
      n = 4+long(random()*7);
      j = long(random(n)*(nbas-1))+1;
      //+ ord = strjoin( symb(j),"");
      ord = string(&grow(csymbs(j),0));
      //+ write,format="%i tegn i ordet: %s\n", n, ord;
      tord = til_tal(ord);
      dro = til_tekst( tord );
      if( ord != dro ) error,"UPS!";
   }
}
%FILE% random.i
/*
 * $Id: random.i,v 1.1.1.1 2005/09/18 22:06:05 dhmunro Exp $
 * Random numbers with various distributions.
 */
/* Copyright (c) 2005, The Regents of the University of California.
 * All rights reserved.
 * This file is part of yorick (http://yorick.sourceforge.net).
 * Read the accompanying LICENSE file for details.
 */

/* Contents:

   random_x   - avoids the 2.e9 bins of the random function at a
                cost of calling random twice, can be used as a
                drop-in replacement for random
   random_u   - convenience routine to give uniform deviate on an
                interval other than (0,1)
   random_n   - return gaussian deviate
   random_ipq - arbitrary piecewise linear deviate, with optional
                power law or exponential tails
   random_rej - generic implementation of rejection method, can be
                used either in conjunction with a piecewise linear
                bounding function, or an arbitrary bounding function
                (in the latter case, the inverse of the integral of
                the bounding function must be supplied as well)
   poisson    - return poisson deviate

   In all cases, these routines accept a dimlist or arguments to
   determine the dimensions of the returned random deviates.
   Furthermore, in all cases you will get back the same sequence
   of deviates no matter what the dimensionality of the calls --
   for example, if at some point the call to random_n(5) returns
   [.3,-.1,-.8,1.1,-.9], then if instead random_n(3) followed by
   random_n(2) had been called, the return values would have been
   [.3,-.1,-.8] and [1.1,-.9].
 */

/* ------------------------------------------------------------------------ */

func build_dimlist(&dimlist, arg)
/* DOCUMENT build_dimlist, dimlist, next_argument
     build a DIMLIST, as used in the array function.  Use like this:

     func your_function(arg1, arg2, etc, dimlist, ..)
     {
       while (more_args()) build_dimlist, dimlist, next_arg();
       ...
     }

     After this, DIMLIST will be an array of the form
     [#dims, dim1, dim2, ...], compounded from the multiple arguments
     in the same way as the array function.  If no DIMLIST arguments
     given, DIMLIST will be [] instead of [0], which will act the
     same in most situations.  If that possibility is unacceptible,
     you may add
       if (is_void(dimlist)) dimlist= [0];
     after the while loop.
 */
{
  if (is_void(dimlist)) dimlist= [0];
  else if (!dimsof(dimlist)(1)) dimlist= [1,dimlist];
  if (is_void(arg)) return;
  if (!dimsof(arg)(1)) {
    grow, dimlist, arg;
    dimlist(1)+= 1;
  } else {
    n= arg(1);
    grow, dimlist, arg(2:1+n);
    dimlist(1)+= n;
  }
}

/* ------------------------------------------------------------------------ */

func random_x(dimlist, ..)
/* DOCUMENT random_x(dimlist)

     same as random(DIMLIST), except that random_x calls random
     twice at each point, to avoid the defect that random only
     can produce about 2.e9 numbers on the interval (0.,1.) (see
     random for an explanation of these bins).

     You may set random=random_x to get these "better" random
     numbers in every call to random.

     Unlike random, there is a chance in 1.e15 or so that random_x
     may return exactly 1.0 or 0.0 (the latter may not be possible
     with IEEE standard arithmetic, while the former apparently is).
     Since cosmic rays are far more likely, you may as well not
     worry about this.  Also, because of rounding errors, some bit
     patterns may still be more likely than others, but the 0.5e-9
     wide bins of random will be absent.

   SEE ALSO: random
 */
{
  while (more_args()) build_dimlist, dimlist, next_arg();
  if (is_void(dimlist)) {
    dimlist= [1,2];
  } else if (!dimsof(dimlist)(1)) {
    dimlist= [2,2,dimlist];
  } else {
    dimlist= grow([dimlist(1)+1],dimlist);
    dimlist(2)= 2;
  }
  r= random_0(dimlist);
  return r(1,..) + (r(2,..)-0.5)/2147483562.
}

if (is_void(random_0)) random_0= random;

/* ------------------------------------------------------------------------ */

func random_u(a, b, dimlist, ..)
/* DOCUMENT random_u(a, b, dimlist)

     return uniformly distributed random numbers between A and B.
     (Will never exactly equal A or B.)  The DIMLIST is as for the
     array function.  Same as (b-a)*random(dimlist)+a.  If A==0,
     you are better off just writing B*random(dimlist).

   SEE ALSO: random, random_x, random_n, random_ipq, random_rej
*/
{
  while (more_args()) build_dimlist, dimlist, next_arg();
  return (b-a)*random(dimlist)+a;
}

/* ------------------------------------------------------------------------ */

func random_n(dimlist, ..)
/* DOCUMENT random_n(dimlist)

     returns an array of normally distributed random double values with
     the given DIMLIST (see array function, nil for a scalar result).
     The mean is 0.0 and the standard deviation is 1.0.
     The algorithm follows the Box-Muller method (see Numerical Recipes
     by Press et al.).

   SEE ALSO: random, random_x, random_u, random_ipq, random_rej, poisson
*/
{
  while (more_args()) build_dimlist, dimlist, next_arg();
  a= array(0.0, dimlist);
  scalar= !dimsof(a)(1);
  if (scalar) a= [a];  /* work around long-standing Yorick bug */

  /* crucial feature of this algorithm is that the same sequence
   * of random numbers is returned independent of the number requested
   * each time, just like random itself */
  na= numberof(a);
  np= numberof(_random_n_prev);
  n= (na-np+1)/2;
  nr= 2*n;
  if (n) {
    x= random(2,n);
    r= sqrt(-2.0*log(x(1,)));
    theta= 2.0*pi*x(2,);
    x(1,)= r*cos(theta);
    x(2,)= r*sin(theta);
    a(np+1:na)= x(1:na-np);
  }
  if (np) {
    a(1)= _random_n_prev;
    _random_n_prev= [];
  }
  if (na-np<nr) {
    _random_n_prev= x(nr);
  }

  if (scalar) a= a(1);  /* work around long-standing Yorick bug */
  return a;
}

/* storage for odd random_n values */
_random_n_prev= [];

/* ------------------------------------------------------------------------ */

func random_ipq(model, dimlist, ..)
/* DOCUMENT random_ipq(ipq_model, dimlist)

     returns an array of double values with the given DIMLIST (see array
     function, nil for a scalar result).  The numbers are distributed
     according to a piecewise linear function (possibly with power law
     or exponential tails) specified by the IPQ_MODEL.  The "IPQ" stands
     for "inverse piecewise quadratic", which the type of function
     required to transform a uniform random deviate into the piecewise
     linear distribution.  Use the ipq_setup function to compute
     IPQ_MODEL.

   SEE ALSO: random, random_x, random_u, random_n, random_rej, ipq_setup
 */
{
  while (more_args()) build_dimlist, dimlist, next_arg();
  ymax= (*model(4))(1);
  return ipq_compute(model, ymax*random(dimlist));
}

func random_rej(target, bound, dimlist, ..)
/* DOCUMENT random_rej(target_dist, ipq_model, dimlist)
         or random_rej(target_dist, bounding_dist, bounding_rand, dimlist)

     returns an array of double values with the given DIMLIST (see array
     function, nil for a scalar result).  The numbers are distributed
     according to the TARGET_DIST function:
        func target_dist(x)
     returning u(x)>=0 of same number and dimensionality as x, normalized
     so that the integral of target_dist(x) from -infinity to +infinity
     is 1.0.  The BOUNDING_DIST function must have the same calling
     sequence as TARGET_DIST:
        func bounding_dist(x)
     returning b(x)>=u(x) everywhere.  Since u(x) is normalized, the
     integral of b(x) must be >=1.0.  Finally, BOUNDING_RAND is a
     function which converts an array of uniformly distributed random
     numbers on (0,1) -- as returned by random -- into an array
     distributed according to BOUNDING_DIST:
        func bounding_rand(uniform_x_01)
     Mathematically, BOUNDING_RAND is the inverse of the integral of
     BOUNDING_DIST from -infinity to x, with its input scaled to (0,1).

     If BOUNDING_DIST is not a function, then it must be an IPQ_MODEL
     returned by the ipq_setup function.  In this case BOUNDING_RAND is
     omitted -- ipq_compute will be used automatically.

   SEE ALSO: random, random_x, random_u, random_n, random_ipq, ipq_setup
 */
{
  if (is_func(bound)) {
    brand= dimlist;
    dimlist= more_args()? next_arg() : [];
  }
  while (more_args()) build_dimlist, dimlist, next_arg();
  if (!is_func(target) || (!is_void(brand) && !is_func(brand)) ||
      (!is_func(bound) && structof(bound)!=pointer))
    error, "improper calling sequence, try help,random_rej";
  if (!is_func(bound)) ymax= (*bound(4))(1);

  /* build result to requested shape */
  x= array(0.0, dimlist);
  nreq= nx= numberof(x);
  ix= 1;

  do {
    /* get 25% more pairs of random numbers than nreq in order
     * to allow for some to be rejected -- should actually go for
     * integral(bounding_dist) times nreq, but don't know what
     * that is -- could refine the estimate as each pass gets a
     * better notion of the fraction rejected, but don't bother */
    r= random(2, max(nreq+nreq/4,10));

    /* first get xx distributed according to bounding_rand,
     * then accept according to the second random number
     * continue until at least one is accepted */
    for (xx=[] ; !numberof(xx) ; xx=xx(list)) {
      if (is_func(bound)) {
        xx= brand(r(1,..));
        list= where(bound(xx)*r(2,..) <= target(xx));
      } else {
        xx= ipq_compute(bound, ymax*r(1,..));
        list= where(ipq_function(bound,xx)*r(2,..) <= target(xx));
      }
    }
    nxx= numberof(xx);
    if (nxx>nreq) {
      xx= xx(1:nreq);
      nxx= nreq;
    }

    nreq-= nxx;
    x(ix:nx-nreq)= xx;
    ix+= nxx;
  } while (nreq);

  return x;
}

func ipq_setup(x,u,power=,slope=)
/* DOCUMENT model= ipq_setup(x, u)
         or model= ipq_setup(x, u, power=[pleft,prght])
         or model= ipq_setup(x, u, power=[pleft,prght], slope=[sleft,srght])

     compute a model for the ipq_compute function, which computes the
     inverse of a piecewise quadratic function.  This function occurs
     when computing random numbers distributed according to a piecewise
     linear function.  The piecewise linear function is u(x), determined
     by the discrete points X and U input to ipq_setup.  None of the
     values of U may be negative, and X must be strictly increasing,
     X(i)<X(i+1).

     If U(1) or U(0) is not zero, you may want to model the "tail" of
     the distribution, which is not well modeled by a piecewise linear
     function.  You can specify a power law tail using the power=
     keyword; the left tail has initial slope (U(2)-U(1))/(X(2)-X(1)),
     and decays to the left as 1/X^PLEFT.  Similarly for the right tail.
     If U(1)==0, PLEFT is ignored, as is PRGHT when U(0)==0.  Use the
     slope= keyword to specify an alternative value for the slope.
     Note that PLEFT and PRGHT must each be greater than 1.0, and that
     SLEFT>0 while SRGHT<0.  If either power is greater than or equal to
     100, an exponential tail will be used.  As a convenience, you may
     also specify PLEFT or PRGHT of 0 to get an exponential tail.

     Note: ipq_function(model, xp) returns the function values u(xp) at
     the points xp, including the tails (if any).  ipq_compute(model, yp)
     returns the xp for which (integral from -infinity to xp) of u(x)
     equals yp; i.e.- the inverse of the piecewise quadratic.

   SEE ALSO: random_ipq, random_rej
 */
{
  x= double(x);
  u= double(u);
  if (dimsof(x)(1)!=1 || numberof(x)<2 || dimsof(u)(1)!=1 ||
      numberof(u)!=numberof(x) || anyof(u<0.)) error, "bad U or X arrays";

  /* compute the integral of u(x), starting from x(1),
   * both at the given points x and at the midpoints of the intervals
   * integ(u,x,xx) is the basic piecewise quadratic function */
  bins= (u(zcen)*x(dif))(cum);
  cens= x(pcen);  /* right shape, wrong values */
  yc= integ(u,x, x(zcen));
  dy= bins(dif);
  /* note that these cens are constrained to lie between -1 and +1 */
  cens(2:-1)= 4.*(yc-bins(1:-1))/(dy+!dy) - 2.;

  ymax= bins(0);

  if (!is_void(power)) {
    if (dimsof(power)(1)!=1 || numberof(power)!=2 ||
        anyof(power<=1.&power!=0.)) error, "illegal power= keyword";
    if (!power(1) || !u(1)) power(1)= 100.;
    if (!power(0) || !u(0)) power(0)= 100.;

    if (is_void(slope))
      slope= [(u(2)-u(1))/(x(2)-x(1)), (u(0)-u(-1))/(x(0)-x(-1))];
    if (dimsof(slope)(1)!=1 || numberof(slope)!=2 ||
        slope(1)<0. || slope(0)>0.)
      error, "illegal slope= keyword, or upward slope at endpoint";

    cens(1)= u(1)? slope(1)/u(1) : 1000./(x(2)-x(1));
    cens(0)= u(0)? -slope(0)/u(1) : 1000./(x(0)-x(-1));
    yi= u(1)/cens(1);
    if (power(1)<100.) yi*= power(1)/(power(1)-1.);
    ymax+= yi;
    bins+= yi;
    yi= u(0)/cens(0);
    if (power(0)<100.) yi*= power(0)/(power(0)-1.);
    ymax+= yi;

  } else {
    power= [100.,100.];
    cens(1)= 1000./(x(2)-x(1));
    cens(0)= 1000./(x(0)-x(-1));
  }

  parm= [ymax, power(1), power(0)];

  return [&bins, &x, &cens, &parm, &u];
}

/* ------------------------------------------------------------------------ */

func ipq_compute(model, y)
{
  /*
   * model= [&bins, &vals, &cens, &parm] where:
   * bins   values of y, a piecewise quadratic function of x
   * vals   values of x that go with bins
   * cens   4*(yc-y0)/(y1-y0) - 2 where yc is value of y at
   *             x=vals(pcen), except for first and last points
   *             which are du/dx / u0 for the extrapolation model
   * parm   [ymax, left_power, right_power]
   *             maximum possible value of y, and
   *             [left,right] powers (>1.0) of x for extrap. model
   */
  local bins, vals, cens, parm;
  eq_nocopy, bins, *model(1);
  eq_nocopy, vals, *model(2);
  eq_nocopy, cens, *model(3);
  eq_nocopy, parm, *model(4);

  i= digitize(y, bins);

  mask0= (i>1);
  list= where(mask0);
  if (numberof(list)) {
    yy= y(list);
    ii= i(list);
    mask= (ii<=numberof(bins));
    list= where(mask);
    if (numberof(list)) {
      /* handle piecewise quadratic part */
      j= ii(list);
      yb= bins(j);
      xb= vals(j);
      aa= cens(j);   /* 4*(yc-y0)/(y1-y0) - 2 */
      j-= 1;
      ya= bins(j);
      xa= vals(j);
      bb= 0.5*(1.+aa);
      yq= (yy(list)-ya)/(yb-ya);
      xq= bb+sqrt(bb*bb-aa*yq);
      xq= xa + (xb-xa)*( yq/(xq+!xq) );
    }

    list= where(!mask);
    if (numberof(list)) {
      /* handle right tail */
      ymax= parm(1);
      if (ymax > bins(0)) {
        yy= (ymax - yy(list))/(ymax - bins(0));
        xa= vals(0);
        aa= cens(0);    /* du/dx / u0 */
        pp= parm(2);    /* power */
        yy0= yy<=0.0;
        yy= max(yy,0.0)+yy0;
        if (pp>=100.) xt= -log(yy)/aa;
        else xt= (pp/aa) * (yy^(1./(1.-pp)) - 1.0);
        xt+= xa + 1.e9*yy0*(xa-vals(1));
      } else {
        xt= array(vals(0), numberof(list));
      }
    }

    xq= merge(xq, xt, mask);
  }

  list= where(!mask0);
  if (numberof(list)) {
    /* handle left tail */
    if (bins(1)) {
      yy= y(list)/bins(1);
      xa= vals(1);
      aa= cens(1);    /* du/dx / u0 */
      pp= parm(3);    /* power */
      yy0= yy<=0.0;
      yy= max(yy,0.0)+yy0;
      if (pp>=100.) xt= log(yy)/aa;
      else xt= (pp/aa) * (1.0 - yy^(1./(1.-pp)));
      xt+= xa - 1.e9*yy0*(vals(0)-xa);
    } else {
      xt= array(vals(1), numberof(list));
    }
  } else {
    xt= [];
  }

  return merge(xq, xt, mask0);
}

func ipq_function(model, x)
{
  /*
   * model= [&bins, &vals, &cens, &parm, &valu] where:
   * bins   values of y, a piecewise quadratic function of x
   * vals   values of x that go with bins
   * cens   4*(yc-y0)/(y1-y0) - 2 where yc is value of y at
   *             x=vals(pcen), except for first and last points
   *             which are du/dx / u0 for the extrapolation model
   * parm   [ymax, left_power, right_power]
   *             maximum possible value of y, and
   *             [left,right] powers (>1.0) of x for extrap. model
   * valu   values of u that go with x
   */
  local vals, cens, parm, valu;
  eq_nocopy, vals, *model(2);
  eq_nocopy, cens, *model(3);
  eq_nocopy, parm, *model(4);
  eq_nocopy, valu, *model(5);

  i= digitize(x, vals);

  mask0= (i>1);
  list= where(mask0);
  if (numberof(list)) {
    xx= x(list);
    ii= i(list);
    mask= (ii<=numberof(vals));
    list= where(mask);
    if (numberof(list)) {
      /* handle piecewise linear part */
      uq= interp(valu, vals, xx(list));
    }

    list= where(!mask);
    if (numberof(list)) {
      /* handle right tail */
      if (valu(0)) {
        xx= xx(list) - vals(0);
        aa= cens(0);    /* du/dx / u0 */
        pp= parm(2);    /* power */
        if (pp>=100.) ut= valu(0)*exp(-aa*xx);
        else ut= valu(0) / (1. + (aa/pp)*xx)^pp;
      } else {
        ut= array(0.0, numberof(list));
      }
    }

    uq= merge(uq, ut, mask);
  }

  list= where(!mask0);
  if (numberof(list)) {
    /* handle left tail */
    if (valu(1)) {
      xx= vals(1) - x(list);
      aa= cens(1);    /* du/dx / u0 */
      pp= parm(3);    /* power */
      if (pp>=100.) ut= valu(1)*exp(-aa*xx);
      else ut= valu(1) / (1. + (aa/pp)*xx)^pp;
    } else {
      ut= array(0.0, numberof(list));
    }
  } else {
    ut= [];
  }

  return merge(uq, ut, mask0);
}

/* ------------------------------------------------------------------------ */

_poiprev = 0;

func poisson(navg)
/* DOCUMENT poisson(navg)

     returns a Poisson distributed random value with mean NAVG.
     (This is the integer number of events which actually occur
      in some time interval, when the probability per unit time of
      an event is constant, and the average number of events during
      the interval is NAVG.)
     The return value has the same dimensions as the input NAVG.
     The return value is an integer, but its type is double.
     The algorithm is taken from Numerical Recipes by Press, et. al.

   SEE ALSO: random, random_n
 */
{
  if (!_poiprev) require, "gamma.i";
  navg = double(navg);
  is_scalar = !dimsof(navg)(1);
  if (is_scalar) navg = [navg];

  mask = navg < 12;

  list = where(mask);
  if (numberof(list)) {
    n = exp(-navg(list));
    rlo = 0.*n;
    master = indgen(numberof(n));
    t = random(numberof(n));
    for (;;) {
      list = where(t > n);
      if (!numberof(list)) break;
      t = t(list) * random(numberof(list));
      n = n(list);
      master = master(list);
      rlo(master) += 1.;
    }
  }

  list = where(!mask);
  if (numberof(list)) {
    r = navg = double(navg(list));
    master = indgen(numberof(r));
    sq = sqrt(2.*navg);
    alxm = log(navg);
    g = navg*alxm - lngamma(navg+1.);
    n = navg;
    for (;;) {
      nn = n;
      rr = y = array(0., numberof(master));
      for (sub=indgen(numberof(rr)) ;; sub=sub(list)) {
        y(sub) = yy = tan(pi*random(numberof(sub)));
        rr(sub) = rs  =sq(sub)*yy + nn;
        list = where(rs < 0.);
        if (!numberof(list)) break;
        nn = nn(list);
      }
      r(master) = rr = floor(rr);
      t = 0.9*(1.+y*y)*exp(rr*alxm-lngamma(rr+1.)-g);
      list = where(random(numberof(t)) > t);
      if (!numberof(list)) break;
      master = master(list);
      n = n(list);
      sq =sq(list);
      alxm = alxm(list);
      g = g(list);
    }
  }

  r = merge(rlo, r, mask);
  if (is_scalar) r = r(1);
  return r;
}

/* ------------------------------------------------------------------------ */
%FILE% random_i.i
func random_i( i1, i2, n )
/* DOCUMENT   res = random_i( i1, i2, n )
        or    res = random_i( i2, n )
        or    res = random_i( i2 )

    return 'n' random long integers between i1 and i2 (included).
    In the second form i1 is set to 1 (one). In the third form
    a single long integer between 1 and i2 is returned.

    2012-12-07/NJW
*/
{
   if( is_void(i1) ) error,"At least one argument must be given";
   if( is_void(i2) ) { // Third form
      i2 = i1;
      i1 = 1;
   } else {
      if( is_void(n) ) { // Second form
         n = i2;
         i2 = i1;
         i1 = 1;
      }
   }
   if( !is_void(n) && n == 1 ) n = [];
   return long(random(n)*(i2 - i1 + 1) + i1);
}
%FILE% rd_phai_spectrum.i
/* Function rd_phai_spectrum */

struct s_Spectrum {
   long n; // number of channels
   pointer rate; // RATE i.e. countrate per channel
   pointer stat_err; // STAT_ERR i.e. 1 sigma error of RATE
   pointer e_min; // E_MIN from EBOUNDS
   pointer e_max; // E_MAX from EBOUNDS
   pointer energ_lo; // ENERG_LO for ARF
   pointer energ_hi; // ENERG_HI for ARF
   string rmf; // RMF file
   string arf; // ARF (Anchor) file
}

func rd_phai_spectrum( dol_or_filename )
/* DOCUMENT res = rd_phai_spectrum( dol_or_filename )

     Returns a spectrum in the struct 'res' with elements:
        n      : (long) number of channels
        rate   : (pointer) The RATE array
        stat_err: (pointer) the STAT_ERR array
        rmf    : (string) RMF file
        arf    : (string) ARF
*/
{
   local dol, extno;

   get_exten_no, dol_or_filename, dol, extno;
   if( !file_test(dol) ) error,dol+" was not found.";
   res = s_Spectrum();
   if( extno == 0 ) dol += "+1"; // default extension number for spectrum
   hdr = headfits( dol );
   rmf_file = fxpar( hdr, "RESPFILE" );
   if( is_void(rmf_file) ) res.rmf = "";
   else {
      res.rmf = rmf_file;
      a = rdfitscol( rmf_file+"[EBOUNDS]", "e_min" );
      res.e_min = &a;
      a = rdfitscol( rmf_file+"[EBOUNDS]", "e_max" );
      res.e_max = &a;
   }
   arf_file = fxpar( hdr, "ANCRFILE" );
   if( is_void(arf_file) ) res.arf = "";
   else {
      res.arf = arf_file;
      a = rdfitscol( rmf_file+"[MATRIX]", "energ_lo" );
      res.energ_lo = &a;
      a = rdfitscol( rmf_file+"[MATRIX]", "energ_lo" );
      res.energ_hi = &a;
  }
   rate = rdfitscol( dol, "rate" );
   res.n = numberof(rate);
   stat_err = rdfitscol( dol, "stat_err" );
   res.rate = &rate;
   res.stat_err = &stat_err;

   return res;
}

/* Function plot_phai_spectrum */

func plot_phai_spectrum( res, itype=, xr=, yr=, color= )
/* DOCUMENT plot_phai_spectrum

       plot_phai_spectrum, res, color=, itype=, xr=, yr=

       where 'res' is the struct e.g. as returned from 'rd_phai_spectrum'.
*/
{
   plot_spectrum, *res.e_min, *res.e_max, *res.rate, *res.stat_err, itype=itype, \
            xr=xr, yr=yr, color=color;
}

/* Function oplot_phai_spectrum */

func oplot_phai_spectrum( res, color= )
/* DOCUMENT oplot_phai_spectrum

       oplot_phai_spectrum, res, color=

       where 'res' is the struct e.g. as returned from 'rd_phai_spectrum'.
*/
{
   oplot_spectrum, *res.e_min, *res.e_max, *res.rate, *res.stat_err, color=color;
}
%FILE% read_energ_data.i
/* Function read_energ_data */

struct s_DATA {
   double elo;
   double ehi;
   double el;
   double data;
}
func read_energ_data( dol, colname )
/* DOCUMENT r = read_energ_data( dol, colname )

     Returns struct s_DATA with elements 'elo', 'ehi', 'el', and 'data'.

     SEE ALSO: rd_arf (xray.i), read_arf (rmf_funcs.i)

*/
{
   local filename, extno;

   get_exten_no, dol, filename, extno;
   if( extno == 0 ) dol = dol+"+1";
   if( !file_test(filename) ) error,filename+" was not found!";

   elo = rdfitscol( dol, "energ_lo");
   res = array( s_DATA, numberof(elo) );
   res.elo = elo;
   res.ehi = rdfitscol( dol, "energ_hi");
   res.data = rdfitscol( dol, colname);
   res.el = 0.5*( res.elo + res.ehi );

   return res;
}
%FILE% read_master_table.i
func read_master_table( fm= )
/* DOCUMENT read_master_table, fm=

    A NuSTAR function for MT_RAYOR. Reads the information in the
    Master_Table_120117.txt originally produced by Anne Fabricant,
    and updated by Nicolai Brejnholt
    for the mirror positions in the flight modules and in the
    coating chamber.

    Master_Table_120117.txt has
    extra 'dummy' information for the DW (Dave Windt) coated mirrors
    to make it readable by e.g. rstab and rscol in Yorick.

    Setting the keyword 'fm' (flight model) to 1 or 2 will limit the
    arrays to the requested optic.

   2011-07-01/NJW, updated with new Master Table 2011-11-24/NJW
*/
{
   savename = "/home/njw/nustar/MT120117.ysav";
   if( file_test(savename) ) {
      write,"Restoring from MT120117.ysav ...";
      f = openb(savename);
      restore, f;
      close,f;
   } else {  // Create it
      write,"Reading /home/njw/nustar/Master_Table_120117.txt ...";
      rstab,"/home/njw/nustar/Master_Table_120117.txt", 13, MTF_glass,MTF_location,MTF_optic, \
            MTF_layer, MTF_uplo, MTF_pos_in_optic, MTF_run_number, MTF_recipe, MTF_witness, \
            MTF_poschamb, MTF_separ, MTF_mount_plate, MTF_pos_on_plate, \
            typ="-sssisi-iissiii";
      write,"Reading finished";
      f = createb(savename);
      save, f, MTF_glass,MTF_location,MTF_optic, MTF_layer, MTF_uplo, MTF_pos_in_optic, MTF_run_number, \
               MTF_recipe, MTF_witness, MTF_poschamb, MTF_separ, MTF_mount_plate, MTF_pos_on_plate;
      close,f;
   }
   write,"Variables are:";
   write,"  MTF_glass(s)         MTF_location(s)     MTF_optic(s)       MTF_layer(i)    MTF_uplo(s)";
   write,"  MTF_pos_in_optic(i)  MTF_run_number(i)   MTF_recipe(i)      MTF_witness(s)  MTF_poschamb(s)";
   write,"  MTF_separ(i)         MTF_mount_plate(i)  MTF_pos_on_plate(i)";

   if( fm ) {
      n = numberof(MTF_glass);
      if( fm == 1 ) {
         idx = indgen(1:n/2);
      } else {
         idx = indgen(n/2+1:n);
      }
      MTF_glass = MTF_glass(idx);
      MTF_location = MTF_location(idx);
      MTF_optic = MTF_optic(idx);
      MTF_layer = MTF_layer(idx);
      MTF_uplo = MTF_uplo(idx);
      MTF_pos_in_optic = MTF_pos_in_optic(idx);
      MTF_run_number = MTF_run_number(idx);
      MTF_recipe = MTF_recipe(idx);
      MTF_witness = MTF_witness(idx);
      MTF_poschamb = MTF_poschamb(idx);
      MTF_separ = MTF_separ(idx);
      MTF_mount_plate = MTF_mount_plate(idx);
      MTF_pos_on_plate = MTF_pos_on_plate(idx);
      write,"Confined to FM"+itoa(fm);
   }
}
%FILE% read_photonfile.i
/* Function read_photonfile */

struct s_Photonfile {
   double detx;
   double dety;
   double rayx;
   double rayy;
   double rayz;
   double angle_in1;
   double angle_out1;
   double angle_in2;
   double angle_out2;
   double azimuth;
   long mirror;
   double energy;
   double rcoef;
   long status;
   long bounce;
   double i1z;
   double i2z;
}

func read_photonfile( filename, sel=, bsel= )
/* DOCUMENT struct_arr = read_photonfile( filename, sel=, bsel= )

    returns an array of structs: s_Photonfile
    where 'sel' selects the status values, and 'bsel' selects the bounce values.

   DETX       DETY        RAYX     RAYY    RAYZ    ANGLE_IN1  ANGLE_OUT1
   ANGLE_IN2  ANGLE_OUT2  AZIMUTH  MIRROR  ENERGY  RCOEF      STATUS
   BOUNCE     I1Z         I2Z
*/
{
   local fh, nrows;

   ptr = rdfitsbin( filename+"+1", fh, nrows );
   if( !is_void(sel) ) {
      w = where( *ptr(fits_colnum(fh,"status")) == sel );
      if( !numberof(w) ) error,"No photons survived the status selection";
   } else w = indgen(nrows);
   if( !is_void(bsel) ) {
      q = where( (*ptr(fits_colnum(fh,"bounce")))(w) == bsel );
      if( !numberof(q) ) error,"No photons survived the bounce selection";
   } else q = indgen(numberof(w));
   nq = numberof(q);

   res = array(s_Photonfile, nq);
   res.detx = (*ptr(fits_colnum(fh,"detx")))(w(q));
   res.dety = (*ptr(fits_colnum(fh,"dety")))(w(q));
   res.rayx = (*ptr(fits_colnum(fh,"rayx")))(w(q));
   res.rayy = (*ptr(fits_colnum(fh,"rayy")))(w(q));
   res.rayz = (*ptr(fits_colnum(fh,"rayz")))(w(q));
   res.angle_in1 = (*ptr(fits_colnum(fh,"angle_in1")))(w(q));
   res.angle_out1 = (*ptr(fits_colnum(fh,"angle_out1")))(w(q));
   res.angle_in2 = (*ptr(fits_colnum(fh,"angle_in2")))(w(q));
   res.angle_out2 = (*ptr(fits_colnum(fh,"angle_out2")))(w(q));
   res.azimuth = (*ptr(fits_colnum(fh,"azimuth")))(w(q));
   res.mirror = (*ptr(fits_colnum(fh,"mirror")))(w(q));
   res.energy = (*ptr(fits_colnum(fh,"energy")))(w(q));
   res.status = (*ptr(fits_colnum(fh,"status")))(w(q));
   res.bounce = (*ptr(fits_colnum(fh,"bounce")))(w(q));
   res.i1z = (*ptr(fits_colnum(fh,"i1z")))(w(q));
   res.i2z = (*ptr(fits_colnum(fh,"i2z")))(w(q));

   return res;
}
%FILE% rebin_specrmf.i
/*******************************************************
  Rebin both a spectrum in PHAII format and the RDM in
  an RMF file

  2012-12-20/NJW
*********************************************************/

func rebin_specrmf( specfile, rmffile=, rebin=, frac=, outspecfile=, outrmffile= )
/* DOCUMENT rebin_specrmf, specfile, rmffile=, rebin=, frac=, outspecfile=, outrmffile=
           rebin = frac=, outspecfile=, outrmffile=

     The spectrum is assumed to be found in a PHAII format file.

     Default is to use 'RESPFILE' in specfile as the RMF, this is overridden by
          giving 'rmffile'

     'rebin' overrides 'frac'

     NB! The present version only works on the first spectrum in the file.
*/
{
   local ob1, ob2, orate, orate_err;

   if( !file_test(specfile) ) error,"File not found";

   rate = rdfitscol(specfile+"+1","rate")(,1);
   stat_err = rdfitscol(specfile+"+1","stat_err")(,1);
   ancrfile = rdfitscol(specfile+"+1","ancrfile")(1);
   name = rdfitscol(specfile+"+1","rowid")(1);
   ra_obj = rdfitscol(specfile+"+1","ra_obj")(1);
   dec_obj = rdfitscol(specfile+"+1","dec_obj")(1);
   exposure = rdfitscol( specfile+"+1", "exposure")(1);
   hdr = headfits(specfile+"+1");
   instrume = fxpar( hdr, "instrume")(1);
   telescop = fxpar( hdr, "telescop");

   if( is_void(rmffile) ) rmffile = fxpar( hdr, "RESPFILE" );

   dol = rmffile+"[MATRIX]";
   rdm = rdfitscol(dol,"MATRIX");
   elo = rdfitscol(dol,"ENERG_LO");
   ehi = rdfitscol(dol,"ENERG_HI");
   n_grp = rdfitscol(dol,"N_GRP");
   f_chan = rdfitscol(dol,"F_CHAN");
   n_chan = rdfitscol(dol,"N_CHAN");
   dol = rmffile+"[EBOUNDS]";
   e_min = rdfitscol(dol,"E_MIN");
   e_max = rdfitscol(dol,"E_MAX");

   if( is_void(rebin) ) { // Then create the 'rebin' array
      if( is_void(frac) ) frac = 0.2; // some reasonable value
      rebin = specrebinninga( e_min, e_max, rate, stat_err, frac, ob1, ob2, orate, orate_err );
   } else {   // apply the 'rebin' array directly
      write,"Applying the rebin array ...";
      specrebinning, e_min, e_max, rate, stat_err, rebin, ob1, ob2, orate, orate_err
   }

   // test for negative values except at the end of 'rebin'
   w = where(rebin <= 0);
   nw = numberof(w);
   if( nw ) {
      if( nw == 1 ) if( w(1) != numberof(rebin) ) error,"##1## dodgy rebin array";
      if( w(1) < numberof(rebin)/2 ) error,"##2## dodgy rebin array";
   }

   // Write the spectral file with rebinned spectra

   if( is_void(outspecfile) ) {
      p = strpos( specfile, ".", rev=1 );
      outspecfile = strinsert( specfile, "_rebin", p );
   }
   write,"outspecfile = "+outspecfile;
   if( is_void(outrmffile) ) {
      p = strpos( rmffile, ".", rev=1 );
      outrmffile = strinsert( rmffile, "_rebin", p );
   }
   fits_copy_keys, hdr, tokwds=1;

   spec2phaii, outspecfile, orate, orate_err, \
      type="net", name=name, ra_obj=ra_obj, dec_obj=dec_obj, \
      exposure=exposure, \
      ancrfile=ancrfile, \
      respfile=outrmffile, \
      telescop=telescop, instrume=instrume;
   write,"Wrote "+outspecfile;

   // Check if the suggested RMF file with the rebinned RDM already
   // exists and with the same rebinning

   write,"outrmffile = "+outrmffile;

   rewrite = 1;
   if( file_test( outrmffile) ) {
      write,"Found "+outrmffile;
      exist_rebin = rdfitscol( outrmffile+"[REBIN]", "rebin" );
      write,"numberof(rebin) = "+itoa(numberof(rebin));
      write,"numberof(exist_rebin) = "+itoa(numberof(exist_rebin));
      if( numberof(rebin) == numberof(exist_rebin) ) {
         write,"max(abs(rebin-exist_rebin)) = "+itoa(max(abs(rebin-exist_rebin)));
         if( noneof(rebin - exist_rebin) ) rewrite = 0;
      }
   }
   write,"'rewrite' = "+itoa(rewrite);

   if( rewrite ) {

      // Write the RMF file with rebinned RDM
      write,"Going to write "+outrmffile;

      rebinx = rebin;
      newrdm = rebin_rdm( rdm, rebinx );
      dms = dimsof(newrdm);

      dol = rmffile+"[MATRIX]";
      hdr = headfits(dol);
      fits_copy_keys,hdr,tokwds=1;
      n_chan() = dms(2);
      kwds_set,"DETCHANS", dms(2),"Number of detector channels";

      fh = wrmfitscols( outrmffile, "ENERG_LO",elo,"ENERG_HI",ehi,"N_GRP",n_grp, \
              "F_CHAN", f_chan, "N_CHAN", n_chan, "MATRIX", newrdm, cont=1, clobber=1 );

      // Write the EBOUNDS extension

      dol = rmffile+"[EBOUNDS]";
      hdr = headfits(dol);
      fits_copy_keys,hdr,tokwds=1;
      kwds_set,"DETCHANS", dms(2),"Number of detector channels";
      fh = wrmfitscols( fh, "E_MIN", ob1, "E_MAX", ob2, cont=1 );

      // Write extra REBIN extension with rebinning array

      kwds_set,"EXTNAME","REBIN","Name of this extension";
      wrmfitscols, fh, "REBIN", rebin;
      write,"Wrote "+outrmffile;

   } else write,"No rewriting required ...";

   return rebin;

}
%FILE% rectify_columns.i
func rectify_columns( text_file, outfile )
/* DOCUMENT rectify_columns, text_file[, outfile]

   Assumes that 'text_file' contains columns where
   each column has no space (blank) but the column
   separator is one or more spaces.
   Then the output file (same as 'text_file' if
   'outfile' is not given) will have nicely ordered columns.

   a         b c
   history failure       boulder
   well               solemn where

   becomes

   a        b        c
   history  failure  boulder
   well     solemn   where

   Empty input lines are skipped.

   2010-09-10/NJW
*/
{
   text = rdfile(text_file);
   ntext = numberof(text);
   // Use first line to find number of columns
   s = strsplit( text(1)," ");
   ncols = numberof(s);
   width = array(long, ncols-1);
   cols = array(string,ntext,ncols);

   lines = array(string, ntext);

   iline = 0;
   for( i = 1; i <= ntext; i++ ) {
      txt = strtrim(strcompress( text(i) ));
      if( strlen(txt) == 0 ) continue;
      s = strsplit( txt, " " );
      ns = numberof(s);
      iline++;
      for( j = 1; j <= ncols; j++ ) {
         cols(iline,j) = j > ns ? "---" : s(j);
      }
   }
   nlines = iline;
   cols = cols(1:nlines,*);
   for( j = 1; j < ncols; j++ ) {
      width(j) = 2 + max(strlen(cols(,j)));
   }

   lines = strpadd(cols(,1),width(1));
   for( j = 2; j < ncols; j++ ) lines += strpadd(cols(,j),width(j));
   lines += cols(,0);

   if(is_void(outfile) ) outfile = text_file;

   write_slist,outfile,lines;

}
%FILE% redefine_project_id.i
/* Function redefine_project_id */

func redefine_project_id( old_proj_name, new_proj_name, jemxNum=, chat= )
/* DOCUMENT redefine_project_id, old_proj_name, new_proj_name, jemxNum=, chat=

     Intended for use in /jemx/njw directories srcl_res, evts_shd, and sky_ima

*/
{
   oldname = "_"+old_proj_name+"_";
   newname = "_"+new_proj_name+"_";

   ch = jemxNum ? itoa(jemxNum) : "?";
   list = file_search("jmx"+ch+"_*"+oldname+"*.fits");
   nlist = numberof(list);
   if( !nlist ) {
      write,"Oops, sorry, no files found!";
      return;
   }

   if( chat ) {
      if( 2*chat >= nlist ) {
         write,"Found these files:";
         prstrarr, list;
      } else {
         write,"   ***   Showing first "+itoa(chat)+" files:";
         prstrarr, list(1:chat);
         write,"   ***   Showing last "+itoa(chat)+" files:";
         prstrarr, list(-(chat-1):0);
      }
      ans = rdline(prompt="Continue ? ... ");
      if( ans != "y" ) {
         write,"Skipped all actions ...";
         return;
      }
   }

   newlist = strstrrepl( list, oldname, newname ); // do the replacement

   //  Test for coincidences with existing files

   exilist = file_search("jmx"+ch+"_*"+"_"+new_proj_name+"_*.fits");
   nexilist = numberof(exilist);
   idx = whereany( newlist, exilist );
   nidx = numberof( idx );

   if( nidx ) {
      write,"These existing files will be overwritten if you proceed:";
      if( nidx <= 20 ) {
         prstrarr, exilist;
      } else {
         write,"   ***   Showing first 10 files:";
         prstrarr, exilist(1:10);
         write,"   ***   Showing last 10 files:";
         prstrarr, exilist(-9:0);
      }
      ans = rdline(prompt="Continue ? ... ");
      if( ans != "y" ) {
         write,"Skipped all actions ...";
         return;
      }
   }

   // Make a system call if in Linux or Solaris (Unix) system
   // bat copy and delete if in windows

   if( strlen(get_env("OSTYPE")) ) { //  -x system
      write,"Rename files (Linux/Unix/Solaris) ...";
      for(i=1;i<=nlist;i++) system,"mv "+list(i)+" "+newlist(i);
   } else {         // windows
      write,"Rename files (Windows) ...";
      for(i=1;i<=nlist;i++) {
         cp, list(i), newlist(i);
         remove, list(i);
      }
   }
}
%FILE% reg2fits.i
func reg2fits( region_file, outfile )
{
   text = strtrim(rdfile(region_file));
   ntext = numberof(text);

   ra_arr = dec_arr = array(float,ntext);
   name = array("                        ",ntext);
   count = 0;

   for( i = 1; i <= ntext; i++ ) {
      line = text(i);
      if( strlen(line) == 0 ) continue;
      if( strpart(line,1:1) == "#" ) continue;
      if( strlowcase(strpart(line,1:6)) == "global" ) continue;

      // Look for coordiates in first parenthesis

      pos = strpos( line,"(", 1);
      if( !pos ) { write,"Warning ##1## line "+itoa(i); continue; }
      pos2 = strpos( line,")", pos);
      if( !pos2 ) { write,"Warning ##2## line "+itoa(i); continue; }
      coords_string = strpart(line,pos+1:pos2-1);
      coords = strsplit(coords_string,",");
      if( numberof(coords)!=2 ) { write,"Warning ##3## line "+itoa(i); continue; }
      count++;
      ra_arr(count) = atof(coords(1));
      dec_arr(count) = atof(coords(2));
      pos = strpos(line,"text",pos2);
      if( pos ) {
         pos2 = strpos(line,"{",pos);
         if( !pos2 ) { write,"Warning ##4## line "+itoa(i); continue; }
         pos3 = strpos(line,"}",pos2);
         if( !pos3 ) { write,"Warning ##5## line "+itoa(i); continue; }
         name(count) = strpart(line,pos2+1:pos3-1);
      }
   }
   ra_arr = ra_arr(1:count);
   dec_arr = dec_arr(1:count);
   name = name(1:count);

   kwds_init;
   kwds_set,"EXTNAME","SRC_CATALOG","Name of this extension";
   kwds_set,"CREATOR","reg2fits.i","Software used";
   kwds_set,"DATE",ndate(3),"Date/time of creation";
   kwds_set,"REGFILE", region_file,"Input file";
   wrmfitscols,outfile,"NAME",name,"RA_OBJ",ra_arr,"DEC_OBJ",dec_arr,"ERR_RAD", \
          float(ra_arr*0+0.05), clobber=1;
   write,outfile+" has been written";
}
%FILE% reverse_cube.i
func reverse_cube( filename )
{
   dol = filename+"+1";
   fh = headfits( dol );
   fits_copy_keys, fh, tokwds=1;
   m = readfits( dol );
   m = m(,,0:1:-1);
   writefits,filename+"x",m,clobber=1;
   write,"Done!";
}
%FILE% rmf_funcs.i
extern rmf_funcsdoc;
/* DOCUMENT ****************************************

   A collection of function for RMF manipulations of
   various kinds including ARF:

     charf      :  Arithmetic changes of an ARF in a table
     attach_arf :  Update ANCRFILE content of '-SPE' file
     arf2phaii  :  Save arf array to adequate FITS format
     create_rmf :  Create an RMF file with a RDM
                          (Redistribution matrix)
     read_arf   :  Return an ARF with energy boundaries
     read_ogip_rmf :  Read an OGIP standard RMF
     rebin_rdm  :  Rebin an RDM

     2009-06-22/NJW, updated 2010-10-05/NJW
     2011-09-13/NJW, updated with RMF OGIP read

******************************************************/

/* Function charf */

func charf( filename, spe_num, expr=, outfile= )
/* DOCUMENT charf, filename, spe_num, expr=, outfile=

   If 'filename' is a spectrum file then the ANCRFILE will be used
   as input ARF, else if it is an ARF file it itself will be used.

   Default for spe_num is 1
   Keyword 'expr' can be "*1.05", "-0.02", "+0.2", "/1.05"

   SEE ALSO: attach_arf

   2008-10-28/NJW
*/
{
   if( typeof(expr) != "string" ) error,"Keyword expr must be a string";

   dol = filename+"+1";

   // Find out whether it is a spectral file or an ARF file

   fh = headfits( dol );
   extname = fxpar( fh, "extname" );
   psp = strpos( extname, "SPE" );
   par = strpos( extname, "ARF" );
   psr = strpos( extname, "SPECRESP" );
   if( psr > 0 ) psp = 0; // Finding SPECRESP overrides finding SPE
   is_spec = -1;
   if( psp > 0 && par <= 0 ) {
      is_spec = 1;
      write,"This is a SPEC file";
   } else if( psp <= 0 && (psr > 0 || par > 0 ) ) {
      is_spec = 0;
      write,"This is an ARF file";
   } else {
      write,format="EXTNAME = %s - cannot decide its type\n", extname;
      return;
   }

   if( is_spec ) {
      // We have a SPEC file

      // get ARF from ANCRFILE
      colnum = fits_colnum( fh, "ANCRFILE");
      if( is_void(colnum) ) error,"Cannot find ANCRFILE column";
      arf_file = strtrim(fits_bintable_peek( dol,spe_num,colnum));
      arf_file = strip_curly_br(arf_file);
   } else {
      arf_file = filename;
      arf_dol = dol;
   }
   fha = headfits( arf_dol );
   colnuma = fits_colnum( fha, "SPECRESP" );
   if( is_void(colnuma) ) error,"Cannot find SPECRESP column";
   arf = fits_bintable_peek( arf_file+"+1", spe_num, colnuma );
   ty = typeof(arf);

   oper = strpart(expr,1:1);
   val  = atof(strpart(expr,2:0));

   if( oper == "*" ) {
      arf *= val;
   } else if( oper == "+" ) {
      arf += val;
   } else if( oper == "-" ) {
      arf -= val;
   } else if( oper == "/" ) {
      arf /= val;
   } else error,"Operand "+oper+" is not supported";

   if( typeof(outfile) == "string" ) {
      cp,arf_file,outfile;
   } else outfile = arf_file;

   if( ty == "float" ) arf = float(arf);
   fits_bintable_poke, outfile+"+1", spe_num, colnuma, arf;

   write,format="Updated %s with new ARF\n", outfile;

}

/* Function attach_arf */

func attach_arf( spe_file, arf_file, spe_num )
/* DOCUMENT     attach_arf, spe_file, arf_file
                attach_arf, spe_file, arf_file, spe_num
                attach_arf, spe_file{2}, arf_file{3}

   Insert 'arf_file' in the 'ANCRFILE' column of 'spe_file'

   First version:  All spectra are updated with corresponding
                   arf i.e. spe_file{1} with arf_file{1} etc.

   Second version: Only spe_file{spe_num} is updated with
                   arf_file{spe_num}

   Third version:  As written

   SEE ALSO: charf

   2008-10-28/NJW
*/
{
   local xxx, spe_no;

   if( is_void(spe_num) ) {  // First or third version

      spe_file = strtrim(spe_file);
      arf_file = strtrim(arf_file);
      if( strpart(spe_file,0:0) != "}" || strpart(arf_file,0:0) != "}" ) { // first version

         ver = 1;
         spe_no = arf_no = 1; // to survive the test

      } else { // third version

         get_exten_no, spe_file, xxx, spe_no;
         spe_file = xxx;
         get_exten_no, arf_file, xxx, arf_no;
         ver = 3;
      }

   } else {  // Second version

      spe_no = spe_num;
      arf_no = spe_num;
      ver = 2

   }

   // Make sure that spe_file is a spectral file

   if( !file_test(spe_file) ) error,"File "+spe_file+" not found";
   if( !file_test(arf_file) ) error,"File "+arf_file+" not found";

   fhs = headfits( spe_file+"+1" );
   extname = fxpar( fhs, "extname" );
   nrows = fxpar( fhs, "naxis2" );
   if( !nrows ) error,"No rows in "+spe_file;
   psp = strpos( extname, "SPE", 1 );
   if( psp <= 0 ) error,"First argument is not a spectral file";

   if( spe_no > nrows ) error,"Requested row not found in "+spe_file;

   colnum = fits_colnum( fhs, "ANCRFILE");
   tmpl_ancrfile = fits_bintable_peek( spe_file+"+1", 1, colnum );
   len = strlen( tmpl_ancrfile );

   fha = headfits( arf_file+"+1" );
   extname = fxpar( fha, "extname" );
   psp = strpos( extname, "ARF", 1 );
   if( psp <= 0 ) write,"Warning! Second argument may not be an ARF file";

   if( ver == 1 ) { // loop over all rows

      for( i = 1; i <= nrows; i++ ) {
         newancrfile = arf_file+"{"+itoa(i)+"}";
         l = strlen(newancrfile);
         for(j=l;j<len;j++) newancrfile += " ";
         fits_bintable_poke, spe_file+"+1", i, colnum, newancrfile;
      }

   } else { // single update, spe_no and arf_no have been defined


      newancrfile = arf_file+"{"+itoa(arf_no)+"}";
      l = strlen(newancrfile);
      for(j=l;j<len;j++) newancrfile += " ";
      fits_bintable_poke, spe_file+"+1", spe_no, colnum, newancrfile;

   }

   write,format="Updated %s with new ANCRFILE\n", spe_file;

}

/* Function arf2phaii */

func arf2phaii( filename, arf, energ_lo, energ_hi, extname=, instrume=, \
                     mission=, telescop=, nokwdsinit= )
/* DOCUMENT arf2phaii, filename, arf, energ_lo, energ_hi, extname=, \
                   instrume=, mission=, telescop=, nokwdsinit=

     Write ARF or ARFs in counts/s to PHA II format
     where each row has vector fields (columns) ENERG_LO, ENERG_HI, and SPECRESP

     Dimension of arf:    nbins x nrows
     Dimension of energ_lo, energ_hi: nbins (assumed to the identical for all rows)
                               or     nbins x nrows

     Keywords:

        These keywords are single valued (becomes part of FITS header)

             extname   (string)  EXTNAME, defaults to SPECRESP
             instrume  (string)  instrument name
             mission   (string)  mission name
             telescop  (string)  name of 'telescope'

             nokwdsinit          will inhibit the keyword initialization

    2009-06-29/NJW
*/
{

   dms = dimsof(arf);
   dmse = dimsof(energ_lo);
   // expand energ_lo if we have more than one ARF
   if( dmse(1) == 1 && dms(1) > 1 ) {
      energ_lo = energ_lo(,-:1:dms(3));
   }
   dmse = dimsof(energ_hi);
   if( dmse(1) == 1 && dms(1) > 1 ) {
      energ_hi = energ_hi(,-:1:dms(3));
   }
   if( anyof(dms-dimsof(energ_lo)) ) error,"Argument (energ_lo) dimension incompatibility";
   if( anyof(dms-dimsof(energ_hi)) ) error,"Argument (energ_hi) dimension incompatibility";

   if( dms(1) == 2 ) {
      nrows = dms(3);
      nbins = dms(2);
   } else if( dms(1) == 1 ) {
      nrows = 1;
      nbins = dms(2);
      arf = reform(arf,nbins,nrows);
      energ_lo = reform(energ_lo,nbins,nrows);
      energ_hi = reform(energ_hi,nbins,nrows);
   } else error,"Illegal dimensions of ARF array";

   ttype1 = "arf_num";
   data1 = short(indgen(nrows));
   ttype2 = "energ_lo";
   data2 = float(energ_lo);
   ttype3 = "energ_hi";
   data3 = float(energ_hi);
   ttype4 = "specresp";
   data4 = float(arf);

   if( !nokwdsinit ) kwds_init;

   if( typeof(extname) == "string" ) {
      kwds_set,"extname",extname,"Name of this extension";
   } else {
      kwds_set,"extname","SPECRESP","Extension name";
   }
   if( !is_void(instrume) ) kwds_set,"instrume",instrume,"Instrument name";
   if( !is_void(mission) ) kwds_set,"mission",mission,"Mission name";
   if( !is_void(telescop) ) kwds_set,"telescop",telescop,"Telescope name";
   kwds_set,"date",ndate(3),"CET Central European time";
   kwds_set,"hduclass","OGIP","Format conforms mostly to OGIP standards";
   kwds_set,"hduclas1","RESPONSE","Dataset contains response information";
   kwds_set,"hduclas2","SPECRESP","Ancillary response data";
   kwds_set,"hduvers","1.3.0","Version of format";
   kwds_set,"tunit2","keV","Unit of column ENERG_LO";
   kwds_set,"tunit3","keV","Unit of column ENERG_HI";
   kwds_set,"tunit4","cm**2","Unit of column SPECRESP";

   wrmfitscols,filename, ttype1, data1, ttype2, data2, ttype3, data3, \
                         ttype4, data4, clobber=1;

}

/* Function create_rmf */

func create_rmf( outfile, n_in=, e_in_min=, e_in_max=, lg=, \
      n_det=, e_det_min=, e_det_max=, expr= )
/* DOCUMENT  create_rmf, outfile, n_in=, e_in_min=, e_in_max=, lg=, \
                 n_det=, e_det_min=, e_det_max=, expr=

    'outfile' is the name of the resulting RMF-file (Default: rmf.fits).

    The following keywords can be given in the call, those not given will
    be asked for (via parameter file: create_rmf.par):

    energ_lo & energ_hi  (n_in)  belong to input spectrum
    e_in_min, e_in_max
    Set 'lg' to get logarithmic in-energy steps

    e_min & e_max        (n_det) belong to detector channels
    e_det_min, e_det_min

    'expr' is the expression for the detector resolution as a function
    of energy that MUST be called 'ener'.

    This function writes file: 'crmf.i' that must be loaded and
    executed in Yorick. This is a work-around of defining a
    function as a text string.

    2010-10-05/NJW but made in 2008 or 2009
*/
{

   extern N_in, E_in_min, E_in_max, N_det, E_det_min, E_det_max, Expr;
   extern Outfile;

   if( is_void(outfile) ) {
      Outfile = "rmf.fits";
      write,"The RMF file will be: "+Outfile;
   }
   Outfile = outfile;

   if( !file_test("create_rmf.par") ) {
      pf = open("create_rmf.par","w");
      write,pf,format="// n_in = %i; Number of columns in RDM\n", 200;
      write,pf,format="// e_in_min = %f; [keV] Lower spectral energy\n", 0.05;
      write,pf,format="// e_in_max = %f; [keV] Upper spectral energy\n", 15.0;
      write,pf,format="// lg = %i; Flag for logarithmic in-energies\n", 1;
      write,pf,format="// n_det = %i; Number of energy bins in detector\n", 100;
      write,pf,format="// e_det_min = %f; [keV] Lower detector energy\n", 0.10;
      write,pf,format="// e_det_max = %f; [keV] Upper detector energy\n", 10.0;
      write,pf,format="// expr = %s; Expression for sigma\n", "0.2*sqrt(ener)";
      close,pf;
   }

   if( is_void(n_in) ) n_in = get_spar("create_rmf.par","n_in",lng=1);
   if( is_void(e_in_min) ) e_in_min = get_spar("create_rmf.par","e_in_min");
   if( is_void(e_in_max) ) e_in_max = get_spar("create_rmf.par","e_in_max");
   if( is_void(lg) ) lg = get_spar("create_rmf.par","lg",lng=1);
   if( is_void(n_det) ) n_det = get_spar("create_rmf.par","n_det",lng=1);
   if( is_void(e_det_min) ) e_det_min = get_spar("create_rmf.par","e_det_min");
   if( is_void(e_det_max) ) e_det_max = get_spar("create_rmf.par","e_det_max");
   if( is_void(expr) ) expr = get_spars("create_rmf.par","expr");

   N_in = n_in;
   E_in_min = e_in_min;
   E_in_max = e_in_max;
   N_det = n_det;
   E_det_min = e_det_min;
   E_det_max = e_det_max;
   Expr = expr;

   f = open("crmf.i","w");

   //+ write,f,"func crmf {";
   slg = lg ? "l" : "";
   write,f,"el = span"+slg+"( E_in_min, E_in_max, N_in+1 );";
   write,f,"energ_lo = el(1:-1); energ_hi = el(2:0); energ = sqrt(energ_lo*energ_hi);";

   write,f,"e = span( E_det_min, E_det_max, N_det+1 );";
   write,f,"e_min = e(1:-1); e_max = e(2:0); edet = e(zcen);";

   write,f,"rdm = array(double,N_det,N_in);";

   write,f,"for( j = 1; j <= N_in; j++ ) { ener = energ(j);";
      write,f,format=" sigma = %s;\n",expr;
      write,f,"rdm(,j) = array_igauss(e,[1./(sigma*sqrt(2*pi)),ener,sigma])*e(dif);}";

   write,f,"kwds_init;";
   write,f,"kwds_set,\"EXTNAME\",\"MATRIX\",\"Name of this extension\";";
   write,f,"kwds_set,\"ORIGIN\",\"DTU Space/NSI\",\"Origin of FITS file\";";
   write,f,"kwds_set,\"CREATOR\",\"yorick/create_rmf(.i)\",\"Executable which created this data\";";
   write,f,"kwds_set,\"DATE\",ndate(3),\"Date/time of creation\";";
   write,f,"kwds_set,\"HDUCLASS\",\"OGIP\",\"Format conforms mostly to OGIP standards\";";
   write,f,"kwds_set,\"HDUCLAS1\",\"RESPONSE\",\"Dataset contains response information\";";
   write,f,"kwds_set,\"HDUCLAS2\",\"RSP_MATRIX\",\"Extension contains a response matrix\";";
   write,f,"kwds_set,\"HDUVERS\",\"1.3.0\",\"Version of format\";";
   write,f,"kwds_set,\"CHANTYPE\",\"PHA\",\"Type of detector channels\";";
   write,f,"kwds_set,\"DETCHANS\",N_det,\"Total number of PHA channels in the full matrix\";";
   write,f,"kwds_set,\"TLMIN4\",1,\"Channel number of first channel\";";
   write,f,"kwds_set,\"TLMAX4\",N_det,\"Channel number of last channel\";";
   write,f,"kwds_set,\"LO_THRES\",0.0,\"Lowest value in MATRIX\";";
   write,f,"kwds_set,\"TUNIT1\",\"keV\",\"Unit of energy\";";
   write,f,"kwds_set,\"TUNIT2\",\"keV\",\"Unit of energy\";";
   write,f,"kwds_set,\"COMMENT\",\"Sigma = "+expr+"\";";

   write,f,"idum = array(short(1),N_in);";
   write,f,"fh = wrmfitscols(\""+Outfile+"\",\"ENERG_LO\",float(energ_lo),\"ENERG_HI\",float(energ_hi), \\";
       write,f,"\"N_GRP\",idum,\"F_CHAN\",idum,\"N_CHAN\",idum,\"MATRIX\",float(rdm),cont=1,clobber=1);";

   write,f,"kwds_set,\"EXTNAME\",\"EBOUNDS\",\"Name of this extension\";";
   write,f,"kwds_set,\"HDUCLAS2\",\"EBOUNDS\",\"Extension contains energy boundaries\";";
   write,f,"kwds_del,\"TUNIT1\";";
   write,f,"kwds_set,\"TUNIT3\",\"keV\",\"Unit of energy\";";
   write,f,"kwds_del,\"TLMIN4\";";
   write,f,"kwds_del,\"TLMAX4\";";
   write,f,"kwds_del,\"LO_THRES\";";

   write,f,"wrmfitscols,fh,\"CHANNEL\",short(indgen(N_det)),\"E_MIN\",float(e_min), \\";
       write,f,"\"E_MAX\",float(e_max);";

//+ write,f,"}";

   write,"Now: #include \"crmf.i\"";
}

/* Function read_ogip_rmf */

func read_ogip_rmf( filename, &elo, &ehi, &e_min, &e_max )
/* DOCUMENT rdm = read_ogip_rmf( filename, >elo, >ehi, >e_min, >e_max )

   See OGIP Calibration Memo CAL/GEN/92-002 (RMFs & ARFs)
    "The Calibration Requirements for Spectral Analysis"

   NB NB NB  This is a very basic version that ignores
             1) MATRIX may not have the right dimension to begin with
             2) Columns F_CHAN, N_CHAN, MATRIX may be of variable length
             3) The mandatory keywords such as 'DETCHANS'
*/
{
   local hdr, nrows;

   /*
    *   The extension "MATRIX" or "SPECRESP MATRIX" must exist with columns
    *     ENERG_LO, ENERG_HI, N_GRP, F_CHAN, N_CHAN, MATRIX
    *   and (mandatory) keywords
    *     EXTNAME, TELESCOP, INSTRUME, FILTER, CHANTYPE, DETCHANS, HDUCLASS,
    *     HDUCLAS1, HDUCLAS2, HDUVERS, TLMIN#
    *   and (optional) keywords
    *     NUMGRP, NUMELT, PHAFILE, LO_THRES, HDUCLAS3 ('REDIST', 'DETECTOR', or 'FULL')
    */

   ptr = rdfitsbin( filename+"[MATRIX]", hdr, nrows );
   if( is_void(ptr) ) { // Try the other allowed name
      ptr = rdfitsbin( filename+"[SPECRESP MATRIX]", hdr, nrows );
      if( is_void(ptr) ) {
         error,"None of the required extension names were found";
      }
   }

  /*
   *   Following three columns MUST be present
   */
   ic = fits_colnum( hdr, "ENERG_LO" );
   if( is_void(ic) ) error,"Column not found";
   elo = *ptr(ic);
   ic = fits_colnum( hdr, "ENERG_HI" );
   if( is_void(ic) ) error,"Column not found";
   ehi = *ptr(ic);
   ic = fits_colnum( hdr, "MATRIX" );
   if( is_void(ic) ) error,"Column not found";
   m = transpose(*ptr(ic)); // transposition is required to adhere to the
                            // convention in 'rdfitscol'
  /*
   *   Following three columns may be absent
   *   in which case 'm' is the final RDM
   */
   ic = fits_colnum( hdr, "N_GRP" );
   if( is_void(ic) ) goto ebounds;
   n_grp = *ptr(ic);
   ic = fits_colnum( hdr, "F_CHAN" );
   if( is_void(ic) ) goto ebounds;
   f_chan = *ptr(ic);
   ic = fits_colnum( hdr, "N_CHAN" );
   if( is_void(ic) ) goto ebounds;
   n_chan = *ptr(ic);


   // when you come here 'm' must be reworked

   for( i = 1; i <= nrows; i++ ) {
      m_orig = m(,i);
      m(,i) = 0.0;
      istart = 1;
      for( j = 1; j <= n_grp(i); j++ ) {
         m(f_chan(i,j)+1:f_chan(i,j)+n_chan(i,j),i) = m_orig(istart:istart+n_chan(i,j)-1);
         istart += n_chan(i,j);
      }
   }

  ebounds:

   /*
    *    Read the EBOUNDS extension for E_MIN and E_MAX
    */

   ptr = rdfitsbin( filename+"[EBOUNDS]", hdr, nrows );
   if( is_void(ptr) ) { // Skip and return
      write,"Extension EBOUNDS is missing - skip and only return MATRIX";
      e_min = e_max = [];
      return m;
   }

   ic = fits_colnum(hdr, "E_MIN");
   if( is_void(ic) )  error,"Column is missing";
   e_min = *ptr(ic);
   ic = fits_colnum(hdr, "E_MAX");
   if( is_void(ic) )  error,"Column is missing";
   e_max = *ptr(ic);

   return m;

}

/* Function rebin_rdm */

func rebin_rdm( rdm, rebin )
/* DOCUMENT new_rdm = rebin_rdm( rdm, rebin )

    Rebins a redistribution matrix (RDM) using an array 'rebin' that
    may result from 'specrebinninga' or 'specrebinningb'. Its elements represent the
    number of old bins that will make the new array.

    Its similar to the array used in 'specrebinning' except that it
    should not skip any bins (i.e. have negative values) except at the
    very end.

*/
{
   dms = dimsof( rdm );
   n_det_bins = dms(2);
   n_ener_bins = dms(3);

   // check 'rebin' for asking for too many bins

   n_wanted = sum(abs(rebin));
   //+ write,"Check 'rebin' ...";
   while( n_wanted > n_det_bins ) {
      // diminish or completely remove last element?
      n = n_wanted - n_det_bins;
      if( abs(rebin(0)) <= n ) { // remove last element
         rebin = rebin(1:-1);
         //+ write,"  remove last element";
      } else {     // diminish last element
         if( rebin(0) > 0 ) {
            rebin(0) -= n;
            //+ write,"  diminish last element to "+itoa(rebin(0));
         } else {
            rebin(0) += n;
            //+ write,"  diminish last element to "+itoa(rebin(0));
         }
      }
      n_wanted = sum(abs(rebin));
   }
   //+ write,"Checking done ...";

   n_new_det_bins = numberof(rebin) - numberof(where(rebin <= 0));

   new_rdm = array( structof(rdm), n_new_det_bins, n_ener_bins );

   m = 1;
   k1 = k2 = 0;
   for( i = 1; i <= n_new_det_bins; i++ ) {
      k1 = k2 + 1;
      while(rebin(m) <= 0) { k1 -= rebin(m); m++; }
      k2 = k1 + rebin(m++) - 1;
      //+ write,"    Summing between "+itoa(k1)+" and "+itoa(k2);
      a = rdm(k1:k2,);
      new_rdm(i,) = a(sum,);
   }

   return new_rdm;

}


/* Function read_arf */

struct s_ARF {
   double elo;
   double ehi;
   double el;
   double arf;
}
func read_arf( filename )
/* DOCUMENT r = read_arf( arf_file_name )

     Returns struct s_ARF with elements 'elo', 'ehi', 'el', and 'arf'.

     SEE ALSO: rd_arf (xray.i)

*/
{
   if( !file_test(filename) ) error,filename+" was not found!";

   dol = filename+"[SPECRESP]";
   elo = rdfitscol( dol, "energ_lo");
   res = array( s_ARF, numberof(elo) );
   res.elo = elo;
   res.ehi = rdfitscol( dol, "energ_hi");
   res.arf = rdfitscol( dol, "specresp");
   res.el = 0.5*( res.elo + res.ehi );

   return res;
}
%FILE% rootpoly.i
#include "kombinationer.i"

func rootpoly( x, xroots )
{
   n = numberof(xroots);

   y = x - xroots(1);
   for( i = 2; i <= n; i++ ) y *= (x-xroots(i));
   return y;
}

func coef_rootpoly( xroots )
{
   n = numberof( xroots );
   c = array(double,n+1);

   //+ if( n == 1 ) {
   //+    c(1) = -xroots(1);
   //+    c(2) = 1.;
   //+ }

   for( i = 1; i<= n; i++ ) {
      // x^(i-1)
      if( i == 1 ) {
         coef = 1.;
         for(j=1;j<=n;j++) coef *= (-xroots(j));
         c(i) = coef;
      } else {
         nkom = nkombi(n-i+1,n);
         coef = 0.0;
         for(j = 1; j <= nkom; j++ ) {
            xr_sel = kombi(n-i+1,xroots,j);
            dcoef = 1.;
            for(k=1;k<=n-i+1;k++) dcoef *= (-xr_sel(k));
            coef += dcoef;
         }
         c(i) = coef;
      }
   }
   c(n+1) = 1.0;

   return c;
}
%FILE% rotate.i
/***********************************
 *   Package for 2D rotation
 ***********************************/

struct s_Point{
   double x;
   double y;
}

func vscalrot( &xarr, &yarr, center, angle, inv= )
/* DOCUMENT vscalrot, xarr, yarr, center, angle, inv=

    Wrapper for scalrot; operates in place.
*/
{
   n = numberof(xarr);
   c = array(s_Point,n);
   c.x = xarr;
   c.y = yarr;
   cen = s_Point();
   cen.x = center(1);
   cen.y = center(2);

   cc = scalrot( c, cen, , angle, inv=inv );

   xarr = cc.x;
   yarr = cc.y;

}

func scalrot( object, center, scale, angle, inv= )
/* DOCUMENT  new_obj = scalrot( object, center, scale, angle, inv= )

   Returns a scaled and rotated object where

   object   array (struct s_Point with elements x and y)
   center   single s_Point (original coordinates)
   scale    single s_Point : scaling factors (applied before the rotation)
   angle    double : rotation angle in degrees (counterclockwise)

   With keyword 'inv' the action is reversed

   2009-07-29/NJW
*/
{
   deg2rad = pi/180;

   if( is_void(scale) ) {
      scale = s_Point();
      scale.x = 1.0;
      scale.y = 1.0;
   }

   co = cos(angle*deg2rad); si = sin(angle*deg2rad);
   omega = [[co,si],[-si,co]];

   n = numberof(object);
   new_obj = array(s_Point,n);
   xy = array(double,2,n);

   if( inv ) {   // *** reverse the action ***

      xy(1,) = object.x - center.x;
      xy(2,) = object.y - center.y;

      dum = omega(1,2);
      omega(1,2) = omega(2,1);
      omega(2,1) = dum;

      z = omega(,+)*xy(+,);

      new_obj.x = z(1,)/scale.x + center.x;
      new_obj.y = z(2,)/scale.y + center.y;

   } else {    // *** forward action ***

      xy(1,) = (object.x - center.x) * scale.x;
      xy(2,) = (object.y - center.y) * scale.y;

      z = omega(,+)*xy(+,);

      new_obj.x = z(1,) + center.x;
      new_obj.y = z(2,) + center.y;
   }

   return new_obj;

}
%FILE% rotate_image.i
/**************************************
  Function to return a rotated image

    Lower left pixel has center coordinates (1.,1.)

    2012-07-15/NJW

**************************************/

func rotate_image( im, angle, xc, yc, prec= )
/* DOCUMENT newim = rotate_image( im, angle, xc, yc, prec= )

      Angle in deg.

      Keyword 'prec' is precision i.e. number of subdivisions.
*/
{
   im = double(im);
   dms = dimsof( im );
   out = im*0.;
   if( is_void(prec) ) prec = 2;

   ca = cos(angle*pi/180.);
   sa = sin(angle*pi/180.);
   omega = [[ca,sa],[-sa,ca]];

   dp = 1./(2*prec);

   for( i = 1; i <= dms(2); i++ ) {
      for( j = 1; j <= dms(3); j++ ) {
         frac = im(i,j) / prec^2;
         for( k = 1; k <= prec; k++ ) {
            for( l = 1; l <= prec; l++ ) {
               subpixpos = [-0.5+dp+2*dp*(k-1+random()-0.5),-0.5+dp+2*dp*(l-1+random()-0.5)];
               pos = omega(,+)*([i,j]+subpixpos-[xc,yc])(+) + [xc,yc];
               ip = long(floor(pos(1)+0.5));
               jp = long(floor(pos(2)+0.5));
               if(ip > 0 && ip <= dms(2) && jp > 0 && jp <= dms(3) ) out(ip,jp) += frac;
            }
         }
      }
   }
   return out;
}
%FILE% scan_image.i
// A struct for the catalog content

struct s_CAT {
   string catdol;
   int nsrcs;
   int symbol;
   string color;
   double size;
   pointer ra_cat;
   pointer dec_cat;
   pointer flag;
   pointer detsig;
}

// A struct for the command with parameters

struct s_Command {
   string command;
   pointer rparms;
   pointer iparms;
   pointer sparms;
}


func scan_image( dols )
{

   extern Ima, I_num, Dms, Dols, Widthi, Widthj, Cats, Cats_active;
   extern Glon_scale, Glat_scale, Box, Workbox, Workbox_toc, Outline;
   extern Glon_ur,Glat_ll,Glon_ll,Glat_ur;
   extern Icn, Jcn;
   extern _Src_rad, _Bkg_rad1, _Bkg_rad2, _Sigma, _Freq, _Tile, _Siglim;

   local val, ix, iy;
   local catfile, extno;

   if( !is_void(dols) ) {
      Dols = dols;
      logfilename = get_next_filename("scan_image_????.txt");
      lg = open(logfilename,"w");
   } else { // continue on current images
      logfilename = get_next_filename("scan_image_????.txt",latest=1);
      lg = open(logfilename,"a");
   }
   num_images = numberof(Dols);
   write,"Logging file: "+logfilename;
   write,lg,format="Log of 'scan_image' on %s\n\n", ndate(3);
   erlog = open("scan_image.log","w");

   if( !is_void(dols) ) {
      write,erlog,"##1## resetting";
      for( i = 1; i <= num_images; i++ ) {
         write,"Reading "+dols(i)+" and convert NaNs to zeros ...";
         if( i == 1 ) {
            Ima = readfits( dols(i) );
            Ima = Ima(,,-);
         } else {
            grow,Ima,readfits( dols(i) );
         }
      }
      Dms = dimsof(Ima);
      Icn = Dms(2)/2;
      Jcn = Dms(3)/2;
      wnan = wherenan( Ima );
      Ima(wnan) = 0.0;
      Widthi = Widthj = 101;
      Cats = s_CAT();
      Cats_active = [1];
      Cats(1).catdol = "cur_cat.fits";
      Cats(1).nsrcs = 0;
      Cats(1).symbol = 16;
      Cats(1).color = "yellow";
      Cats(1).size = 1.2;
      I_num = 1;
      Outline = bytscl(imcut(Ima(,,1),1,2));
   }
   write,lg,format="DOL : %s,  %ix%i pixels\n", Dols(1), Dms(2), Dms(3);
   for( i = 2; i <= num_images; i++ ) {
      write,lg,format="DOL : %s\n", Dols(i);
   }
   write,lg,"  Pixel         RA    dec     Glon    Glat\n";

   // show outline in plot window #0
   disp,Outline,pane=0;

   Glon_scale = span(360.-180./Dms(2),180./Dms(2),Dms(2))-180.;
   Glat_scale = span(-0.025*(Dms(3)/2-0.5),0.025*((Dms(3)/2)-0.5),Dms(3));
   autoscan = 0;
   reverse = 0;
   cstr = command_string = "";
   if( Cats(1).nsrcs > 0 ) {
      racat1 = *Cats(1).ra_cat;
      deccat1 = *Cats(1).dec_cat;
      flag1 = *Cats(1).flag;
      detsig1 = *Cats(1).detsig;
   }

   while( 1 ) {
      write,erlog,"##2## after while in line 67";
      if( autoscan ) {
         ic = icn;
         jc = jcn;
         flag = 0;
         if( reverse ) {
            ic -= (4*Widthi)/5;
            if( ic < Widthi/2 ) {
               jc -= (4*Widthj)/5;
               if( jc < Widthj/2 ) write,"Warning - backing too much ...";
               ic = Dms(2) - (Widthi-1)/2;
            }
         } else {
            ic += (4*Widthi)/5;
            if( ic > Dms(2) ) {
               jc += (4*Widthj)/5;
               if( jc > Dms(3) ) {
                  write,"Warning - scan exhausted ...";
                  flag = 1;
               }
               ic = (Widthi-1)/2;
            }
         }
         Icn = ic;
         Jcn = jc;
      } else {
        /*
         * ans = "";
         * read,prompt="Enter center pixel: ... ",format="%[^\n]",ans;
         * ic = jc = 0;
         * sread,format="%i%i",ans,ic,jc;
         */

         ic = Icn;
         jc = Jcn;
      }

      icn = ic;
      jcn = jc;

    // in order to tell if the box has a non-zero content
      Box = extract_box( Ima(,,I_num), icn, jcn, Widthi, Widthj, cen=1 );
      if( icn != ic || jcn != jc )  {
         write,format="Center pixel has been adjusted: %6i%6i\n", icn, jcn;
      }

      if( max(Box) == min(Box) && autoscan ) {
         write,"Empty image - continue ...";
         if( !flag ) continue;
      }

      write,erlog,"##3## before _show_box and _add_cats";
      _get_box, icn, jcn;
      _show_box, icn, jcn;
      _add_cats;

      while( 1 ) {
         read,format="%[^\n]",prompt="What now? ... ", command_string;
         command_string = strtrim(command_string);
         write,erlog,"##4## command given: "+command_string;
         cans = siparse(command_string);
         cmd = cans.command;

         if( cmd == "x" ) {
            close, lg;
            close, erlog;
            return;
         }

         if( cmd == "cf" ) { // comcf
            cans = siparse(command_string, "rr");
            if( is_void(*cans.rparms) ) {
               read,prompt="Enter cut factors: ... ",format="%[^\n]",cstr;
               lofac = hifac = 0.0;
               sread,format="%f%f",cstr,lofac,hifac;
            } else {
               lofac = (*cans.rparms)(1);
               hifac = (*cans.rparms)(2);
            }
            pli,imcut(Workbox(0:1:-1,,0),lofac,hifac),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
            _add_cats;
         } else if( cmd == "c" ) { // comc
            pli,imcut(Workbox(0:1:-1,,0),2,4),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
            _add_cats;
         } else if( cmd == "n" ) { // comn
            cans = siparse(command_string, "i" );
            if( is_void(*cans.iparms) ) {
               I_num++;
               if( I_num > num_images ) I_num = 1;
            } else {
               I_num = (*cans.iparms)(1);
            }
            write,"The image number is now "+itoa(I_num);
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            _add_cats;
         } else if( cmd == "nc" ) { // comnc
            I_num++;
            if( I_num > num_images ) I_num = 1;
            write,"The image number is now "+itoa(I_num);
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            pli,imcut(Box(0:1:-1,),2,4),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
            _add_cats;
         } else if( cmd == "v" ) { // comv
            cans = siparse(command_string, "i" );
            if( is_void(*cans.iparms) ) {
               I_num--;
               if( I_num < 1 ) I_num = Dms(4);
            } else {
               I_num = (*cans.iparms)(1);
            }
            write,"The image number is now "+itoa(I_num);
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            _add_cats;
         } else if( cmd == "vc" ) { // comvc
            I_num--;
            if( I_num < 1 ) I_num = Dms(4);
            write,"The image number is now "+itoa(I_num);
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            pli,imcut(Box(0:1:-1,),2,4),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
            _add_cats;
         } else if( cmd == "b" || cmd == "bc" ) { // comb combc
            for( i = 1; i <= num_images; i++ ) {
               I_num = i;
               _get_box, icn, jcn;
               _show_box, icn, jcn;
               dcim = command_string == "bc" ? imcut(Box(0:1:-1,),2,4) : Box(0:1:-1,);
               if( I_num == 1 ) {
                  cim = dcim;
                  cim = cim(,,-);
               } else {
                  grow,cim,dcim;
               }
               pause, 1000;
            }
            for( j = 1; j <= 4; j++ ) {
               for( i = 1; i <= num_images; i++ ) {
                  pli,cim(,,i),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
                  pause, 1000;
               }
            }
         } else if( cmd == "o" ) { // como
            Workbox = Box(,,-);
            Workbox_toc = "o icn jcn = "+itoa(icn)+" "+itoa(jcn);
            pli,Box(0:1:-1,),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
            _add_cats;
         } else if( cmd == "s" || cmd == "sc" ) { // coms comsc
            cans = siparse(command_string, "r" );
            if( is_void(*cans.rparms) ) {
               if( is_void(_Sigma) ) {
                  sigma = 1.;
                  read,prompt="Enter sigma [pixel] ... ",format="%f", sigma;
                  _Sigma = sigma;
               } else sigma = _Sigma;
            } else {
               _Sigma = sigma = (*cans.rparms)(1);
            }
            dcim = gfconvol(Workbox(,,0),sigma);
            grow,Workbox,dcim;
            grow,Workbox_toc,"s sigma="+swrite(format="%9.4f",sigma);
            if( cmd == "sc" ) dcim = imcut(dcim,2,4);
            pli,dcim(0:1:-1,),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
            _add_cats;
         } else if( cmd == "p" ) { // comp
            autoscan = 0;
            cans = siparse(command_string,"ii");
            if( is_void(*cans.iparms) ) {
               read,prompt="Enter center pixel: ... ",format="%[^\n]",cstr;
               ic = jc = 0;
               sread,format="%i%i",cstr,ic,jc;
            } else {
               ic = (*cans.iparms)(1);
               jc = (*cans.iparms)(2);
            }
            Icn = ic;
            Jcn = jc;
            break;
         } else if( cmd == "m" ) { // comm
            cans = siparse(command_string,"i"); // allow for flag value
            flag = 0;
            if( !is_void(*cans.iparms) ) flag = (*cans.iparms)(1);

            pt = curmark1();
            if( pt(1) < 0.0 ) pt(1) += 360;
            glon = pt(1);
            // make sure 'glon' is in the same range as 'Glon_scale'
            if( glon > 180. ) glon -= 360.;
            abslo = abs(Glon_scale-glon);
            // find index in 'Glon_scale' i.e. x pixel number in
            // the large image
            lon = where( abslo == min(abslo) )(1);
            absla = abs(Glat_scale-pt(2));
            // find index in 'Glat_scale' i.e. y pixel number in
            // the large image
            lat = where( absla == min(absla) )(1);

           /*
            *** position in current image
            */
            iix = (Widthi/2) + (lon - icn);
            iiy = (Widthj/2) + (lat - jcn);
            if( iix < 1 ) iix = 1; if( iix > Widthi ) iix = Widthi;
            if( iiy < 1 ) iiy = 1; if( iiy > Widthj ) iiy = Widthj;

            write,format="Position in current image: %i %i\n", iix, iiy;

            d = distances(Widthi, Widthj, iix, iiy);
            reg = where(d < 3.);
            src_vec = peaksearch0(Workbox(,,0),reg=reg);

            write,format="Peak position: %.4f %.4f\n", src_vec(2), src_vec(3);
            write,format="Maxval: %.6f,  detsig: %.3f\n", src_vec(1), src_vec(5);

            detsig = src_vec(5);

            radec = equatorial(pt(1),pt(2));
            if( radec(1) < 0.0 ) radec(1) += 360;
            src = nearest_source( radec(1), radec(2), 0.2, dst );
            if( is_void(src) ) {
               namestr = "NEW SOURCE";
            } else {
               namestr = swrite(format="%s (%.1f arcmin)",strtrim(src.name),dst*60.);
            }
            write,lg,format="%6i%6i %9.3f%9.3f %9.3f%9.3f %s\n", \
                  lon, lat, radec(1), radec(2), pt(1), pt(2), namestr;
            write,format="%6i%6i %9.3f%9.3f %9.3f%9.3f %s\n", \
                  lon, lat, radec(1), radec(2), pt(1), pt(2), namestr;
            read,prompt="Enter comment: ... ",format="%[^\n]",cstr;
            write,lg,format="// %s\n", cstr;

            // Update current catalog

            if( Cats(1).nsrcs == 0 ) {
               racat1 = [radec(1)];
               deccat1 = [radec(2)];
               flag1 = [flag];
               detsig1 = [detsig];
            } else {
               grow, racat1, radec(1);
               grow, deccat1, radec(2);
               grow, flag1, flag;
               grow, detsig1, detsig;
            }
            Cats(1).ra_cat = &racat1;
            Cats(1).dec_cat = &deccat1;
            Cats(1).flag = &flag1;
            Cats(1).detsig = &detsig1;
            Cats(1).nsrcs++;
         } else if( cmd == "a" ) { // coma
            autoscan = 1;
            reverse = 0;
            break;
         } else if( cmd == "r" ) { // comr
            autoscan = 1;
            reverse = 1;
            break;
         } else if( cmd == "i" ) { // comi
            write,format="Working on %s (%ix%i)\n", Dols(I_num), Dms(2), Dms(3);
            write,format="Box size: %i x %i\n", Widthi, Widthj;
            write,format="Logfile: %s\n", logfilename;
            dmsw = dimsof(Workbox);
            if( dmsw(4) == 1 ) write,format="%i image in Workbox\n",1;
            else write,format="%i images in Workbox\n",dmsw(4);
            write,"Toc of Workbox:"
            for( i = 1; i <= dmsw(4); i++ ) {
               write,format="    %s\n", Workbox_toc(i);
            }
         } else if( cmd == "h" ) { // comh
            icn -= (Widthi/10);
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            _add_cats;
            Icn = icn;
         } else if( cmd == "j" ) { // comj
            jcn -= (Widthj/10);
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            _add_cats;
            Jcn = jcn;
         } else if( cmd == "k" ) { // comk
            jcn += (Widthj/10);
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            _add_cats;
            Jcn = jcn;
         } else if( cmd == "l" ) { // coml
            icn += (Widthi/10);
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            _add_cats;
            Icn = icn;
         } else if( cmd == "z" ) { // comz
            Widthi = (Widthi - 1)/2 + 1;
            Widthj = (Widthj - 1)/2 + 1;
            write,format="New box size: %i x %i\n", Widthi, Widthj;
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            _add_cats;
         } else if( cmd == "u" ) { // comu
            Widthi = (Widthi - 1)*2 + 1;
            Widthj = (Widthj - 1)*2 + 1;
            write,format="New box size: %i x %i\n", Widthi, Widthj;
            _get_box, icn, jcn;
            _show_box, icn, jcn;
            _add_cats;
            Icn = icn;
            Jcn = jcn;
         } else if( cmd == "ls" ) { // comls
            astr = "";
            read,prompt="Enter file selection string : ... ", astr;
            ls,sel=astr;
         } else if( cmd == "e" ) { // come
            filename = get_next_filename("box_???.fits");
            finame = "";
            read,prompt="Accept "+filename+" or enter new : ... ",finame;
            if( strlen(finame) > 4 ) filename = finame;
            kwds_init;
            kwds_set,"EXTNAME","BOX_EXPORT","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"CREATOR","/r9/njw/work/scan_image.i","Software used";
            kwds_set,"ICN", Icn,"Center pixel X";
            kwds_set,"JCN", Jcn,"Center pixel Y";
            kwds_set,"IMAGEDOL", Dols(I_num),"DOL of mother image";
            kwds_set,"INUM", I_num,"Number of image (often energy index)";
            writefits,filename,Box,clobber=1;
            write,"Box has been exported to "+filename+" ...";
         } else if( cmd == "ew" ) { // comew  export workbox
            filename = get_next_filename("wbox_???.fits");
            finame = "";
            read,prompt="Accept "+filename+" or enter new : ... ",finame;
            if( strlen(finame) > 4 ) filename = finame;
            kwds_init;
            kwds_set,"EXTNAME","WBOX_EXPORT","Name of this extension";
            kwds_set,"DATE",ndate(3),"Date/time of creation";
            kwds_set,"CREATOR","/r9/njw/work/scan_image.i","Software used";
            kwds_set,"ICN", Icn,"Center pixel X";
            kwds_set,"JCN", Jcn,"Center pixel Y";
            kwds_set,"IMAGEDOL", Dols(I_num),"DOL of mother image";
            kwds_set,"INUM", I_num,"Number of image (often energy index)";
            writefits,filename,Workbox,clobber=1;
            write,"Workbox has been exported to "+filename+" ...";
         } else if( cmd == "cats" ) { // comcats  show catalogs read in
            nn = numberof(Cats);
            if( nn ) {
               for( i = 1; i <= nn; i++ ) {
                  astr = Cats_active(i) ? "" : "Inactive ";
                  write,format="%sCat#%i : %s\n", astr, i, Cats(i).catdol;
                  write,format="     Symbol %i, size %4.2f, color %s\n", \
                       Cats(i).symbol, Cats(i).size, Cats(i).color;
               }
            } else write,"No catalogs have been read in!";
         } else if( cmd == "tc" ) { // comtc toggle catalog  active/inactive
            cans = siparse(command_string,"i");
            nn = numberof(Cats);
            if( is_void(*cans.iparms) ) {
               if( nn ) {
                  for( i = 1; i <= nn; i++ ) {
                     astr = Cats_active(i) ? "" : "Inactive ";
                     write,format="%sCat#%i : %s\n", astr, i, Cats(i).catdol;
                     write,format="     Symbol %i, size %4.2f, color %s\n", \
                          Cats(i).symbol, Cats(i).size, Cats(i).color;
                  }
                  na = 1;
                  read,prompt="Which one to change? ... ", na;
                  Cats_active(na) = 1 - Cats_active(na);
               } else write,"No catalogs have been read in!";
            } else {
               na = (*cans.iparms)(1);
               if( na < 1 || na > nn ) {
                  write,"Parameter out of range (1-"+itoa(nn)+")";
               } else {
                  Cats_active(na) = 1 - Cats_active(na);
               }
            }
            _show_box, icn, jcn;
            _add_cats;
         } else if( cmd == "rc" ) { // comrc
            cans = siparse(command_string,"s");
            if( is_void(*cans.sparms) ) { // manual input
               grow, Cats, s_CAT();
               ncats = numberof(Cats);
               grow, Cats_active, 1;
               catdol = "";
               do {
                  read,prompt="Enter DOL of catalog ... ", catdol;
                  get_exten_no, catdol, catfile, extno;
               } while( !file_test(catfile) );
               color = "";
               read,prompt="Enter color of symbols ... ", color;
               symbol = int(0);
               read,prompt="Enter symbol type ... ", symbol;
               size = 0.;
               read,prompt="Enter symbol size ... ", size;
               Cats(ncats).catdol = catdol;
               Cats(ncats).color = color;
               Cats(ncats).symbol = symbol;
               Cats(ncats).size = size;
               ra_cat = rdfitscol(catdol,"ra_obj");
               Cats(ncats).ra_cat = &ra_cat;
               dec_cat = rdfitscol(catdol,"dec_obj");
               Cats(ncats).dec_cat = &dec_cat;
               Cats(ncats).nsrcs = numberof(ra_cat);
               write,itoa(Cats(ncats).nsrcs)+" sources in "+catdol;
            } else {
               local ips, colorz,symsz,dolz;
               lfname = (*cans.sparms)(1);
               while( !file_test(lfname) ) {
                  read,prompt="Failed - enter new file name : ... ", lfname;
               }
               rstab,lfname,4,ips,colorz,symsz,dolz,typ="isfs",silent=1;
               nips = numberof(ips);
               for( i = 1; i <= nips; i++ ) {
                  grow, Cats, s_CAT();
                  ncats = numberof(Cats);
                  grow, Cats_active, 1;
                  catdol = dolz(i);
                  get_exten_no, catdol, catfile, extno;
                  if( !file_test(catfile) ) {
                     write,format="Cannot find: %s\n", catfile;
                     continue;
                  }
                  Cats(ncats).catdol = catdol;
                  Cats(ncats).color = colorz(i);
                  Cats(ncats).symbol = ips(i);
                  Cats(ncats).size = symsz(i);
                  ra_cat = rdfitscol(catdol,"ra_obj");
                  Cats(ncats).ra_cat = &ra_cat;
                  dec_cat = rdfitscol(catdol,"dec_obj");
                  Cats(ncats).dec_cat = &dec_cat;
                  Cats(ncats).nsrcs = numberof(ra_cat);
                  write,itoa(Cats(ncats).nsrcs)+" sources in "+catdol;
               }
            }
         } else if( cmd == "wc" ) { // comwc
            ss = "";
            read,prompt="Enter name of output file: ... ", ss;
            kwds_init;
            kwds_set,"DATE", ndate(3),"Date/time of file creation";
            kwds_set,"RESPONSI","scan_image.i","Software used";
            kwds_set,"LOGFILE",logfilename,"Name of log file with comments";
            for( i = 1; i <= num_images; i++ ) {
               kwds_set,"DOL"+itoa(i),Dols(i),"DOL of image analyzed";
            }
            wrmfitscols,ss,"RA_OBJ", *Cats(1).ra_cat, "DEC_OBJ", *Cats(1).dec_cat, \
                   "DETSIG",*Cats(1).detsig, "FLAG",*Cats(1).flag, \
                   clobber=1,extname="SCAN_IMAGE_CAT";
            write,"    "+ss+" has been written";
         } else if( cmd == "gf" ) { // comgf  Gaussian flatfield
            cans = siparse(command_string, "r"); // expects a sigma
            if( is_void(*cans.rparms) ) {
               sigma = 1.;
               read,prompt="Enter sigma [pixel] ... ",format="%f", sigma;
            } else {
               sigma = (*cans.rparms)(1);
            }
            grow,Workbox,gflatfield(Workbox(,,0),sigma);
            grow,Workbox_toc,"gf sigma="+swrite(format="%9.4f",sigma);
            _show_box, icn, jcn;
            _add_cats;
         } else if( cmd == "ff" ) { // comff  Fourier flatfield
            cans = siparse(command_string, "i"); // expects a "freq"
            if( is_void(*cans.iparms) ) {
               if( is_void(_Freq) ) {
                  freq = 1;
                  read,prompt="Enter freq [pixel] ... ",format="%i", freq;
                  _Freq = freq;
               } else freq = _Freq;
            } else {
               _Freq = freq = (*cans.iparms)(1);
            }
            grow,Workbox,fflatfield(Workbox(,,0),freq);
            grow,Workbox_toc,"ff freq="+swrite(format="%4i",freq);
            _show_box, icn, jcn;
            _add_cats;
         } else if( cmd == "us" ) { // comus  make uniform scatter
            cans = siparse(command_string, "ir"); // expects tile and eps
            if( is_void(*cans.iparms) ) {
               if( is_void(_Tile) ) {
                  tile = 1;
                  read,prompt="Enter tile [number] ... ",format="%i", tile;
                  _Tile = tile;
               } else tile = _Tile;
            } else _Tile = tile = (*cans.iparms)(1);
            if( is_void(*cans.rparms) ) {
               eps = 1.e-7;
            } else eps = (*cans.rparms)(1);
            grow,Workbox,imscatter(Workbox(,,0),tile,eps=eps);
            grow,Workbox_toc,swrite(format="us tile= %i, eps=%11.3e",tile,eps);
            _show_box, icn, jcn;
            _add_cats;
         } else if( cmd == "ss" ) { // comss  show significance
            cans = siparse(command_string, "r"); // expects significance limit
            if( is_void(*cans.rparms) ) {
               if( is_void(_Siglim) ) {
                  siglim = 1.0;
                  read,prompt="Enter signif limit ... ",format="%f", siglim;
                  _Siglim = siglim;
               } else siglim = _Siglim;
            } else _Siglim = siglim = (*cans.rparms)(1);
            dcim = Workbox(,,0);
            w = where(dcim > siglim );
            if( numberof(w) ) dcim(w) = siglim;
            w = where(dcim < -1.0 );
            if( numberof(w) ) dcim(w) = -1.0;
            pli,dcim(0:1:-1,),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
            _add_cats;
         } else if( cmd == "d" ) { // comd
            dmsw = dimsof(Workbox);
            if( dmsw(4) == 1 ) {
               write,"Only one image in Workbox - no action ...";
            } else {
               Workbox = Workbox(,,1:-1);
               Workbox_toc = Workbox_toc(1:-1);
               i = dmsw(4)-1;
               if( i == 1 ) {
                  write,"Now just one image in Workbox ...";
               } else {
                  write,itoa(i)+" images in Workbox now ...";
               }
               _show_box, icn, jcn;
               _add_cats;
            }
         } else if( cmd == "ii" ) { // comii  Image information
            wim = Workbox(,,0);
            swim = indgen(numberof(wim));
            cans = siparse(command_string, "ssss"); // expects one or more keywords
            nkeys = numberof(*cans.sparms);
            plo = 0;
            for( i =  1; i <= nkeys; i++ ) {
               key = (*cans.sparms)(i);
               if( strpart(key,1:3) == "noz" ) {
                  swim = where(wim != 0.0);
               } else if( strpart(key,1:3) == "plo" ) {
                  plo = 1;
               } else {
                  write,"Ups, illegal keyword - use only noz or plo";
               }
            }
            if( numberof(swim) == 0 || max(wim(swim)) == min(wim(swim)) ) {
               write,"Singularity! Flat image.";
            } else {
               arr_info, wim(swim);
               histos,wim(swim),hz, xz,binsize=(max(wim(swim))-min(wim(swim)))/200;
               esti = [max(hz),sum(xz*hz)/sum(hz),sqrt(sum(xz^2*hz)/sum(hz))];
               local yfit;
               coefs = gaussfit(xz,hz,esti,yfit);
               write,format="Fit: ampl  = %9.4f\n", coefs(1);
               write,format="Fit: mean  = %9.4f\n", coefs(2);
               write,format="Fit: sigma = %9.4f\n", coefs(3);
               if( plo ) {
                  w2;
                  plot,xz,hz,ps=10;
                  oplot,xz,yfit,li=2;
                  w1; // reset to window #1 since e.g. 'm' works in that
               }
            }
         } else if( cmd == "f" ) { // comf  find source
            src_vec = peaksearch0(Workbox(,,0));
            // [maxval, xpos, ypos, peak signal, significance,
            //                          src_rad, bkg_rad1, bkg_rad2]
            write,format="At (%.4f,%.4f), max value = %.4f, signif = %.4f\n", \
                  src_vec(2), src_vec(3), src_vec(1), src_vec(5);
            psizelon = (Glon_ur - Glon_ll)/Widthi;
            glon = Glon_ll + (src_vec(2)-0.5)*psizelon;
            psizelat = (Glat_ur - Glat_ll)/Widthj;
            glat = Glat_ll + (src_vec(3)-0.5)*psizelat;
            write,format="Galactic: %8.3f %8.3f\n", glon, glat;
            oplot,[glon],[glat],ps=16,thick=3,color="white";
         } else if( cmd == "es" ) { // comes   erase source
            if( !is_void(src_vec) ) {
               src_vec(6) = _Src_rad;
               src_vec(7) = _Bkg_rad1;
               src_vec(8) = _Bkg_rad2;
               grow,Workbox,erase_source(Workbox(,,0),src_vec);
               grow,Workbox_toc,swrite(format="es galactic: %8.3f%8.3f",glon,glat);
               _show_box,icn,jcn;
            } else write,"No source defined - skip ...";
         } else if( cmd == "see" ) { // comsee
            if( is_void(_Src_rad) )  write,format=" 1: _Src_rad    %s\n", "<not set>";
            else write,format=" 1: _Src_rad   %9.4f\n", _Src_rad;
            if( is_void(_Bkg_rad1) ) write,format=" 2: _Bkg_rad1   %s\n", "<not set>";
            else write,format=" 2: _Bkg_rad1  %9.4f\n", _Bkg_rad1;
            if( is_void(_Bkg_rad2) ) write,format=" 3: _Bkg_rad2   %s\n", "<not set>";
            else write,format=" 3: _Bkg_rad2  %9.4f\n", _Bkg_rad2;
            if( is_void(_Sigma) )    write,format=" 4: _Sigma      %s\n", "<not set>";
            else write,format=" 4: _Sigma     %9.4f\n", _Sigma;
            if( is_void(_Freq) )     write,format=" 5: _Freq      %s\n", "<not set>";
            else write,format=" 5: _Freq      %4i\n", _Freq;
            if( is_void(_Tile) )     write,format=" 6: _Tile      %s\n", "<not set>";
            else write,format=" 6: _Tile      %4i\n", _Tile;
            if( is_void(_Siglim) )   write,format=" 7: _Siglim    %s\n", "<not set>";
            else write,format=" 7: _Siglim    %9.4f\n", _Siglim;
         } else if( cmd == "set" ) {
            cans = siparse(command_string,"ir");
            if( (*cans.iparms)(1) == 1 ) _Src_rad = (*cans.rparms)(1);
            if( (*cans.iparms)(1) == 2 ) _Bkg_rad1 = (*cans.rparms)(1);
            if( (*cans.iparms)(1) == 3 ) _Bkg_rad2 = (*cans.rparms)(1);
            if( (*cans.iparms)(1) == 4 ) _Sigma    = (*cans.rparms)(1);
            if( (*cans.iparms)(1) == 5 ) _Freq     = long((*cans.rparms)(1));
            if( (*cans.iparms)(1) == 6 ) _Tile     = long((*cans.rparms)(1));
            if( (*cans.iparms)(1) == 7 ) _Siglim   = (*cans.rparms)(1);
         } else if( cmd == "si" ) { // comsi   make significance image
            cans = siparse(command_string,"rrr");
            if( !is_void(*cans.rparms) ) {
               _Src_rad = (*cans.rparms)(1);
               _Bkg_rad1 = (*cans.rparms)(2);
               _Bkg_rad2 = (*cans.rparms)(3);
            }
            grow,Workbox,signif(Workbox(,,0));
            grow,Workbox_toc,"si";
            _show_box, icn, jcn;
            _add_cats;
         } else if( cmd == "?" ) { // com?
            cans = siparse(command_string,"s");
            if( is_void(*cans.sparms) ) { // show overview
               write,"a   autoscan,     m   mark and save,  cf  cut image,";
               write,"b   blink,        bc  blink with standard cuts,";
               write,"s   smooth,       p   new position,   i   general info,";
               write,"r   reverse scan, x   exit,           ?   help,";
               write,"z   zoom,         u   unzoom,         o   original,";
               write,"e   export Box to fits file,          d   move 1 up in Workbox";
               write,"ew  export Workbox to fits file,";
               write,"c   standard image cut,               ii  image info,";
               write,"n   change to next image, nc  change with standard cut,";
               write,"v   change to previous image, vc  change with standard cut,";
               write,"f   find source,  es  erase recently found source,";
               write,"ls  ls system command,";
               write,"rc  read source catalog, tc  activate/de-activate catalog,";
               write,"wc  write FITS file with sources defined in current session,";
               write,"gf  Gaussian flatfield,               ff  Fourier flatfield,";
               write,"si  make significance image,";
               write,"us  make uniform scatter image,";
               write,"ss  show significance when scaled appropriately,";
               write,"h j k l (vi analog) left, down, up, right by a 10th,";
               write,"cats  see the loaded catalogs,";
               write,"see   see parameter or parameters,";
               write,"set   set parameter or parameters";
            } else {
               if( (*cans.sparms)(1) == "p" ) {
                  write,"p [ic jc] - move frame to new position";
               } else if( (*cans.sparms)(1) == "a" ) {
                  write,"a         - move frame to next scan position";
               } else if( strpart((*cans.sparms)(1),1:1) == "n" ) {
                  write,"n [ie]    - go to next energy interval";
                  write,"nc [ie]   - go to next energy interval with image cut";
               } else if( strpart((*cans.sparms)(1),1:1) == "v" ) {
                  write,"v [ie]    - go to previous energy interval";
                  write,"vc [ie]   - go to previous energy interval with image cut";
               } else if( (*cans.sparms)(1) == "ii" ) {
                  write,"ii [plot] [nozeros] - image (top of stack) information";
                  write,"        with plot of histogram, exclude pixels with zero value";
               } else if( (*cans.sparms)(1) == "rc" ) {
                  write,"rc [file_with_list] - 'read catalog' asks for catalog DOL";
                  write,"        or reads one or more from the text file in s-format";
               } else if( (*cans.sparms)(1) == "tc" ) {
                  write,"tc [cat_number] - change status (active/inactive) for catalog";
               } else if( strpart((*cans.sparms)(1),1:2) == "se" ) {
                  write,"see                       - see all parameter values";
                  write,"set [param #] [new value] - set a parameter value";
               }
            }
         }
      }
   }
}

func _get_box( &icn, &jcn )
{
   // Extract image part into 'Box' and load into 'Workbox'

   extern Box, Ima, I_num, Workbox, Workbox_toc, Widthi, Widthj;
   extern Glon_ur,Glat_ll,Glon_ll,Glat_ur;
   extern Cats, Cats_active;
   extern erlog;

   write,erlog,format="##6## _get_box called with %i %i\n", icn, jcn;

   _i = icn;
   _j = jcn;
   Box = extract_box( Ima(,,I_num), icn, jcn, Widthi, Widthj, cen=1 );
   if( icn != _i || jcn != _j )  {
      write,format="New center pixel: %6i%6i\n", icn, jcn;
   }
   Workbox = Box(,,-);
   Workbox_toc = "original icn jcn = "+itoa(icn)+" "+itoa(jcn);

   w0;
   dwi = (Widthi-1)/2; dwj = (Widthj-1)/2;
   oplot,icn+[-dwi,dwi,dwi,-dwi,-dwi],jcn+[-dwj,-dwj,dwj,dwj,-dwj],color="white";
}

func _show_box( &icn, &jcn )
{

   // Displays highest level of Workbox


   extern Box, Ima, I_num, Workbox, Widthi, Widthj;
   extern Glon_ur,Glat_ll,Glon_ll,Glat_ur;
   extern Cats, Cats_active;
   extern erlog;

   write,erlog,format="##6## _show_box called with %i %i\n", icn, jcn;

   //+ _i = icn;
   //+ _j = jcn;
   //+ Box = extract_box( Ima(,,I_num), icn, jcn, Widthi, Widthj, cen=1 );
   //+ if( icn != _i || jcn != _j )  {
   //+    write,format="New center pixel: %6i%6i\n", icn, jcn;
   //+ }

   //+ w0;
   dwi = (Widthi-1)/2; dwj = (Widthj-1)/2;
   //+ oplot,icn+[-dwi,dwi,dwi,-dwi,-dwi],jcn+[-dwj,-dwj,dwj,dwj,-dwj],color="white";
   w1;

   // my own conversion of coords

   write,format="Now at %6i%6i\n", icn, jcn;
   myglon = Glon_scale(icn);
   if( myglon < 0. ) myglon += 360.;
   myglat = Glat_scale(jcn);
   write,format="Galact : %9.3f%9.3f\n",myglon,myglat;
   myradec = equatorial(myglon,myglat);
   write,format="RA Dec : %9.3f%9.3f\n", myradec(1), myradec(2);

   lli = icn - dwi;
   llj = jcn - dwj;
   uri = icn + dwi;
   urj = jcn + dwj;
   Glon_ll = Glon_scale(lli);
   Glat_ll = Glat_scale(llj);
   Glon_ur = Glon_scale(uri);
   Glat_ur = Glat_scale(urj);
   if( Glon_ll < 0.0 && Glon_ur < 0.0 ) {
      Glon_ll += 360;
      Glon_ur += 360;
   }
   plot,[-99],xr=[Glon_ll,Glon_ur],yr=[Glat_ll,Glat_ur], \
        title=itoa(I_num),xtitle="Gal. longitude",ytitle="Gal. latitude";
   pli,Workbox(0:1:-1,,0),Glon_ur,Glat_ll,Glon_ll,Glat_ur;
}

func _add_cats( void )
{
   extern Cats, Cats_active;

   write,erlog,"##7## _add_cats called";
   if( is_void(Cats_active) || is_void(Cats) ) {
      write,erlog,"##8## Immediate return from _add_cats";
      return;
   }

   nCats = Cats_active(sum);
   if( nCats ) {
      write,erlog,"##9## _add_cats found "+itoa(nCats)+" active catalogs";
      wcats = where(Cats_active);
      for( i = 1; i <= nCats; i++ ) {
         icat = wcats(i);
         if( Cats(icat).nsrcs > 0 ) {
            eq_nocopy, rac, *Cats(icat).ra_cat;
            eq_nocopy, decc, *Cats(icat).dec_cat;
            for( j = 1; j <= Cats(icat).nsrcs; j++ ) {
               g = galactic(rac(j),decc(j));
               oplot,[g(1)],[g(2)],ps=Cats(icat).symbol, \
                   color=Cats(icat).color, symsize=Cats(icat).size;
               oplot,[g(1)+360],[g(2)],ps=Cats(icat).symbol, \
                   color=Cats(icat).color, symsize=Cats(icat).size;
            }
         }
      }
   }
}

func siparse( str, types )
/* DOCUMENT sc = siparse( command_string, data_types )

     Returns a struct 's_command' with parsed values from the
     command string given the expected data types.

     Example:   >  sc = siparse( "smooth 3.0 4.0","rr" )
          sc.command :  "smooth"
          (*sc.rparms)(1) : 3.0
          (*sc.rparms)(2) : 4.0
*/
{
   // parameters must be space separated

   command = s_Command();
   str = strtrim(strcompress(str));
   keys = strsplit(str," ");
   nkeys = numberof(keys);
   // initialize
   s_nill = [];
   command.rparms = &s_nill;
   command.iparms = &s_nill;
   command.sparms = &s_nill;

   if( nkeys == 1 ) {
      command.command = keys;
   } else {
      command.command = keys(1);
      if( typeof(types) == "string" ) {
         ntypes = strlen(types);
         if( ntypes < nkeys-1 ) {
            write,"siparse: too many keywords - truncated";
            nkeys = ntypes+1;
            keys = keys(nkeys);
         }
         vreal = vint = vstr = [];
         if( ntypes ) {
            for( i = 1; i < nkeys; i++ ) {
               strp = keys(i+1);
               typ = strpart(types,i:i);
               if( typ=="r" ) {
                  grow,vreal,atof(strp);
               } else if( typ=="i" ) {
                  grow,vint,atoi(strp);
               } else if( typ=="s" ) {
                  grow,vstr,strp;
               } else {
                  error,"Invalid type definition";
               }
            } // for( i = ...
         } // if( ntypes )
         command.rparms = &vreal;
         command.iparms = &vint;
         command.sparms = &vstr;
      }
   }
   return command;
}

func imscatter( im, tile, eps= )
/* DOCUMENT new_image = imscatter( im, tile, eps= )

   Divides the image 'im' into 'tile' x 'tile' squares,
   evaluates the average and RMS by fitting a gaussian
   to the histogram of values. In this way the influence
   of a few localized areas with extreme values (such as
   point sources) is avoided.

   It returns an image scaled to an RMS of 1 i.e. like a
   significance image.

   Keyword 'eps' : sets the lower limit for useful pixel values
       meaning that all pixels with abs(values) < eps will
       be disregarded. Default is 1.e-9

   2010-09-23/NJW
*/
{
   local x, h, yfit;

   if( is_void(eps) ) eps = 1.e-9;

   imout = double(im);
   dms = dimsof( im );
   istep = dms(2)/tile;
   jstep = dms(3)/tile;
   i1 = 1;
   for( i = 1; i <= tile; i++ ) {
      j1 = 1;
      i2 = i == tile ? dms(2) : i1 + istep - 1;
      for( j = 1; j <= tile; j++ ) {
         j2 = j == tile ? dms(3) : j1 + jstep - 1;
         wim = imout(i1:i2,j1:j2);
         valid = where( abs(wim) > eps );
         nvalid = numberof(valid);
         if( nvalid > 100 ) {
            bs = (max(wim)-min(wim))/100;
            histos,wim(valid),h,x,binsize=bs;
            esti = [max(h),sum(x*h)/sum(h),sqrt(sum(x^2*h)/sum(h))];
            coefs = gaussfit( x, h, esti, yfit );
            //+ write,format="i j: %4i%4i, avg: %9.4f, rms: %9.4f\n", \
            //+      i,j,coefs(2), coefs(3);
            imout(i1:i2,j1:j2) = (wim - coefs(2))/coefs(3);
         } else if( nvalid > 10 ) {
            imout(i1:i2,j1:j2) = (wim - wavg(wim(valid)))/wrms(wim(valid));
         }
         // No change if 10 or fewer valid values
         j1 += jstep;
      }
      i1 += istep;
   }
   return imout;
}
%FILE% scom.i
extern scomdoc;
/* DOCUMENT ********************************************************
 *
 *    S file format package
 *
 *  2004-08-23/Niels J. Westergaard
 *  2009-07-21/NJW added function 'wstab'
 *
      comblock           n_columns
      comget
      comgets            rscol              
      comreplace         rstab              
      comreplaces        scomget            
      get_spar           scomgets           
      get_spar_dec       scomreplace        
      get_spar_ra        scomreplaces       
      get_spars          wsmat
      rsmat              wstab

 ******************************************************************/

/* Function comget */

func comget( file, keyword_str, lng= )
/* DOCUMENT res = comget( file, keyword_str, lng=)
   Returns an array of values from lines:
      // keyword_str = value; comment field
   Format: Initial '//' (MUST be in position 1 and 2)
           keyword string CANNOT contain spaces
           Equal sign '=' MUST be present
   Everything following and including the ';' sign is disregarded

   Keyword   lng:   Converts to long integer

   2004-08-24/NJW
*/

{

   return scomget( rdfile(file), keyword_str, lng=lng );

}

/* Function comgets */

func comgets( file, keyword_str )
/* DOCUMENT res = comgets( file, keyword_str)
   Returns an array of string values from lines:
       // keyword_str = string

   2004-09-12/NJW

*/

{

   return scomgets( rdfile(file), keyword_str );

}

/* Function scomget */

func scomget( string_arr, keyword_str, lng= )
/* DOCUMENT res = scomget(string_arr, keyword_str, lng=)
   Returns an array of values read from an S-format string array.
   If keyword 'lng ' is set then long integers are returned.

*/

{

   values = [];
   nval = 0;
   for ( i = 1; i <= numberof(string_arr); i++ ) {
      line = string_arr(i);
      if( strpart(line,1:2) == "//" ) {
         // remove comment part
         cpos = strpos(line,";",3);
         if( cpos > 3 ) line = strpart(line,1:cpos-1);
         pe = strpos(line,"=",3);
         comp = strtrim(strpart(line,3:pe-1));

         if( keyword_str == comp ) {

            if( lng ) {
               value = 1;
               n = sread(strpart(line,pe+1:),format="%d",value);
            } else {
               value = 1.0;
               n = sread(strpart(line,pe+1:),format="%f",value);
            }
            if( n == 1 ) grow, values, value;
         }
      }
   }

   n = numberof(values);
   return n == 1 ? values(1) : values;

}

/* Function scomgets */

func scomgets( string_arr, keyword_str )
/* DOCUMENT res = scomgets(string_arr, keyword_str)
   Returns an array of string values from an array in
   S-format.
*/

{

   values = [];
   nval = 0;
   n = 0;
   for ( i = 1; i <= numberof(string_arr); i++ ) {
      line = string_arr(i);
      if( strpart(line,1:2) == "//" ) {
         // remove comment part
         cpos = strpos(line,";",3);
         if( cpos > 3 ) line = strpart(line,1:cpos-1);
         pe = strpos(line,"=",3);
         comp = strtrim(strpart(line,3:pe-1));

         if( keyword_str == comp ) {
            value = strtrim(strpart(line,pe+1:));
            grow, values, value;
         }
      }
   }

   n = numberof(values);
   return n == 1 ? values(1) : values;

}

/* Function n_columns */

func n_columns( file_name, sep= )
/* DOCUMENT n = n_columns(file_name, sep=)

   2004-09-15/NJW

   Part of 'scom' package

    Return the number of columns in the first line that starts with
    a number i.e. not a comment.

    Keyword  sep  :  Separator string (single character)
                     Default is space (blank).
*/
{

   require, "idlx.i";

   // Define separator

   if( is_void(sep) ) sep = " ";

   ncol = -1; // to be returned if no numbers found
   file = open(file_name,"r");
   flag = 1;
   while( flag && (line = rdline(file)) ) {

      pos = strpos(line,";",1);
      if( pos > 0 ) line = strpart(line,1:pos-1);
                               // remove ';' and what follows (comments)
      line = strcompress(line,st=sep); // multiple separators and tabs to single occurrences
      line = strtrim(line); // remove leading and trailing blanks
      len = strlen(line);
      if( len > 0 ) {     // skip if no characters on line
         cc = strpart(line,1:1);
         if( cc == "." && len > 1 ) cc = strpart(line,2:2);
         n = strpos("+-0123456789",cc,1);
         if( n > 0 ) {  // here we have a number
            ncol = numberof(strsplit(line,sep));
            flag = 0; // terminate while loop
         }
      }
   }
   close,file;

   return(ncol);

}

/* Function comblock */

func comblock( file, nblock )
/* DOCUMENT  [lnum1,lnum2] = comblock( file, nblock )

    Member of scom package

    2004-09-12/NJW

*/

{

/*

       Returns 2 element line_number begin, line_number end.

    Reads an ASCII file 'file' searching for lines beginning with '//'
    followed by 'block = nnnnn'  e.g. :

      // block = 123

      IDL> comblock,'myfile', 114, ln_begin, ln_end
           returns the linenumbers for the beginning (ln_begin)
           and the end (ln_end) of block #114
           Both are set to -1 if the block is not found
*/

   file = open(file,"r");
   s = " ";
   lns = array(0,1000);
   bns = array(0,1000);
   bn = 0;
   linenumber = 1;
   k = 1;
   while( s = rdline(file) ) {
      if( strpart(s,1:2) == "//" ) {
         pos = strpos(s,"block",3);
         if( pos >= 1 ) {    // string has been found
            pe = strpos(s,"=",pos+5);
            if( pe >= 1 ) {   // an equal sign has been found
               sb = strpart(s,3:pe-1);
               psemi = strpos(s,";",3);
               if( psemi == 0 ) psemi = strlen(s)+1;
               // Make sure that the only the search string is present
               if( strtrim(sb) == "block") {
                  sread,strpart(s,pe+1:psemi-1),bn;
                  bns(k) = bn;
                  lns(k) = linenumber;
                  k++;
               }
            }
         }
      }
      linenumber++;
   }
   close,file;

   if( k > 1 ) {
      lns = lns(1:k);
      bns = bns(1:k);
      lns(k) = linenumber - 1;
      bns(k) = 99999;
      k_ok = where( nblock == bns );
      nk_ok = numberof(k_ok);
      if( nk_ok > 0 ) {
         ln_begin = lns(k_ok(1))+1;
         ln_end   = lns(k_ok(1)+1) - (bns(k_ok(1)+1) != 99999);
          // bns == 99999 signals end of file and ln_end is not to be reduced by one
      } else {
         ln_begin = -1;
         ln_end   = -1;
      }
   } else {
      ln_begin = -1;
      ln_end   = -1;
   }
   return([ln_begin,ln_end]);
}

/* Function rscol */

func rscol(filename, col_def, str=,nt=,lng=,dble=,silent=,block=,typ=,sep=,nomem=)
/* DOCUMENT col = rscol( filename, col_def, str=, nt=,lng=,
                      dble=, silent=, block=, typ=, sep=, nomem=)

     Read a column from an ASCII file where numbers are organized as a table
     If the column should be read as a string then the keyword 'str' must be set.
     Default type is float. Keywords exist for int, long and double.
     Alternatively 'typ' can be given "i":int, "j":long, "d":double, "f":float, "s":string.
     The columns can be numbers or character strings separated with
     blanks or the character as given in keyword 'sep'. The first column (number 1) must
     always start with one of +-.0123456789.

     The lines that start with other characters are interpreted as
     comment lines and will be displayed but skipped in
     the reading of the data.

     If the 'block' keyword is given with a block number
     then the file will be scanned for existence of lines:
         // block = nnn
     and only the table rows between where nnn matches the
     given block number and the next '// block = xxx'

     Keyword: nomem    Disselects the use of memory i.e. when files are expected to change
                       between readings

     Other procedures required: n_columns.pro
                                comblock.pro

     2004-09-12/NJW
     2009-10-22/NJW, updated to use mem_storage if not disselected

*/

{

   vb = silent ? 0 : 1;

   // Define type of returned array

   type = 4 ; // float
   if (str) type = 7 ; // string
   if (lng) type = 3 ; // long
   if (dble) type = 5 ; // double
   if (nt)  type = 2 ; // integer
   if( typeof(typ) == "string" ) {
      if( strlen(typ) == 1 ) {
         if( typ == "i" ) type = 2;
         if( typ == "j" ) type = 3;
         if( typ == "f" ) type = 4;
         if( typ == "d" ) type = 5;
         if( typ == "s" ) type = 7;
      }
   }

   //  --- memory usage: define storage name
   //      as filename+column-number+block-number

   // Column separator

   if( is_void(sep) ) sep = " "; // Default separator is space (blank)

   // If column designator is a string then find the matching
   // number

   vartype = typeof(col_def);
   if( vartype == "string" ) {
      // get the column names
      colnames = comgets(filename,"colname");
      if( numberof(colnames) == 0 ) {
         write,"Error - no keyword colname found";
         return [];
      }
      w = where( colnames == col_def );
      if( numberof(w) ) {
         col_number = w(1);
      } else {
         write,"Error: no such column name has been found";
         return([]);
      }
   } else {
      col_number = col_def;
   }
   col_num = col_number;

   // Initiate use of block (i.e. only take data from a
   // specified block

   ln_begin = 1;
   ln_end = 0; // means no upper limit
   useblock = 0;
   if (block) {
      useblock = 1;
      // nblock = long(block);
      line_nums = comblock(filename, block);
      if(line_nums(1) == -1 ) {
         write,"RSCOL Warning: Requested block not found";
         write,"                 Proceed reading all data";
         useblock = 0;
      } else {
         ln_begin = line_nums(1);
         ln_end   = line_nums(2);
      }
   }

   // --- set memory name

   mem_name = filename+itoa(col_num);
   if( useblock ) mem_name += "_"+itoa(block);

   if( 0 == mem_restore( mem_name, col_dat ) && !nomem ) return col_dat;

   // See if requested column number is less than or equal to
   // the number of columns

   if( vb ) write,format="RSCOL: at least %d columns expected in %s\n",col_number, filename;
   nc = n_columns(filename,sep=sep);
   if( vb ) write,format="%d columns found in file: %s\n", nc, filename;

   if( col_number > nc ) {
      write,format="RSCOL: only %d columns found in file\n",nc;
      return([]);
   }

   // Prepare reading the file in chunks of 'nmax' lines

   nmax = 300;
   cur_size = nmax;

   file = open(filename,"r");

   if( type == 2 ) {
      col_dat = array(int,nmax);
   } else if( type == 3 ) {
      col_dat = array(long,nmax);
   } else if( type == 4 ) {
      col_dat = array(float,nmax);
   } else if( type == 5 ) {
      col_dat = array(double,nmax);
   } else if( type == 7 ) {
      col_dat = array("",nmax);
   }

   x = array(float,nc);
   s = " ";
   kount = 1;
   linenumber = 0;

   while( s = rdline(file) ) {

     linenumber++;
     pos = strpos(s,";",1);
     if( pos > 0 ) {
        ss = strpart(s,1:pos-1);
     } else ss = s;
     st = strtrim(ss,blank=" "+sep); // remove leading and trailing blanks
     if( strlen(st) > 0 ) {
        if( !strmatch("+-.0123456789",strpart(st,1:1))  ) {
              if( vb ) write,format="%s\n",s;
        } else {
           su = strcompress(st,st=sep); // reduce all separators to single occurrences
           elmnts = strsplit(su,sep); // separate into columns

           if( linenumber >= ln_begin &&
                  (linenumber <= ln_end || ln_end == 0) ) {
              if( type == 7 ) {
                   col_dat(kount) = elmnts(col_number);
              } else {
                   n = sread(elmnts(col_number),col_dat(kount));
              }
              kount++;
           }


           // Check if expansion is needed

           if( kount == cur_size + 1) {

              grow,col_dat,array(col_dat(1),nmax);
              cur_size += nmax;

           }
        }
      }
   }
   if( vb ) write,format="RSCOL Size of table = %d\n",kount-1;
   col_dat = kount == 1 ? [] : col_dat(1:kount-1);
   close,file;

   if( !nomem ) mem_save, mem_name, col_dat;

   return( col_dat );

}

/* Function rstab */

func rstab( filename, ncols, &c1, &c2, &c3, &c4, &c5, &c6, &c7, &c8, &c9, &c10, &c11, &c12, &c13, \
            block=, typ=, sep=, silent= )
/* DOCUMENT rstab, filename, ncols, >c1, >c2, ..., block=, typ=, sep=, silent=

   Reads S-format text file and returns columns in c1, c2, ... up to and including c13
   The second argument must give the requested number of columns.

   Keyword 'typ' can be given as a string with as many characters as there are columns.
   i: int, j: long, f: float, d: double, s: string
   (defaults to 'double'). It must be given if some column values are incompatible with
   numbers. A dash causes skipping the column entirely.
   Keyword 'sep' indicates the column separator if different from space.

   e.g. file "myfile.scm":
     // here are some data
        1 1.2345e2 background 11.23
        2 5.5142e3 foreground 12.85

   can be read with: > rstab,"myfile.scm",4,n,y,denom,calib,typ="idsf"

   or, if only column 1 and 4 are to be read:

   > rstab,"myfile.scm",2,n,calib,typ="i--f"

   2008-08-13/NJW
   2009-07-20/NJW updated for more efficient reading
*/
{
   vb = is_void(silent);
   if(is_void(sep) ) sep = " ";

   // 'ncols' is the number of requested columns to return

   if(vb) write,format="RSTAB: %i first columns were requested\n", ncols;

   if( typeof(typ) == "string" ) {
      types = (*pointer(typ))(1:-1); // drop trailing null
      wtypes = where(types != '-');
      typw = types(wtypes);
      len = numberof(wtypes);
      if( len != ncols ) {
         write,"Mismatching typ and number of columns - default to double";
         typw = array('d',ncols);
         wtypes = indgen(ncols);
      }
   } else {
      typw = array('d',ncols);
      wtypes = indgen(ncols);
   }

   // Initiate use of block (i.e. only take data from a
   // specified block

   ln_begin = 1;
   ln_end = 0; // means no upper limit
   useblock = 0;
   if (block) {
      useblock = 1;
      // nblock = long(block);
      line_nums = comblock(filename, block);
      if(line_nums(1) == -1 ) {
         write,"RSTAB Warning: Requested block not found";
         write,"                 Proceed reading all data";
         useblock = 0;
      } else {
         ln_begin = line_nums(1);
         ln_end   = line_nums(2);
      }
   }

   // See if requested number of columns is less than or equal to
   // the existing number of columns

   if( vb ) write,format="RSTAB: at least %i columns expected in %s\n", ncols, filename;
   // 'nc' is number of existing columns in the file
   nc = n_columns(filename,sep=sep);
   if( vb ) write,format="%d columns found in file: %s\n", nc, filename;

   if( ncols > nc ) {
      write,format="RSTAB: only %d columns found in file\n",nc;
      return([]);
   }

   // Prepare reading the file

   nmax = 300;
   cur_size = nmax;

   file = open(filename,"r");

   c1 = array(struc(typw(1)),nmax);
   if( ncols > 1 ) c2 = array(struc(typw(2)),nmax);
   if( ncols > 2 ) c3 = array(struc(typw(3)),nmax);
   if( ncols > 3 ) c4 = array(struc(typw(4)),nmax);
   if( ncols > 4 ) c5 = array(struc(typw(5)),nmax);
   if( ncols > 5 ) c6 = array(struc(typw(6)),nmax);
   if( ncols > 6 ) c7 = array(struc(typw(7)),nmax);
   if( ncols > 7 ) c8 = array(struc(typw(8)),nmax);
   if( ncols > 8 ) c9 = array(struc(typw(9)),nmax);
   if( ncols > 9 ) c10 = array(struc(typw(10)),nmax);
   if( ncols > 10 ) c11 = array(struc(typw(11)),nmax);
   if( ncols > 11 ) c12 = array(struc(typw(12)),nmax);
   if( ncols > 12 ) c13 = array(struc(typw(13)),nmax);

   kount = 1;
   linenumber = 0;

   while( s = rdline(file) ) {

     linenumber++;
     pos = strpos(s,";",1);
     if( pos > 0 ) {
        ss = strpart(s,1:pos-1);
     } else ss = s;
     cst = strtrim(ss,blank=sep+" "); // remove leading and trailing separators
     if( strlen(cst) > 0 ) {
        if( !strmatch("+-.0123456789",strpart(cst,1:1))  ) {
              if( vb ) write,format="%s\n",s;
        } else {
           su = strcompress(cst,st=sep); // reduce all separators to single separators
           elmnts = strsplit(su,sep); // separate into columns

           if( linenumber >= ln_begin &&
                  (linenumber <= ln_end || ln_end == 0) ) {
              c1(kount) = _str2x( elmnts(wtypes(1)), typw(1) );
              if( ncols > 1 ) c2(kount) = _str2x( elmnts(wtypes(2)), typw(2) );
              if( ncols > 2 ) c3(kount) = _str2x( elmnts(wtypes(3)), typw(3) );
              if( ncols > 3 ) c4(kount) = _str2x( elmnts(wtypes(4)), typw(4) );
              if( ncols > 4 ) c5(kount) = _str2x( elmnts(wtypes(5)), typw(5) );
              if( ncols > 5 ) c6(kount) = _str2x( elmnts(wtypes(6)), typw(6) );
              if( ncols > 6 ) c7(kount) = _str2x( elmnts(wtypes(7)), typw(7) );
              if( ncols > 7 ) c8(kount) = _str2x( elmnts(wtypes(8)), typw(8) );
              if( ncols > 8 ) c9(kount) = _str2x( elmnts(wtypes(9)), typw(9) );
              if( ncols > 9 ) c10(kount) = _str2x( elmnts(wtypes(10)), typw(10) );
              if( ncols > 10 ) c11(kount) = _str2x( elmnts(wtypes(11)), typw(11) );
              if( ncols > 11 ) c12(kount) = _str2x( elmnts(wtypes(12)), typw(12) );
              if( ncols > 12 ) c13(kount) = _str2x( elmnts(wtypes(13)), typw(13) );
              kount++;
           }


           // Check if expansion is needed

           if( kount == cur_size + 1) {

              grow,c1,array(struc(typw(1)),nmax);
              if( ncols > 1 ) grow,c2,array(struc(typw(2)),nmax);
              if( ncols > 2 ) grow,c3,array(struc(typw(3)),nmax);
              if( ncols > 3 ) grow,c4,array(struc(typw(4)),nmax);
              if( ncols > 4 ) grow,c5,array(struc(typw(5)),nmax);
              if( ncols > 5 ) grow,c6,array(struc(typw(6)),nmax);
              if( ncols > 6 ) grow,c7,array(struc(typw(7)),nmax);
              if( ncols > 7 ) grow,c8,array(struc(typw(8)),nmax);
              if( ncols > 8 ) grow,c9,array(struc(typw(9)),nmax);
              if( ncols > 9 ) grow,c10,array(struc(typw(10)),nmax);
              if( ncols > 10 ) grow,c11,array(struc(typw(11)),nmax);
              if( ncols > 11 ) grow,c12,array(struc(typw(12)),nmax);
              if( ncols > 12 ) grow,c13,array(struc(typw(13)),nmax);
              cur_size += nmax;

           }
        }
      }
   }
   if( vb ) write,format="RSTAB Size of table = %d\n",kount-1;
   c1 = kount == 1 ? [] : c1(1:kount-1);
   if( ncols > 1 ) c2 = kount == 1 ? [] : c2(1:kount-1);
   if( ncols > 2 ) c3 = kount == 1 ? [] : c3(1:kount-1);
   if( ncols > 3 ) c4 = kount == 1 ? [] : c4(1:kount-1);
   if( ncols > 4 ) c5 = kount == 1 ? [] : c5(1:kount-1);
   if( ncols > 5 ) c6 = kount == 1 ? [] : c6(1:kount-1);
   if( ncols > 6 ) c7 = kount == 1 ? [] : c7(1:kount-1);
   if( ncols > 7 ) c8 = kount == 1 ? [] : c8(1:kount-1);
   if( ncols > 8 ) c9 = kount == 1 ? [] : c9(1:kount-1);
   if( ncols > 9 ) c10 = kount == 1 ? [] : c10(1:kount-1);
   if( ncols > 10 ) c11 = kount == 1 ? [] : c11(1:kount-1);
   if( ncols > 11 ) c12 = kount == 1 ? [] : c12(1:kount-1);
   if( ncols > 12 ) c13 = kount == 1 ? [] : c13(1:kount-1);

   close,file;


   if(vb)write,format="RSTAB: %i columns with %i rows read.\n", ncols, numberof(c1);

}

/* Function scomreplaces */

func scomreplaces( string_arr, keyword_str, new_string )
/* DOCUMENT res = scomreplaces(string_arr, keyword_str, new_string)

   Replaces the string value(s) given with keyword 'keyword_str'
   with 'new_string'. 'new_string' can be a single string or an
   array of same number of elements as there are keywords of the
   chosen name in the input string array.

    2009-03-27/NJW

*/

{

   nnew = numberof(new_string);
   res = []; // string array to be returned

   values = [];
   nval = 0;
   n = 0;
   for ( i = 1; i <= numberof(string_arr); i++ ) {
      line = string_arr(i);
      if( strpart(line,1:2) == "//" ) {
         // save comment part and strip
         cpos = strpos(line,";",3);
         csave = [];
         wline = line;
         if( cpos > 3 ) {
            csave = strpart(line,cpos:);
            wline = strpart(wline,1:cpos-1);
         }
         pe = strpos(wline,"=",3);
         if( pe <= 3 ) { // not a keyword anyway
            grow, res, line;
            continue;
         }
         // trim to find keyword candidate
         comp = strtrim(strpart(wline,3:pe-1));

         if( keyword_str == comp ) {
            // found the keyword, do replacement
            nval++;
            if( nnew != 1 && nval > nnew ) {
               write,"scomreplaces error, too few replacement values";
               return string_arr;
            }
            j = nnew == 1 ? 1 : nval;
            line = strpart(wline,1:pe)+" "+new_string(j);
            if( !is_void(csave) ) line += csave;
            grow, res, line;
         } else { // wrong keyword
            grow, res, line;
         }
      } else {
         grow, res, line;
      }
   }

   return res;

}

/* Function comreplaces */

func comreplaces( file, keyword_str, new_string )
/* DOCUMENT complaces, file, keyword_str, new_string


*/
{
   str = rdfile( file );
   str = scomreplaces( str, keyword_str, new_string );
   write_slist, file, str;
}

/* Function scomreplace */

func scomreplace( string_arr, keyword_str, new_values )
/* DOCUMENT res = scomplace( string_arr, keyword_str, new_values )

*/
{
   tty = typeof(new_values);
   if( tty == "double" ) {
      new_string = swrite(format="%.14e", new_values);
   } else if( tty == "float" ) {
      new_string = swrite(format="%.8e", new_values);
   } else if( tty == "long" || tty == "int" ) {
      new_string = swrite(format="%i", new_values);
   } else {
      write,"data format not supported";
      return string_arr;
   }
   return scomreplaces( string_arr, keyword_str, new_string );
}

/* Function comreplace */

func comreplace( file, keyword_str, new_values )
/* DOCUMENT complace, file, keyword_str, new_values


*/
{
   str = rdfile( file );
   str = scomreplace( str, keyword_str, new_values );
   write_slist, file, str;
}

/* Function get_spar */

func get_spar( filename, parname, lng= )
/* DOCUMENT parval = get_spar( filename, parname, lng= )

 Return the new parameter : double [default]
                           long     -  keyword "lng"

*/
{
   par_new = comget(filename, parname,lng=lng);

   if( lng ) write,format="Default %s [%i]\n",parname,par_new;
   else write,format="Default %s [%.4g]\n",parname,par_new;

   answer = rdline(prompt="Accept with Rtrn or enter new "+parname+" (string) : ... ");
   if( strlen(answer) ) {
      if( lng ) {
         par_new = tolong(answer);
      } else {
         par_new = atof(answer)
      }
      comreplace, filename, parname, par_new;
   }
   if(lng)write,format="The new %s is %i\n", parname, par_new;
   else write,format="The new %s is %.4g\n", parname, par_new;

   return par_new;
}

/* Function get_spar_dec */

func get_spar_dec( filename, parname )
/* DOCUMENT par = get_spar_dec( filename, parname )

    Return an s-format real Dec parameter by dialogue
        where DMS format is possible
*/
{

   par_new = comget(filename, parname);
   
   write,"Default "+parname+" [", par_new," or ", adstring(0,par_new),"]";
   answer = rdline( prompt="Accept with Rtrn or enter new "+parname+" (string) : ... ");
   
   if( strlen(answer) ) {
      answer = strcompress(strtrim(answer));
      tok = strsplit(answer," ")
      if( numberof(tok)  ==  1 ) par_new = atof(answer);
      if( numberof(tok)  ==  2 ) par_new = ten(atof(tok(1)),atof(tok(2)));
      if( numberof(tok)  >  2 ) par_new = ten(atof(tok(1)),atof(tok(2)),atof(tok(3)));
      comreplace,filename, parname, par_new;
   }
   write,"The new "+parname+" is: ", par_new;
   return par_new;
}

/* Function get_spar_ra */

func get_spar_ra( filename, parname )
/* DOCUMENT par = get_spar_ra( filename, parname )

    Return an s-format real RA parameter by dialogue
      where HMS format is possible
*/
{

// Get the new parameter; Special for RA

   par_new = comget(filename, parname);
   
   write,"Default "+parname+" [", par_new," or ", adstring(par_new,0),"]";
   answer = rdline( prompt="Accept with Rtrn or enter new "+parname+" (string) : ... ");
   
   if( strlen(answer) ) {
      answer = strcompress(strtrim(answer));
      tok = strsplit(answer," ");
      if( numberof(tok)  ==  1 ) par_new = atof(answer);
      if( numberof(tok)  ==  2 ) par_new = 15.*ten(atof(tok(1)),atof(tok(2)));
      if( numberof(tok)  >  2 ) par_new = 15.*ten(atof(tok(1)),atof(tok(2)),atof(tok(3)));
      ierr = comreplace(filename, parname, par_new);
   }
   write,"The new "+parname+" is: ", par_new;
   return par_new;
}

/* Function get_spars */

func get_spars( filename, parname )
/* DOCUMENT par = get_spars( filename, parname )

    Return an s-format string parameter by dialogue
*/
{

   // Get the new string valued parameter
   
   par_new = comgets(filename, parname);
   write,"Default "+parname+" [", par_new,"]";
   answer = rdline( prompt="Accept with Rtrn or enter new "+parname+" (string) : ... ");
   if( strlen(answer) ) {
      par_new = answer;
      comreplaces,filename, parname, par_new;
   }
   write,"The new "+parname+" is: ", par_new;
   return par_new;
}

/* Function wstab */

func wstab( filename, .., fmt=, hdr=, app= )
/* DOCUMENT wstab, filename, arr1, arr2, ..., fmt=, hdr=, app=

   Write a number of columns to a file as specified by a format string

   KEYWORD: hdr     a string array that will be written
                    in the start of the file.
            app     Append to an existing file
            fmt     Format string (like "%5.0f%13s%6.2f")

   2005-01-03/NJW, update 2005-04-14/NJW
   2007-09-13/NJW, update with append option
   2008-08-13/NJW, update with format option

*/

{
   local coldata;

   if( app ) {
      f = open( filename,"a");
   } else {
      f = open( filename,"w");
   }
   if( (num = numberof(hdr)) ) {
      for( i = 1; i <= num; i++ ) {
         write,f,format="%s\n",hdr(i);
      }
   }

   first = 1;
   ncols = 0;
   while( more_args() ) {
      ncols++;
      buffer = next_arg();
      //+ write,format="%i elements in col#%i\n", numberof(buffer), ncols;
      if( first ) {
         list = _lst(buffer);
         nrows = numberof(buffer);
         //+ write,format="nrows = %i (ncols = %i)\n", nrows, ncols;
         first = 0;
      } else {
         list = _cat(list,_lst(buffer));
         nr = numberof(buffer);
         //+ write,format="nr = %i (ncols = %i)\n", nr, ncols;
         if( nr != nrows ) {
            write,format="Column #%i has wrong number of elements\n", ncols;
            return;
         }
      }
   }

   //  assign standard formats if not given

   fmtflag = typeof( fmt ) == "string" ? 1 : 0;
   if( fmtflag ) {
      fmtpart = strsplit( fmt, "%" );
      nfmtpart = numberof(fmtpart);
      for(i=1;i<=nfmtpart;i++) {
         fmtpart(i) = "%"+fmtpart(i);
      }
      if( nfmtpart != ncols ) {
         write,"Bad number of format specifications - use defaults";
         fmtflag = 0;
      }
   }
   if( !fmtflag) {
      fmtpart = array(string,ncols);
      for(i=1;i<=ncols;i++) {
         typ = typeof(_car(list,i));
         if( typ == "string" ) {
            fmtpart(i) = " %s ";
         } else if( typ == "int" || typ == "long" || typ == "char" ) {
            fmtpart(i) = " %i ";
         } else if( typ == "float" ) {
            fmtpart(i) = " %13.6e ";
         } else if( typ == "double" ) {
            fmtpart(i) = " %17.10e ";
         } else {
            write,"Data type not supported";
            return;
         }
      }
   }

   //  do the writing to file

   for( i = 1; i <= nrows; i++ ) {
      for( j = 1; j <= ncols; j++ ) {
         eq_nocopy, coldata, _car(list,j);
         write,f,format=fmtpart(j), coldata(i);
      }
      write,f,format="%s\n","";
   }

   close,f;

}

/* Function rsmat */

func rsmat( filename, nt=, lng=, dble=, flt=, block=, skip=, silent= )
/* DOCUMENT arr = rsmat( filename, nt=, lng=, dble=, flt=, block=, skip=, silent= )

   Returns s-format array of type specified by keyword nt, lng, dble, or flt
   (default is double).

   Keyword 'skip' is the number of columns to skip counting from the first
           'silent' will suppress additional screen output

   2009-07-23/NJW
*/
{
   vb = !silent;
   if(is_void(skip)) skip = 0;

   typ = 'd'; // default
   if( nt ) typ = 'i';
   if( lng ) typ = 'j';
   if( flt ) typ = 'f';

   if( !file_test(filename) ) {
      write,"RSMAT: File not found: "+filename;
      return [];
   }
   file = open(filename,"r");

   nc = n_columns(filename);
   if( vb ) write,format="%d columns found in file: %s\n", nc, filename;

   // Initiate use of block (i.e. only take data from a
   // specified block

   ln_begin = 1;
   ln_end = 0; // means no upper limit
   useblock = 0;
   if (block) {
      useblock = 1;
      // nblock = long(block);
      line_nums = comblock(filename, block);
      if(line_nums(1) == -1 ) {
         write,"RSMAT Warning: Requested block not found";
         write,"                 Proceed reading all data";
         useblock = 0;
      } else {
         ln_begin = line_nums(1);
         ln_end   = line_nums(2);
      }
   }

   linenumber = 0;
   kount = 1;
   nmax = cur_size = 300;
   arr = array( struc(typ), nc-skip, nmax );

   while( s = rdline(file) ) {

     linenumber++;
     pos = strpos(s,";",1);
     if( pos > 0 ) {
        ss = strpart(s,1:pos-1);
     } else ss = s;
     st = strtrim(ss); // remove leading and trailing blanks
     if( strlen(st) > 0 ) {
        if( !strmatch("+-.0123456789",strpart(st,1:1))  ) {
              if( vb ) write,format="%s\n",s;
        } else {
           su = strcompress(st); // reduce all space to single spaces
           elmnts = strsplit(su," "); // separate into columns

           if( linenumber >= ln_begin &&
                  (linenumber <= ln_end || ln_end == 0) ) {
              for(i = 1+skip; i <= nc; i++ ) {
                 arr(i-skip,kount) = _str2x( elmnts(i),typ);
              }
              kount++;
           }


           // Check if expansion is needed

           if( kount == cur_size + 1) {

              grow,arr,array(struc(typ),nc-skip,nmax);
              cur_size += nmax;

           }
        }
      }
   }

   close, file;

   return transpose(arr(,1:kount-1));

}

/* Function wsmat */

func wsmat( filename, arr, fmt=, hdr=, app= )
/* DOCUMENT wsmat, filename, arr, fmt=, hdr=, app=

   Write an array in ASCII format to a file as specified by
   a format string

   KEYWORD: hdr     a string array that will be written
                    in the start of the file.
            app     Append to an existing file
            fmt     Format string (like "%5.1f")

   2009-07-24/NJW, cloned from wstab

*/

{

   if( app ) {
      f = open( filename,"a");
   } else {
      f = open( filename,"w");
   }
   if( (num = numberof(hdr)) ) {
      for( i = 1; i <= num; i++ ) {
         write,f,format="%s\n",hdr(i);
      }
   }

   typ = typeof(arr);
   dms = dimsof(arr);
   if( dms(1) != 2 ) {
      write,"WSMAT: array must be 2D, no action";
      return;
   }
   nrows = dms(2);
   ncols = dms(3);

   //  assign standard formats if not given

   fmtflag = typeof( fmt ) == "string" ? 1 : 0;
   if( !fmtflag) {
      if( typ == "string" ) {
         fmt = " %s ";
      } else if( typ == "int" || typ == "long" || typ == "char" ) {
         fmt = " %i ";
      } else if( typ == "float" ) {
         fmt = " %13.6e ";
      } else if( typ == "double" ) {
         fmt = " %17.10e ";
      } else {
         write,"Data type not supported";
         return;
      }
   }

   //  do the writing to file

   for( i = 1; i <= nrows; i++ ) {
      for( j = 1; j <= ncols; j++ ) {
         write,f,format=fmt, arr(i,j);
      }
      write,f,format="%s\n","";
   }

   close,f;

}
%FILE% scomm.i
/*******************************************************************
 *
 *    S file format package
 *
 *  2004-08-23/Niels J. Westergaard
 *  2006-06-13/NJW bug fixing in rscol and comblock
 *  2008-08-13/NJW added function 'rstab'
 *
      comblockm
      comgetm
      comgetsm
      n_columnsm
      rscolm
      rstabm

 ******************************************************************/

/* Function comgetm */

func comgetm( file, keyword_str, fix= )
/* DOCUMENT res = comgetm( file, keyword_str, fix=)
   Returns an array of values from lines:
      // keyword_str = value; comment field
   Format: Initial '//' (MUST be in position 1 and 2)
           keyword string CANNOT contain spaces
           Equal sign '=' MUST be present
   Everything following and including the ';' sign is disregarded

   Uses the 'mem_storage' package to save file in memory

   2004-08-24/NJW
   2008-08-19/NJW
*/

{

   file = fullpath(file);

   local flines;
   if( mem_restore( file, flines ) < 0 ) {
      flines = read_slist(file);
      mem_save, file, flines;
   }
   nlines = numberof(flines);

   l = strlen(keyword_str);

   values = [];
   nval = 0;
   for( ll = 1; ll <= nlines; ll++ ) {
      line = flines(ll);
      if( strpart(line,1:2) == "//" ) {
         // remove comment part
         cpos = strpos(line,";",3);
         if( cpos > 3 ) line = strpart(line,1:cpos-1);
         pe = strpos(line,"=",3);
         if( pe == 0 ) continue;
         comp = strtrim(strpart(line,3:pe-1));

         if( keyword_str == comp ) {

            if( fix ) {
               value = 1;
               n = sread(strpart(line,pe+1:),format="%d",value);
            } else {
               value = 1.0;
               n = sread(strpart(line,pe+1:),format="%f",value);
            }
            if( n == 1 ) {
               if( nval == 0 ) {
                  values = value;
               } else {
                  values = arrcat(values,value);
               }
               ++nval;
            }
         }
      }
   }

   return values;

}

/* Function comgetsm */

func comgetsm( file, keyword_str )
/* DOCUMENT res = comgetsm( file, keyword_str)
   Returns an array of string values from lines:
       // keyword_str = string

   Uses the 'mem_storage' package to save file in memory

   2004-09-12/NJW
   2008-08-19/NJW

*/

{

   file = fullpath(file);

   local flines;
   if( mem_restore( file, flines ) < 0 ) {
      flines = read_slist(file);
      mem_save, file, flines;
   }
   nlines = numberof(flines);

   l = strlen(keyword_str);

   values = [];
   nval = 0;
   for( ll = 1; ll <= nlines; ll++ ) {
      line = flines(ll);
      if( strpart(line,1:2) == "//" ) {
         // remove comment part
         cpos = strpos(line,";",3);
         if( cpos > 3 ) line = strpart(line,1:cpos-1);
         pe = strpos(line,"=",3);
         comp = strtrim(strpart(line,3:pe-1));

         if( keyword_str == comp ) {

            value = "";

            value = strtrim(strpart(line,pe+1:));
            if( nval == 0 ) {
               values = value;
            } else {
               values = arrcat(values,value);
            }
            ++nval;
         }
      }
   }

   return values;

}

/* Function n_columnsm */

func n_columnsm( file_name )
/* DOCUMENT n = n_columnsm(file_name)

   Return the number of columns in the first line that starts with
   a number i.e. not a comment

   Uses the 'mem_storage' package to save file in memory

   2004-09-15/NJW
   2008-08-19/NJW

   Part of 'scom' package

*/

{

   require, "idlx.i";

   file_name = fullpath(file_name);

   local flines;
   if( mem_restore( file_name, flines ) < 0 ) {
      flines = read_slist(file_name);
      mem_save, file_name, flines;
   }
   nlines = numberof(flines);

   ncol = -1; // to be returned if no numbers found

   flag = 1;
   ll = 0;
   while( flag && ++ll <= nlines ) {

      line = flines(ll);

      pos = strpos(line,";",1);
      if( pos > 0 ) line = strpart(line,1:pos-1);
                               // remove ';' and what follows (comments)
      line = strcompress(line); // multiple blanks and tabs to single blanks
      line = strtrim(line); // remove leading and trailing blanks
      len = strlen(line);
      if( len > 0 ) {     // skip if no characters on line
         cc = strpart(line,1:1);
         if( cc == "." && len > 1 ) cc = strpart(line,2:2);
         n = strpos("+-0123456789",cc,1);
         if( n > 0 ) {  // here we have a number
            for( j = 1; j <= len; j++ ) {
               cc = strpart(line,j:j);
               if( cc == "," ) line = strput( line, " ", j);
            }
            line = strtrim(line);
            len = strlen(strcompress(line));
            len0= strlen(strcompress(line,all=1));
            ncol = len - len0 + 1;
            flag = 0; // terminate while loop
         }
      }
   }

   return(ncol);

}

/* Function comblockm */

func comblockm( file, nblock )
/* DOCUMENT  [lnum1,lnum2] = comblockm( file, nblock )

       Returns 2 element line_number begin, line_number end.

    Reads an ASCII file 'file' searching for lines beginning with '//'
    followed by 'block = nnnnn'  e.g. :

     // block = 123

    IDL> comblock,'myfile', 114, ln_begin, ln_end
          returns the linenumbers for the beginning (ln_begin)
          and the end (ln_end) of block #114
          Both are set to -1 if the block is not found

    Member of scomm package

    2004-09-12/NJW

*/

{

   file = fullpath(file);

   local flines;
   if( mem_restore( file, flines ) < 0 ) {
      flines = read_slist(file);
      mem_save, file, flines;
   }
   nlines = numberof(flines);

   s = " ";
   lns = [];
   bns = [];
   bn = 0;
   linenumber = 1;
   k = 1;
   for(ll=1;ll<=nlines;ll++) {
      s = flines(ll);
      if( strpart(s,1:2) == "//" ) {
         pos = strpos(s,"block",3);
         if( pos >= 1 ) {    // string has been found
            pe = strpos(s,"=",pos+5);
            if( pe >= 1 ) {   // an equal sign has been found
               sb = strpart(s,3:pe-1);
               psemi = strpos(s,";",3);
               if( psemi == 0 ) psemi = strlen(s)+1;
               // Make sure that the only the search string is present
               if( strtrim(sb) == "block") {
                  sread,strpart(s,pe+1:psemi-1),bn;
                  grow, bns, bn;
                  grow, lns, ll;
               }
            }
         }
      }
   }

   if( numberof(bns) ) {
      grow, lns, nlines;
      grow, bns, 99999;
      k_ok = where( nblock == bns );
      nk_ok = numberof(k_ok);
      if( nk_ok > 0 ) {
         ln_begin = lns(k_ok(1))+1;
         ln_end   = lns(k_ok(1)+1) - (bns(k_ok(1)+1) != 99999);
          // bns == 99999 signals end of file and ln_end is not to be reduced by one
      } else {
         ln_begin = -1;
         ln_end   = -1;
      }
   } else {
      ln_begin = -1;
      ln_end   = -1;
   }
   return([ln_begin,ln_end]);
}

/* Function rscolm */

func rscolm(filename, col_def, str=,fix=,lng=,dble=,silent=,block=,typ=)
/* DOCUMENT col = rscolm( filename, col_def, str=, fix=,lng=,
                      dble=, silent=, block=, typ=)

     Read a column from an ASCII file where numbers are organized as a table
     If the column should be read as a string then the keyword 'str' must be set.
     Default type is float. Keywords exist for int, long and double.
     Alternatively 'typ' can be given "i":int, "j":long, "d":double, "f":float, "s":string.
     The columns can be numbers or character strings separated with
     blanks. The first column must always start with one of +-.0123456789
     First column number is 1
     The lines that start with non-digit characters are interpreted as
     comment lines and will be displayed but skipped in
     the reading of the data

     If the 'block' keyword is given with a block number
     then the file will be scanned for existence of lines:
         // block = nnn
     and only the table rows between where nnn matches the
     given block number and the next '// block = xxx'

     Other procedures required: n_columnsm and comblockm

     2004-09-12/NJW
     2008-08-19/NJW

*/

{

   filename = fullpath(filename);

   local flines;
   if( mem_restore( filename, flines ) < 0 ) {
      flines = read_slist(filename);
      mem_save, filename, flines;
   }
   nlines = numberof(flines);

   vb = silent ? 0 : 1;

   // Define type of returned array

   type = 4 ; // float
   if (str) type = 7 ; // string
   if (lng) type = 3 ; // long
   if (dble) type = 5 ; // double
   if (fix)  type = 2 ; // integer
   if( typeof(typ) == "string" ) {
      if( strlen(typ) == 1 ) {
         if( typ == "i" ) type = 2;
         if( typ == "j" ) type = 3;
         if( typ == "f" ) type = 4;
         if( typ == "d" ) type = 5;
         if( typ == "s" ) type = 7;
      }
   }

   // If column designator is a string then find the matching
   // number

   vartype = typeof(col_def);
   if( vartype == "string" ) {
      // get the column names
      colnames = comgetsm(filename,"colname");
      if( numberof(colnames) == 0 ) {
         write,"Error - no keyword colname found";
         return [];
      }
      w = where( colnames == col_def );
      if( numberof(w) ) {
         col_number = w(1);
      } else {
         write,"Error: no such column name has been found";
         return([]);
      }
   } else {
      col_number = col_def;
   }
   col_num = col_number;

   // Initiate use of block (i.e. only take data from a
   // specified block

   ln_begin = 1;
   ln_end = 0; // means no upper limit
   useblock = 0;
   if (block) {
      useblock = 1;
      // nblock = long(block);
      line_nums = comblockm(filename, block);
      if(line_nums(1) == -1 ) {
         write,"RSCOL Warning: Requested block not found";
         write,"                 Proceed reading all data";
         useblock = 0;
      } else {
         ln_begin = line_nums(1);
         ln_end   = line_nums(2);
      }
   }

   // See if requested column number is less than or equal to
   // the number of columns

   if( vb ) write,format="RSCOLM: at least %d columns expected in %s\n",col_number, filename;
   nc = n_columnsm(filename);
   if( vb ) write,format="%d columns found in file: %s\n", nc, filename;

   if( col_number > nc ) {
      write,format="RSCOLM: only %d columns found in file\n",nc;
      return([]);
   }

   // Prepare reading the file

   nmax = 300;
   cur_size = nmax;

   file = open(filename,"r");

   if( type == 2 ) {
      col_dat = array(int,nmax);
   } else if( type == 3 ) {
      col_dat = array(long,nmax);
   } else if( type == 4 ) {
      col_dat = array(float,nmax);
   } else if( type == 5 ) {
      col_dat = array(double,nmax);
   } else if( type == 7 ) {
      col_dat = array("",nmax);
   }

   x = array(float,nc);
   s = " ";
   kount = 1;
   linenumber = 0;

   for(ll=1;ll<=nlines;ll++) {
     s = flines(ll);

     linenumber++;
     pos = strpos(s,";",1);
     if( pos > 0 ) {
        ss = strpart(s,1:pos-1);
     } else ss = s;
     st = strtrim(ss); // remove leading and trailing blanks
     if( strlen(st) > 0 ) {
        if( !strmatch("+-.0123456789",strpart(st,1:1))  ) {
              if( vb ) write,format="%s\n",s;
        } else {
           su = strcompress(st); // reduce all space to single spaces
           elmnts = strsplit(su," "); // separate into columns

           if( linenumber >= ln_begin &&
                  (linenumber <= ln_end || ln_end == 0) ) {
              if( type == 7 ) {
                   col_dat(kount) = elmnts(col_number);
              } else {
                   n = sread(elmnts(col_number),col_dat(kount));
              }
              kount++;
           }


           // Check if expansion is needed

           if( kount == cur_size + 1) {

              grow,col_dat,array(col_dat(1),nmax);
              cur_size += nmax;

           }
        }
      }
   }
   if( vb ) write,format="RSCOLM Size of table = %d\n",kount-1;
   col_dat = kount == 1 ? [] : col_dat(1:kount-1);

   return( col_dat );

}

/* Function rstabm */

func rstabm( filename, &c1, &c2, &c3, &c4, &c5, &c6, &c7, &c8, &c9, &c10, &c11, &c12, &c13, typ= )
/* DOCUMENT rstabm, filename, >c1, >c2, ..., typ=

   Reads S-format text file and returns columns in c1, c2, ... up to and including c13

   Keyword 'typ' can be given as a string with as many characters as there are columns.
   i: int, j: long, f: float, d: double, s: string

   e.g. file "myfile.scm":
     // here are some data
        1 1.2345e2 background 11.23
        2 5.5142e3 foreground 12.85

   can be read with: > rstabm,"myfile.scm",n,y,denom,calib,typ="idsf"

   2008-08-13/NJW
*/
{

   filename = fullpath(filename);

   local flines;
   if( mem_restore( filename, flines ) < 0 ) {
      flines = read_slist(filename);
      mem_save, filename, flines;
   }
   nlines = numberof(flines);

   ncols = n_columnsm(filename);
   tflag = 0;
   if( typeof(typ) == "string" ) {
      tflag = 1;
      len = strlen(typ);
      if( len != ncols ) {
         write,"Mismatching typ and number of columns - disregard";
         tflag = 0;
      }
   }

   t = [];
   if( ncols >= 1 ) {
      if(tflag) t = strpart(typ,1:1);
      c1 = rscolm(filename,1,silent=1,typ=t);
   }
   if( ncols >= 2 ) {
      if(tflag) t = strpart(typ,2:2);
      c2 = rscolm(filename,2,silent=1,typ=t);
   }
   if( ncols >= 3 ) {
      if(tflag) t = strpart(typ,3:3);
      c3 = rscolm(filename,3,silent=1,typ=t);
   }
   if( ncols >= 4 ) {
      if(tflag) t = strpart(typ,4:4);
      c4 = rscolm(filename,4,silent=1,typ=t);
   }
   if( ncols >= 5 ) {
      if(tflag) t = strpart(typ,5:5);
      c5 = rscolm(filename,5,silent=1,typ=t);
   }
   if( ncols >= 6 ) {
      if(tflag) t = strpart(typ,6:6);
      c6 = rscolm(filename,6,silent=1,typ=t);
   }
   if( ncols >= 7 ) {
      if(tflag) t = strpart(typ,7:7);
      c7 = rscolm(filename,7,silent=1,typ=t);
   }
   if( ncols >= 8 ) {
      if(tflag) t = strpart(typ,8:8);
      c8 = rscolm(filename,8,silent=1,typ=t);
   }
   if( ncols >= 9 ) {
      if(tflag) t = strpart(typ,9:9);
      c9 = rscolm(filename,9,silent=1,typ=t);
   }
   if( ncols >= 10 ) {
      if(tflag) t = strpart(typ,10:10);
      c10 = rscolm(filename,10,silent=1,typ=t);
   }
   if( ncols >= 11 ) {
      if(tflag) t = strpart(typ,11:11);
      c11 = rscolm(filename,11,silent=1,typ=t);
   }
   if( ncols >= 12 ) {
      if(tflag) t = strpart(typ,12:12);
      c12 = rscolm(filename,12,silent=1,typ=t);
   }
   if( ncols >= 13 ) {
      if(tflag) t = strpart(typ,13:13);
      c13 = rscolm(filename,13,silent=1,typ=t);
   }

   write,format="%i columns with %i rows read.\n", ncols, numberof(c1);

}
%FILE% seecol.i
/* ********************************************************
     Display a window with colors, increasing green along
     abscissa and increasing blue on ordinate.

     With 'seecol' you can choose the level of red.
     With 'seecola' you get a panel with 16 levels of
     red in each subwindow (that again has green and blue
     as explained above).

     2012-01-16/NJW
*/

window,0,style="nobox.gs";
plot,[0,1],[0,0],xr=[0,1],yr=[0,1];

func seecol( red_level )
{
   s = indgen(0:255:5);
   ns = numberof(s);
   step = 1./ns;
   unit_polx = [0,1,1,0,0];
   unit_poly = [0,0,1,1,0];
   for( i = 1; i <= ns; i++ ) {
      for( j = 1; j <= ns; j++ ) {
         poly_fillc, step*(i-1+unit_polx), step*(j-1+unit_poly), color=[red_level,s(i),s(j)];
      }
   }
}

func seecola( void )
{
   // color levels
   s = long(span(0,255,16)+0.5);

   ns = numberof(s);
   step = 0.25/ns;
   write,"step = "+ftoa(step,ndec=4);
   unit_polx = [0,1,1,0,0];
   unit_poly = [0,0,1,1,0];
   for( k = 1; k <= 16; k++ ) {
      red_level = s(k);
      xpos = ((k-1)%4) * 0.25;
      ypos = ((k-1)/4) * 0.25;
      write,itoa(red_level)+", x,xy: ",ftoa(xpos,ndec=2)+", "+ftoa(ypos,ndec=2);
      for( i = 1; i <= ns; i++ ) {
         for( j = 1; j <= ns; j++ ) {
            poly_fillc, step*(i-1+unit_polx)+xpos, step*(j-1+unit_poly)+ypos, color=[red_level,s(i),s(j)];
         }
      }
   }
}
%FILE% seeff_derive_eeff.i
func seeff_derive_eeff( dol_lo, dol_hi, dol_bkg )
/* DOCUMENT seeff_derive_eeff, dol_lo, dol_hi, dol_bkg

   seeff_derive_eeff: Derive the EEFF

   dol_lo points to a JEMX spectrum taken at low gain
   dol_hi points to a JEMX spectrum taken at high gain
   dol_bkg points to a JEMX background spectrum at nominal gain of 22.1

   2008-05-26/NJW, cloned from detmo_derive_eeff.i
*/

{

   hdr_lo = headfits( dol_lo );
   hdr_hi = headfits( dol_hi );
   hdr_bkg = headfits( dol_bkg );
   gain_lo = fxpar( hdr_lo, "avg_gain" );
   gain_hi = fxpar( hdr_hi, "avg_gain" );
   gain_bkg = fxpar( hdr_bkg, "avg_gain" );

   // Get PI boundaries from IMOD table
   j_get_pi_ebds, eb1, eb2;
   epi = 0.5*(eb1 + eb2);

   // Get the background spectrum (at nominal gain i.e. 22.1)
   j_get_src_spectrum, dol_bkg, 1, rate_bkghi, stat_err_bkghi;

   // Get the low gain spectrum
   j_get_src_spectrum, dol_lo, 1, rate_lo, stat_err_lo;

   // Get the high gain spectrum
   j_get_src_spectrum, dol_hi, 1, rate_hi, stat_err_hi;

   // Do the rebinning

   REBIN = -39; // skip first 39 channels
   grow, REBIN, array(1,10); // +10 = 49
   grow, REBIN, array(2,10); // +20 = 69
   grow, REBIN, array(3,30); // +90 = 159
   grow, REBIN, array(2,33); // +66 = 225
   grow, REBIN, -31;         // +31 = 256

   specrebinning, eb1, eb2, rate_hi, stat_err_hi, REBIN, ob1, ob2, orate_hi, ostat_err_hi;
   specrebinning, eb1, eb2, rate_lo, stat_err_lo, REBIN, ob1, ob2, orate_lo, ostat_err_lo;
   specrebinning, eb1, eb2, rate_bkghi, stat_err_bkghi, REBIN, ob1, ob2, orate_bkghi, ostat_err_bkghi;
   oepi = 0.5*(ob1 + ob2); // central energies of output channels

   // Get the zeroth order electronic efficiency

   pha_z = rscol("elec_eff_pha_060202.scm",1,silent=1);
   eta_z = rscol("elec_eff_pha_060202.scm",2,silent=1);
   eta_bkghi = interp( eta_z, pha_z, oepi*gain_hi );
   eta_bkglo = interp( eta_z, pha_z, oepi*gain_lo );

   // Approximating the low gain background

   orate_bkglo = orate_bkghi * eta_bkglo / eta_bkghi;
   ostat_err_bkglo = ostat_err_bkghi * eta_bkglo / eta_bkghi;

   // Subtract the background approximations

   orate_hi = orate_hi - orate_bkghi;
   ostat_err_hi = sqrt(ostat_err_hi^2 + ostat_err_bkghi^2);

   orate_lo = orate_lo - orate_bkglo;
   ostat_err_lo = sqrt(ostat_err_lo^2 + ostat_err_bkglo^2);

   // Plot the spectra

   window,0,style="boxed.gs";
   plot_spectrum, ob1, ob2, orate_hi, ostat_err_hi, itype=3;
   oplot_spectrum, ob1, ob2, orate_bkghi, ostat_err_bkghi, color="blue";
   oplot_spectrum, ob1, ob2, orate_lo, ostat_err_lo, color="red";
   oplot_spectrum, ob1, ob2, orate_bkglo, ostat_err_bkglo, color="green";

   // Do the CBJ type of EEFF determination i.e. starting at high
   // energies (or PHA values) and work downwards

   ener = 25.; // keV
   eta_arr = [1.0,1.0]; // The array of electronic efficiencies
   pharr = ener*gain_hi*[1.,5.]; // ensures that the upper limit is
      // not a problem. The array is sorted everytime a new EEFF
      // value has been determined.

   while( ener > 1.5 ) {
      rate_lo_e = interp(rate_lo,epi,ener);
      rate_hi_e = interp(rate_hi,epi,ener);
      phahi = ener * gain_hi;
      phalo = ener * gain_lo;
      eta_2 = interp( eta_arr, pharr, phahi );
      eta_1 = eta_2 * rate_lo_e / rate_hi_e;
      //+ write,format="%8.3f  %8.4f\n", pha1, eta_1;
      grow, pharr, phalo;
      grow, eta_arr, eta_1;
      is = sort(pharr);
      eta_arr = eta_arr(is);
      pharr = pharr(is);
      ener *= 0.97;
   }
   window,1,style="boxed.gs";
   plot,pharr,eta_arr,xr=[0,800],yr=[0,1.5];
   oplot,pha_z, eta_z, color="blue";
   hdr = array(string,5);
   hdr(1) = "// "+ndate(3);
   hdr(2) = "// origin = seeff_derive_eeff.i";
   hdr(3) = "// gain_lo = "+swrite(format="%.3f", gain_lo);
   hdr(4) = "// gain_hi = "+swrite(format="%.3f", gain_hi);
   hdr(5) = "// startenergy = 25 ; keV";
   outname = get_next_filename("seeff_????_"+ndate(1)+".scm")
   wstab,outname, pharr,eta_arr,hdr=hdr;
   write,format="Output EEFF curved has been written to %s\n", outname;

}
%FILE% select_to_frac.i
/* Function select_to_frac */

func select_to_frac( arr, fraction )
/* DOCUMENT sel = select_to_frac( arr, fraction )

   Returns the indices for array 'arr' for the selection of
   the fraction 'fraction' of the total sum in 'arr'

   2010-10-08/NJW
*/
{
   a = reform(arr,numberof(arr));
   a = a(sort(a));
   b = a(psum);
   idx = where(b > b(0)*(1-fraction))(1);
   w = where( arr > a(idx) );
   if( numberof(w) ) return w;
   return idx;
}
%FILE% set_boundingbox.i
func set_boundingbox( filename, x1=, y1=, x2=, y2=, silent= )
/* DOCUMENT set_boundingbox, filename, x1=, y1=, x2=, y2=, silent=

   Adjusts the PostScript bounding box (as generated by 'Yorick')
   to the values given by keywords x1,y1,x2,y2, but only those
   given are changed.

   If none are given the file will not change, but
   BoundingBox values will be displayed.

   With usual window size and no text in the plot the
   recommended values are:

        x1=36, y1=48,     x2=477, y2=671
         Lower left        Upper right
          corner             corner

   2009-10-06/NJW
*/
{
   x1old = y1old = x2old = y2old = 0;
   x1act = y1act = x2act = y2act = 0;
   action = 0;
   if( !is_void(x1) ) { x1act = 1; action++; }
   if( !is_void(y1) ) { y1act = 1; action++; }
   if( !is_void(x2) ) { x2act = 1; action++; }
   if( !is_void(y2) ) { y2act = 1; action++; }
   pslines = rdfile(filename);
   last = numberof(pslines);
   kount = 0;
   while( kount < 2 && last > 0 ) {
      if( strmatch(pslines(last),"BoundingBox") ) {
         kount++;
         if(!silent)write,format="%s\n", pslines(last);
         if(!silent)write,"                         x1  y1  x2  y2";
         if( !(pos = strpos(pslines(last),":"))) error,"##1##";
         start = strpart(pslines(last),1:pos);
         ending = strpart(pslines(last),pos+1:0);
         if( !is_digit(strcompress(ending,all=1)) ) error,"##2##";
         if( action ) {
            sread,ending,format="%i%i%i%i",x1old, y1old, x2old, y2old;
            if( !x1act ) x1 = x1old;
            if( !y1act ) y1 = y1old;
            if( !x2act ) x2 = x2old;
            if( !y2act ) y2 = y2old;
            pslines(last) = start + swrite(format=" %i %i %i %i", x1, y1, x2, y2);
            if(!silent)write,format="Becomes: %s\n", pslines(last);
         }
      }
      last--;
   }
   if( action ) {
      write_slist,filename,pslines;
      if(!silent)write,filename+" has been updated";
   } else {
      if(!silent)write,"No action since none was requested!";
   }
}

sbb = set_boundingbox;
write,"Shorthand 'sbb' for 'set_boundingbox' has been defined";
%FILE% snpif_a.i
// 2006-06-12/NJW
//
//             Testing NL expression for SN ratio
//
require, "plot.i";
require, "image.i";
require, "idlx.i";
require, "random.i";
require, "scom.i";
require, "string.i";
require, "fits.i";
require, "mfits.i";
require, "snpif_f.i";

lun = open("snpif.scm","w");

N = 2000; // total number of pixels
// piecewise linear
br1 = 0.3;
n1 = long(N*br1 + 0.5);
val1 = 0.0;
br2 = 0.8;
n2 = long(N*br2 + 0.5);
val2 = 0.5;
br3 = 0.9;
n3 = long(N*br3 + 0.5);
val3 = 1.0;
pif = span(0.,val1,n1);
pif = grow(pif,span(val1,val2,n2-n1))
pif = grow(pif,span(val2,val3,n3-n2))
pif = grow(pif,span(val3,1.0,N-n3))

pifname = get_next_filename("snpif_pif_????.fits");
wrmfitscols,pifname,"pif", pif,extname="PIF";

NCASES = 10000;
write,lun,format="//  snpif results %sT%s\n", getdate(), gettime();
write,lun,format="// NCASES = %d\n", NCASES;

N_ma = 20;
ma_vec = (indgen(N_ma)-1)*25 + 500;
N_mb = 18;
mb_vec = indgen(N_mb)*25;

F = 10.; // number of counts per pixel where PIF = 1
B = 0.3;  // number of background counts per pixel

// for( F = 0.5; F < 12.0; F += 4.5 ) {

   write,lun,format="// F = %8.2f\n", F;
   write,lun,format="// B = %8.2f\n", B;
   write,lun,format="%s\n", "//";

   // Create FITS file with dummy primary header

   fname = get_next_filename("snpif_????.fits");
   fh = fits_create( fname );
   fits_set, fh,"EXTEND",'T',"There may be extensions";
   fits_set, fh,"FLUXIN", F, "Given flux value";
   fits_set, fh,"BKGIN", B, "Given background value";
   fits_set, fh,"NCASES", NCASES, "Number of trials for averaging";
   fits_set, fh,"NPIXELS", N, "Number of pixels in shadowgram";
   fits_set, fh,"PIFFILE", pifname, "File with copy of PIF table";
   fits_write_header, fh;
   
   Fa_arr = array(0.0, N_ma, N_mb );
   Fb_arr = array(0.0, N_ma, N_mb );
   F_arr = array(0.0, N_ma, N_mb );
   B_arr = array(0.0, N_ma, N_mb );
   sigmaF_arr = array(0.0, N_ma, N_mb );
   sigmaB_arr = array(0.0, N_ma, N_mb );
   sn_nl_arr = array(0.0, N_ma, N_mb );
   sn_njw_arr = array(0.0, N_ma, N_mb );

   ideal_shg = F * pif + B;
   
   // 'a' selection is high PIF values
   // pixels from ma to N both included

   for( ima = 1; ima <= N_ma; ima++ ) {
      ma = ma_vec(ima);
      asel = indgen(N-ma+1) + ma - 1;
      // 'b' selection is high PIF values
      // pixels from 1 to mb both included
      // but mb < ma

      for( imb = 1; imb <= N_mb; imb++ ) {
         mb = mb_vec(imb);
         bsel = indgen(mb);
   
         Aa = sum(pif(asel));
         Na = N - ma + 1;
   
         Ab = sum(pif(bsel));
         Nb = mb;
         divisor = Aa*Nb - Ab*Na;
   
         sn_nl = (Aa/Na - Ab/Nb)/sqrt(1./Na + 1./Nb);
         sn_nl_arr(ima,imb) = sn_nl;
   
         // get the F and B values from NJW equations
         // for a number of cases and evaluate mean and rms
   
         fsum = 0.0;
         fsum2 = 0.0;
         bsum = 0.0;
         bsum2 = 0.0;
         Fasum = 0.0;
         Fbsum = 0.0;
   
         for( i = 1; i <= NCASES; ++i ) {
            shg = poisson(ideal_shg);
            Fa = sum(shg(asel));
            Fb = sum(shg(bsel));
   
            resF = (Nb*Fa - Na*Fb)/divisor;
            resB = (Fb*Aa - Fa*Ab)/divisor;
            fsum += resF;
            bsum += resB;
            fsum2 += resF^2;
            bsum2 += resB^2;
            Fasum += Fa;
            Fbsum += Fb;
         }
   
         sigmaF = sqrt((fsum2 - (fsum^2)/NCASES)/(NCASES-1));
         sigmaB = sqrt((bsum2 - (bsum^2)/NCASES)/(NCASES-1));
         resF = fsum/NCASES;
         resB = bsum/NCASES;
         Fa = Fasum/NCASES;
         Fb = Fbsum/NCASES;
         sigmaF_arr(ima,imb) = 1.0/sigmaF;
         sigmaB_arr(ima,imb) = 1.0/sigmaB;
         F_arr(ima,imb) = resF;
         B_arr(ima,imb) = resB;
         Fa_arr(ima,imb) = Fa;
         Fb_arr(ima,imb) = Fb;
   
         sn_njw = (Fa/Na - Fb/Nb)/sqrt(Fa/Na^2 + Fb/Nb^2);
         sn_njw_arr(ima,imb) = sn_njw;

         write,format="%5d %5d NL SN = %10.5f F: %6.2f %6.2f B: %6.2f %6.2f \n",\
                mb, ma, sn_nl, resF, sigmaF, resB, sigmaB;
         write,lun,format="%5d %5d %12.7f %8.4f %8.4f %8.4f %8.4f %8.4f %8.4f %8.4f\n",\
                mb, ma, sn_nl, resF, sigmaF, resB, sigmaB, Fa, Fb, sn_njw;
      }
   }

   // Append arrays to the FITS file

   snpif_f, fh, F_arr, "F", "Derived flux values", ma_vec, mb_vec;
   snpif_f, fh, B_arr, "B", "Derived background values", ma_vec, mb_vec;
   snpif_f, fh, sigmaF_arr, "SIGMAF", "Derived flux sigma values", ma_vec, mb_vec;
   snpif_f, fh, sigmaB_arr, "SIGMAB", "Derived background sigma values", ma_vec, mb_vec;
   snpif_f, fh, Fa_arr, "FA", "Derived flux from high PIF values", ma_vec, mb_vec;
   snpif_f, fh, Fb_arr, "FB", "Derived flux from low PIF values", ma_vec, mb_vec;
   snpif_f, fh, sn_nl_arr, "SN_NL", "Signal/noise NL expression", ma_vec, mb_vec;
   snpif_f, fh, sn_njw_arr, "SN_NJW", "Signal/noise NJW expression", ma_vec, mb_vec;

   fits_close, fh;
// }

close, lun;
%FILE% snpif_b.i
// Present results from snpif_a.i
//
require, "scom.i"
require, "idlx.i"
require, "image.i"
require, "random.i"
require, "plot.i"

glo = open("snpif.log","w");

for( blck = 23; blck <= 23; ++blck ) {

   mb = rscol("snpif.scm",1,fix=1,silent=1,block=blck);
   ma = rscol("snpif.scm",2,fix=1,silent=1,block=blck);
   for(nrows=2; mb(nrows) > mb(nrows-1); ++nrows);
   --nrows;
   ncols = numberof(mb)/nrows;
   write,format="blck = %d, nrows = %d, ncols = %d\n", blck, nrows, ncols;
   write,glo,format="blck = %d, nrows = %d, ncols = %d\n", blck, nrows, ncols;
   
   xax = mb(1:nrows);
   yax = ma(1::nrows);
   
   sn = rscol("snpif.scm",3,silent=1,block=blck);
   f = rscol("snpif.scm",4,silent=1,block=blck);
   sf = rscol("snpif.scm",5,silent=1,block=blck);
   b = rscol("snpif.scm",6,silent=1,block=blck);
   sb = rscol("snpif.scm",7,silent=1,block=blck);
   
   sna = reform(sn,nrows,ncols);
   fa = reform(f,nrows,ncols);
   sfa = reform(sf,nrows,ncols);
   ba = reform(b,nrows,ncols);
   sba = reform(sb,nrows,ncols);

   dispc,sna,xax=xax,yax=yax
   zps,plotname
   write,glo,format="SN Plotfile: %s\n", plotname;
   disp,sfa,xax=xax,yax=yax
   zps,plotname
   write,glo,format="sigma(F) Plotfile: %s\n", plotname;
}
close, glo;
%FILE% snpif_f.i
func snpif_f( &fh, data_array, extname, comment, ma_vec, mb_vec )
/* DOCUMENT snpif_f, fh, data_array, extname, comment , ma_vec, mb_vec

     Add a new IMAGE extension to FITS file

*/
{
   fits_new_hdu, fh, "IMAGE";
   fits_set, fh, "BITPIX", fits_bitpix_of(data_array),"Datatype";
   sz = dimsof(data_array);
   fits_set_dims, fh, sz;
   fits_set, fh, "CRPIX1", 1, "Reference pixel for axis 1";
   fits_set, fh, "CRVAL1", double(ma_vec(1)), "Reference coordinate for axis 1";
   fits_set, fh, "CDELT1", (ma_vec(0)-ma_vec(1))/double(sz(2)), "Pixel size unit for axis 1";
   fits_set, fh, "CRPIX2", 1, "Reference pixel for axis 2";
   fits_set, fh, "CRVAL2", double(mb_vec(1)), "Reference coordinate for axis 2";
   fits_set, fh, "CDELT2", (mb_vec(0)-mb_vec(1))/double(sz(2)), "Pixel size unit for axis 2";
   fits_set, fh, "EXTNAME", extname, comment;
   fits_write_header, fh;
   fits_write_array, fh, data_array;
}
%FILE% sort_nocase.i
func sort_nocase( str_arr )
/* DOCUMENT idx = sort_nocase( str_arr )

   Sort a string array independent of case so that e.g.
   Anders follows and. Achieved by converting to upper case
   before sorting.

*/
{
   if( typeof(str_arr) != "string" ) return indgen(numberof(str_arr));

   return( sort(strupcase(str_arr)) );
}
%FILE% sourcemap.i

/* Function sourcemap */

func sourcemap( void, rep=, force=, clog=, coords=, height=, extralist=, labels=, \
               radius=, coordsys=, plotheader=, cl=, pane=, chat= )
/* DOCUMENT sourcemap, rep=, force=, clog=, coords=, height=, extralist=, labels=,
               radius=, coordsys=, plotheader=, cl=, pane=, chat=

  NJW/090337, cloned from the IDL version

 Draw a map of sources in smaller region in RA-DEC or Galactic coordinates.
 Remembers previous settings in 'sourcemap.par'.

  Keyword: rep    : repeat previous plot
           force  : set to 1 when re-reading of catalog is to be forced
           clog   : catalog DOL (defaults to ISDC reference catalog)
           coords : 2 element array with RA-Dec or Lon-Lat values in degrees
           height : height of source name labels (defaults to 12)
           extralist : s-format list of additional points to put on plot
           labels : "y" is labels are wanted
           radius : radius in deg for source selection
           coordsys : "equatorial" or "galactic"
           plotheader : text string for plot header
           cl     : 'center lines' for marking plot center
           pane   : plotting window number (0-7), default 0
           chat   : for extra information

*/
{

   extern Source_cat, Source_cat_dol, Source_cat_num;

   local boxt, box_dum, p1, q1, p, q;
   local xsrc, ysrc;

   deg2rad = pi / 180.;
   if(is_void(height)) height = 12;
   if(is_void(chat)) chat = 0;
   if(is_void(pane)) pane = 0;

   //  Search parameter file 'sourcemap.par' following PFILES

   parfile = "sourcemap.par";
   if( ! file_test(parfile) ) {
      parfile = parpath("sourcemap");
      if( is_void(parfile) ) {
         write,"Could not locate sourcemap.par from PFILES";
         return;
      }
   }


   if( !numberof(coordsys) ) {
      if( rep ) { // select coordsystem of previous plot
         coordsys = comgets(parfile, "coordsys" );
      } else {
         coordsys = get_spars(parfile,"coordsys");
      }
   }
   if( coordsys != "equatorial" && coordsys != "galactic" ) {
      write,format="'coordsys' is found as '%s'\n", coordsys;
      write,"'coordsys' must be either 'equatorial' or 'galactic'";
      return;
   }
   equat = strpart(coordsys,1:1) == "e" ? 1 : 0;
   if(chat>0) write,"coordsys = "+coordsys;

   if( equat ) {
      comreplaces, parfile, "coordsys", "equatorial";
      xtitstr = "RA (J2000) [deg]";
      ytitstr = "DEC (J2000) [deg]";
   } else {
      comreplaces, parfile, "coordsys", "galactic";
      xtitstr = "Gal. Long. [deg]"
      ytitstr = "Gal. Lat.  [deg]"
   }

   lout = create("output");

  //   Prepare to avoid writing text on top of each other

   n_boxes = 0;
   boxes = array(float,4,300); // each row is a box of text in normal coordinates
   xtnormv = array(float,300); // save values when two passes are required
   ytnormv = array(float,300); // save values when two passes are required

  // Read the catalog if not already there or there as been a change
  // or if forced

   if( numberof(clog) ) {
      comreplaces, parfile,"input_catalogue", clog;
   }

   if( rep ) {
      input_catalogue = comgets(parfile,"input_catalogue");
   } else if( !numberof(clog) ) {
      input_catalogue = get_spars(parfile,"input_catalogue");
   }

  // Read the contents of the catalogue

   read_catalog, input_catalogue, force=force;

  //   Choose the central point

   answer = "";

   ra_cen = 0.0;
   dc_cen = 0.0;
   gl_cen = 0.0;
   gb_cen = 0.0;

   if( equat ) {
      if( numberof(coords) == 2 ) {
         ra_cen = coords(1);
         dc_cen = coords(2);
         comreplace, parfile, "ra_cen", ra_cen;
         comreplace, parfile, "dc_cen", dc_cen;
      } else {
         write,"The right ascension and declination (J2000) in decimal degrees";
         if( rep ) {
            ra_cen = comget(parfile,"ra_cen");
            dc_cen = comget(parfile,"dc_cen");
         } else {
            ra_cen = get_spar_ra(parfile,"ra_cen");
            dc_cen = get_spar_dec(parfile,"dc_cen");
         }
      }


  // Get the center of field in galactic coordinates

      glb = galactic(ra_cen,dc_cen);
      gl_cen = zero2pi(deg2rad*glb(1))/deg2rad;
      gb_cen = glb(2);

      comreplace, parfile, "gl_cen", gl_cen;
      comreplace, parfile, "gb_cen", gb_cen;

   } else {

      if( numberof(coords) == 2 ) {
         gl_cen = coords(1);
         gb_cen = coords(2);
         comreplace, parfile, "gl_cen", gl_cen;
         comreplace, parfile, "gb_cen", gb_cen;
      } else {
         write,"The galactic longitude and latitude in decimal degrees"
         if( rep ) {
            gl_cen = comget(parfile,"gl_cen");
            gb_cen = comget(parfile,"gb_cen");
         } else {
            gl_cen = get_spar(parfile,"gl_cen");
            gb_cen = get_spar(parfile,"gb_cen");
         }
      }

  // Get the center of field in equatorial coordinates

      radec = equatorial( gl_cen, gb_cen);
      ra_cen = radec(1);
      dc_cen = radec(2);

      comreplace,parfile, "ra_cen", ra_cen;
      comreplace,parfile, "dc_cen", dc_cen;

   }


   if( !numberof(radius) ) { // a keyword will override other input
      if( rep ) {
         radius = comget(parfile,"radius");
      } else {
         radius = get_spar(parfile,"radius");
      }
   } else comreplace,parfile, "radius", radius;


   if( !numberof(plotheader) ) { // a keyword will override other input
      if( rep ) {
         plotheader = comgets(parfile,"plotheader");
      } else {
         plotheader = get_spars(parfile,"plotheader");
      }
   } else comreplaces,parfile, "plotheader", plotheader;


   if( !numberof(labels) ) { // a keyword will override other input
      if( rep ) {
         labels = comgets(parfile,"labels");
      } else {
         labels = get_spars(parfile,"labels");
      }
   } else comreplaces,parfile, "labels", labels;
   if(chat>0) write,"labels: "+labels;


   if( !numberof(extralist) ) { // a keyword will override other input
      if( rep ) {
         extralist = comgets(parfile,"extralist");
      } else {
         extralist = get_spars(parfile,"extralist");
      }
   } else comreplaces,parfile, "extralist", extralist;

   extrapoints = 0;
   if( extralist != "none" ) {

      if( strpart(extralist,1:1) == "p" \
          && is_digit(strpart(extralist,2:5)) \
          && strlen(extralist) == 5 ) {
         pointingfile = "/r6/jemx/pointings/pointings_"+strpart(extralist,2:5) \
          +"p.dat";
         cosys = "equatorial";
         exc1 = rscol(pointingfile,2,silent=1);
         exc2 = rscol(pointingfile,3,silent=1);
      } else {
         rstab,extralist, 2, exc1, exc2;
         cosys = comgets(extralist, "coordsys");
      }

      n_extra = numberof(exc1);
      extrapoints = 1;

      //  if same coordinate system as plot then do nothing
      //  else make appropriate conversion

      if( equat && cosys == "galactic" ) {
         buf = equatorial( exc1, exc2 );
         exc1 = zero2pi(buf(,1)*deg2rad)/deg2rad;
         exc2 = buf(,2);
      }
      if( ! equat && cosys == "equatorial" ) {
         buf = galactic( exc1, exc2 );
         exc1 = zero2pi(buf(,1)*deg2rad)/deg2rad;
         exc2 = buf(,2);
      }

   }

   //+ intens = Source_cat.intens;
   name = Source_cat.name;
   class = Source_cat.class;
   //+ catalog = Source_cat.catalogue;
   ra   = Source_cat.ra_obj;
   dec  = Source_cat.dec_obj;


   //+ selection = where(intens  >  limit * 2.e-11 , n_selection );
   //+ if( n_selection  <=  0 ) {
   //+   write,"  -- no sources above intens limit !";
   //+   free_lun,lout;
   //+   return;
   //+}

   //+intens = intens(selection);
   //+name = name(selection);
   //+ra = ra(selection);
   //+dec = dec(selection);
   //+category = category(selection);
   //+catalog = catalog(selection);

   n = numberof(name);

   buf = galactic( ra, dec );
   gl = zero2pi(buf(,1)*deg2rad)/deg2rad;
   gb = buf(,2);

   distances = arcdist(ra,dec,ra_cen,dc_cen);
   selection = where( distances  <  radius);
   n_selection = numberof(selection);
   if( n_selection  ==  0 ) {
      write,"No sources inside circle ";
      close,lout;
      return;
   }
   //+ intens = intens(selection);
   name = name(selection);
   ra = ra(selection);
   dec = dec(selection);
   class = class(selection);
   //+ catalog = catalog(selection);
   gl = gl(selection);
   gb = gb(selection);

  // Define common coordinates

   if( equat ) {
      x = ra;
      y = dec;
      x_cen = ra_cen;
      y_cen = dc_cen;
   } else {
      x = gl;
      y = gb;
      x_cen = gl_cen;
      y_cen = gb_cen;
   }

   n = n_selection;

  // Sort according to second coordinate

   isort = sort(y);
   //+ intens = intens(isort);
   name = name(isort);
   x = x(isort);
   y = y(isort);
   class = class(isort);
   //+ catalog = catalog(isort);
   ra = ra(isort);
   dec = dec(isort);
   gl = gl(isort);
   gb = gb(isort);

  //--------------------------------------------------------
  //
  //   The selection of sources is finished and the plotting
  //   can start
  //
  //--------------------------------------------------------


   window,pane;

   cosy = cos(y_cen*pi/180);
   xra = [x_cen+radius/cosy,x_cen-radius/cosy];
   yra = [max(-90., y_cen-radius),min(90., y_cen+radius)];

  // Shift sources with X 180 -> 360 to negative if
  // plot range requires it

   if( xra(2) < 0 ) {
      h = where(x > 180);
      if( numberof(h) ) x(h) -= 360;
      if( extrapoints ) {
         h = where(exc1 > 180);
         if( numberof(h) ) exc1(h) -= 360;
      }
   }

  // Shift sources with X 0 -> 180 to 360 +  if
  // plot range requires it

   if( xra(1) > 360 ) {
      h = where(x  <  180);
      if( numberof(h) ) x(h) += 360;
      if( extrapoints ) {
         h = where(exc1 < 180);
         if( numberof(h) ) exc1(h) += 360;
      }
   }

   //  Plot the frame, add 200 to y to make sure that points
   //  fall outside limits

   plot, x, y+200, xr=xra, yr=yra, xtitle=xtitstr, \
        ytitle=ytitstr, title=plotheader;

   if( cl ) {
      oplot, xra,[y_cen,y_cen],li=2;
      oplot, [x_cen,x_cen],yra,li=2;
   }
   if( extrapoints ) oplot,exc1,exc2,ps=22,color="red",symsize=0.25,fill=1;
   plotname,Source_cat_dol;
   plotsign;


  // Initial loop to protect the data points from text

   for( i = 1; i <= n; i++ ) {
      mcoord_conv, x(i), y(i), p, q, from="wor",to="ndc";
      // protect the data point:
      boxes(1,++n_boxes) = p - 0.01;
      boxes(3,n_boxes) = p + 0.01;
      boxes(2,n_boxes) = q - 0.01;
      boxes(4,n_boxes) = q + 0.01;
      if(chat>4)drawbox,boxes(,n_boxes),device=1;
   }

   for( i = 1; i <= n; i++ ) {
      name(i) = strtrim(strcompress(name(i)));
      oplot,[x(i)], [y(i)],ps=13,symsize=0.30, fill=1, color="green";

      // Find empty region for label

      if( labels == "y" ) {

         write,lout,"Search for region for ", itoa(i),": ",name(i);
         mcoord_conv, x(i), y(i), xsrc, ysrc, from="wor",to="ndc";
         write,lout,"Source position (ndc) : ", xsrc, ysrc;
         // define the basic name box
         textbox, xsrc, ysrc, name(i), boxt, \
             device=1,height=height,align=0.5,nobox=1,notext=1;
         wbox = boxt(3)-boxt(1);
         hbox = (boxt(4)-boxt(2))*1.1;
         found = 0;

       //  scan the position-map for the best label position

         pmap = get_pmap( xsrc, ysrc+0.01, xpmap, ypmap );

         while( max(pmap) > 0 ) {

            maxim, pmap, maxval, ixbest, iybest;
            xbest = xpmap(ixbest);
            ybest = ypmap(iybest);
            boxt = [xbest-0.5*wbox,ybest,xbest+0.5*wbox,ybest+hbox];
            if(chat>4)drawbox, boxt, device=1;

            found = 1;
            if( boxt(3) > 0.6143 - 0.005 ) found = 0;
            if( boxt(1) < 0.1757 + 0.005 ) found = 0;
            if( boxt(4) > 0.8643 - 0.005 ) found = 0;
            if( boxt(2) < 0.4257 + 0.005 ) found = 0;
            if( found ) {
               for( j = 1; j<= n_boxes; j++ ) {
                  if( boxoverlap( boxt, boxes(,j) ) ) found = 0;
               }
            }

            if( found ) {
               break; // stop the search
            } else {
               pmap(ixbest,iybest) = -1.;
            }

         }

         textbox,xbest,ybest,name(i),box_dum,nobox=1,device=1,align=0.5,height=height;
         boxes(,++n_boxes) = boxt;
         mcoord_conv, boxt(1), boxt(2), p, q, from="ndc",to="wor";
         mcoord_conv, boxt(3), boxt(4), p1, q1, from="ndc",to="wor";
         oplot,[p,p1],[q,q]; // underlining source name
         oplot,[0.5*(p+p1),x(i)],[q,y(i)];

      } // Terminate test for labels wanted

      // Update plot with limit and symbols


      write,format="%20s %8.3f%8.3f  %8.3f%8.3f\n",name(i), \
            ra(i),dec(i),gl(i),gb(i);

   }

   close,lout;

}

/* Function textbox */

func textbox( x, y, str, &boxdevice, &boxworld, \
                     align=, notext=, nobox=, device=, height= )
/* DOCUMENT textbox, x, y, str, >boxdevice, >boxworld,
                    align=, notext=, nobox=, device=, height=

  Print out a text string "str" just as "xyouts". This procedure
  also returns a box [x1,y1,x2,y2] in normalized device coordinates around
  the text string

  The keyword "notext" inhibits the output of text to window
  but only sets the circumscribing box

  With keyword "device" set (x,y) must be in normalized device coordinates
  else in data coordinates

   991129/NJW
   2009-08-10/NJW translated to Yorick
*/
{

   local p, q;

   chsiz = 1.
   chsiz = is_void(charsize) ? 1. : charsize;
   align = is_void(align) ? 0.0 : align;
   dev = is_void(device) ? 0 : 1;
   height = is_void(height) ? 14 : height;
   notext = !is_void(notext);
   nobox = !is_void(nobox);

   if( height < 9 ) {
      height = 8; block = 1;
   } else if( height < 11 ) {
      height = 10; block = 2;
   } else if( height < 13 ) {
      height = 12; block = 3;
   } else if( height < 15 ) {
      height = 14; block = 4;
   } else {
      height = 16; block = 5;
   }

   if( align < 0.25 ) {
      just = "LA";
      align = 0.0;
   } else if( align < 0.75 ) {
      just = "CA";
      align = 0.5;
   } else {
      just = "RA";
      align = 1.0;
   }

   // Write string to window

   if( !notext ) {
      plt,str,x,y,height=height,justify=just,tosys=(1-dev);
   }

   // get string length in normalized device coordinates

   dfile = "/home/njw/yorick/char_sizes.scm";
   rstab,dfile,2,carr,lsiz,typ="cf",block=block,silent=1;
   wdevice = 0.0;
   cstr = *pointer(str);
   slen = strlen(str);
   for(i=1;i<=slen;i++) {
      w = where(cstr(i) == carr);
      if(numberof(w)>0) wdevice += lsiz(w(1));
   }

   // get the character size in y direction:

   h_charsize = height * 0.0013;

   // start of string position in device coordinates:

   if( dev ) {
      xstartdevice = x - align*wdevice;
      ystartdevice = y;
   } else {
      mcoord_conv, x, y, p, q, from="wor",to="ndc";
      xstartdevice = p - align*wdevice;
      ystartdevice = q;
   }
   ystartdevice -= 0.2*h_charsize;

   mcoord_conv, xstartdevice, ystartdevice, xstartworld, ystartworld, \
              from="ndc",to="wor";

   // end of string position in device coordinates:

   xenddevice = xstartdevice + wdevice;
   yenddevice = ystartdevice + h_charsize;
   mcoord_conv, xenddevice, yenddevice, xendworld, yendworld, \
              from="ndc",to="wor";

   boxdevice = [xstartdevice, ystartdevice, xenddevice, yenddevice];
   boxworld = [xstartworld, ystartworld, xendworld, yendworld];

   if( !nobox ) drawbox,boxworld;
}

func drawbox( box, device= )
/* DOCUMENT drawbox, box, device

    assumes box : [x1,y1,x2,y2]
*/
{
   local x1,y2, x2,y2;

   if( device ) {
      mcoord_conv, box(1),box(2), x1, y1, from="ndc", to="wor";
      mcoord_conv, box(3),box(4), x2, y2, from="ndc", to="wor";
   } else {
      x1 = box(1); y1 = box(2);
      x2 = box(3); y2 = box(4);
   }
   oplot,[x1,x2,x2,x1,x1], \
         [y1,y1,y2,y2,y1];
}

/* Function boxoverlap */

func boxoverlap( box1, box2 )
/* DOCUMENT boxoverlap
;
;   Returns 1 if( there is an overlap between box1 && box2
;
;   "box" is an array of 4 numbers [x1,y1,x2,y2]
;
*/
{

   if( numberof(box1)  !=  4 ) {
      write,"BOXOVERLAP first argument must have 4 elements";
      return -1;
   }

   if( numberof(box2)  !=  4 ) {
      write,"BOXOVERLAP second argument must have 4 elements";
      return -1;
   }

   // Test for one corner of a box inside the other box

   if( box1(1)  >=  box2(1) && box1(1)  <=  box2(3) && \
      box1(2)  >=  box2(2) && box1(2)  <=  box2(4)      ) return 1;

   if( box1(1)  >=  box2(1) && box1(1)  <=  box2(3) && \
      box1(4)  >=  box2(2) && box1(4)  <=  box2(4)      ) return 1;

   if( box1(3)  >=  box2(1) && box1(3)  <=  box2(3) && \
      box1(2)  >=  box2(2) && box1(2)  <=  box2(4)      ) return 1;

   if( box1(3)  >=  box2(1) && box1(3)  <=  box2(3) && \
      box1(4)  >=  box2(2) && box1(4)  <=  box2(4)      ) return 1;

   if( box2(1)  >=  box1(1) && box2(1)  <=  box1(3) && \
      box2(2)  >=  box1(2) && box2(2)  <=  box1(4)      ) return 1;

   if( box2(1)  >=  box1(1) && box2(1)  <=  box1(3) && \
      box2(4)  >=  box1(2) && box2(4)  <=  box1(4)      ) return 1;

   if( box2(3)  >=  box1(1) && box2(3)  <=  box1(3) && \
      box2(2)  >=  box1(2) && box2(2)  <=  box1(4)      ) return 1;

   if( box2(3)  >=  box1(1) && box2(3)  <=  box1(3) && \
      box2(4)  >=  box1(2) && box2(4)  <=  box1(4)      ) return 1;

   // Test for overlap with no points inside

   if( box1(1)  <  box2(1) && box1(3)  >  box2(3) && \
      box2(2)  <  box1(2) && box2(4)  >  box1(4)      ) return 1;

   if( box2(1)  <  box1(1) && box2(3)  >  box1(3) && \
      box1(2)  <  box2(2) && box1(4)  >  box2(4)      ) return 1;

   return 0;

}

/* Function get_pmap */

func get_pmap( xsrc, ysrc, &xpmap, &ypmap )
/* DOCUMENT pmap = get_pmap( xsrc, ysrc, >xpmap, >ypmap )

   returns a 100x100 map of NDC positions with a value
   the higher the more preferred.
   Arguments x(y)pmap get the axis arrays in NDC.

*/
{
   // NDC window limits
   vp = viewport();

   xpmap = span(vp(1),vp(2),101)(zcen);       // pixel centers
   ypmap = span(vp(3),vp(4),101)(zcen);       // pixel centers

/*
 *  Position map
 *      high value: a preferable position
 *      negative value: a forbidden position
 */

   pmap = array(double,100,100);

   yroof = 1.0 * abs(ypmap-ysrc);
   pmap += max(yroof) - yroof(-,);
   xroof = 1.0 * abs(xpmap-xsrc);
   pmap += max(xroof) - xroof(,-);

   // regions below the source are less preferred

   w = where(ypmap < ysrc);
   if(numberof(w)) pmap(,w) *= 0.7;

   return pmap;

}
%FILE% spair.i
func spair( n_players, n_games )
{
   // n_players must be even
   n2 = n_players/2;
   if( n2*2 != n_players ) error,"Odd number of players";
   n_pairs = n2 * (n_players-1);
   a = array(long,n_pairs);
   aidx = indgen(n_players);

   for( i = 1; i <= n_games; i++ ) {
      // choose half in a random way
      r = 1;
      while( r ) { // repeat until all are different
         idx = long(random(n2)*n_players)+1;
         idx = idx(sort(idx));
         u = uniq(idx);
         r = (numberof(u) < n2);
      }
      nidx = rem_elem( aidx, idx );
      for( j = 1; j <= n2; j++ ) {
         for( k = j+1; k <= n2; k++ ) {
            a(pair_number(idx(j),idx(k)))++;
            a(pair_number(nidx(j),nidx(k)))++;
         }
      }
   }

   return a;

}

func pair_number( player1, player2 )
/* DOCUMENT  numbering scheme
   1.2                               : 1
   1.3 2.3                           : (2*1/2)+1 -> (3*2/2)
   1.4 2.4 3.4                       : (3*2/2)+1 -> (4*3/2)
    .   .
   1.n 2.n 3.n ... n-1.n             : ((n-1)*(n-2)/2)+1 -> (n*(n-1)/2)
*/
{
   if( player1 < player2 ) { // player2 is 'n'
      n = player2;
      i = player1;
   } else {
      n = player1;
      i = player2;
   }
   return ((n-1)*(n-2))/2 + i;
}
      
%FILE% spand.i
func spand( xmin, xmax, n )
/* DOCUMENT arr = spand( xmin, xmax, n )

    Returns n numbers with linearly increasing differences.
    A result somewhere beteen 'span' and 'spanl'.
*/
{
   xmin = double(xmin);
   xmax = double(xmax);
   k2 = (xmax-xmin)/(double(n)*(n-1));
   a = double(indgen(n));
   return k2 * a * (a - 1) + xmin;
}
%FILE% specfit.i
extern specfitdoc;
/* DOCUMENT ****************************************

   A collection of function for ARF and RMF manipulations of
   various kinds:

     make_arf   :  Construct an ARF from a Crab spectrum and
                   an RMF file
     arffit_photspec : Return a photon spectrum for given
                       spectral model
     j_pack_rmf :  Produce an RMF file from a template
     j_rdm_rebin : Return a rebinned redistribution matrix

     2009-06-22/NJW

*********************************************************/

/* Function make_arf */

func make_arf( dialog=, noplot=, vh= )
/* DOCUMENT make_arf, dialog=, noplot=, vh=

   Procedure: Take a Crab spectrum and the corresponding ARF (arfc)
   as defined in the parameter file "make_arf.par" i.e. _NOT_ the
   anchor file (ANCRFILE) from the column in the spectral file.
   If "make_arf.par" does not exist in the current directory then
   the environment variable PFILES is used to locate it.

   This ARF (arfc) is the starting array for the new adaption.

   Create a new file ('new_arf_file') with the resulting ARF
   (the array "eflt" multiplied with arfc) and update the the
   column "ANCRFILE" in the spectral file with the new ARF file.

   The names of these files are stored in "make_arf.par"
   and can be read from there.

   Keyword 'dialog' should be set for user interaction.
   Keyword 'noplot' will prevent all plotting when set.
   Keyword 'vh' is the energy limit between medium and very high energy
                     defaults to 28 keV

   Contents of "make_arf.par" :

      INPUT files:

    crab_spe_file : spectral file such as jmx2_srcl_spe.fits with the
                    spectrum on which to base the ARF.
                    [The column ANCRFILE is updated with the name of
                     the 'new_arf_file' (see below)].
    begin_arf_file : arf file such as jmx2_srcl_arf.fits
                     The start arf for the ARF adaption
    rmf_grp_file  : the RMF.-GRP file with energy boundaries and
                    redistribution matrix for the fitting

       OUTPUT files:

    new_arf_file  : new ARF file - product of "make_arf"
    new_eflt_file : by-product of "make_arf", gives the energy dependent ratio
                    between new_arf and begin_arf
*****************************************************************************/
{

   extern  e_min, e_max, matrix, arf;
   extern  rate, stat_err, countspec, number;
   extern  elo, ehi, eline, spectrcode;
   extern  const, param1, nh, chi2red, sx;
   extern  rmf_grp_file;

   parfile = pfiles_path("make_arf.par");

   if( dialog ) {
      write,"INPUT file with canonical count spectrum:";
      crab_spe_file = get_spars(parfile,"crab_spe_file");
      write,"INPUT file with initial ARF:";
      begin_arf_file = get_spars(parfile,"begin_arf_file");
      write,"INPUT RMF file with energy arrays and redistribution matrix:";
      rmf_grp_file = get_spars(parfile,"rmf_grp_file");
      write,"OUTPUT, name of file with resulting ARF:";
      new_arf_file = get_spars(parfile,"new_arf_file");
      write,"OUTPUT, name of EFLT file (ratio between input and resulting ARF):";
      new_eflt_file = get_spars(parfile,"new_eflt_file");
   } else {
      crab_spe_file = comgets(parfile,"crab_spe_file");
      begin_arf_file = comgets(parfile,"begin_arf_file");
      rmf_grp_file = comgets(parfile,"rmf_grp_file");
      new_arf_file = comgets(parfile,"new_arf_file");
      new_eflt_file = comgets(parfile,"new_eflt_file");
   }

   pflag = is_void(noplot);
   if( is_void(vh) ) vh = 28.0;

   p = strpos(crab_spe_file,"jmx1");
   if( p  >=  1 ) {
      strj = "1";
   } else {
      p = strpos(crab_spe_file,"jmx2");
      if( p  >=  1 ) {
         strj = "2";
      } else {
         strj = "";
         read,prompt="Enter JEMX number : ... ", strj;
      }
   }

   // Read the ARF in the "begin_arf_file"

   arfc = rdfitscol(begin_arf_file+"+1","SPECRESP");
   dms = dimsof(arfc);
   if( dms(1) == 2 ) arfc = arfc(,1);

   // Assume that the Crab spectrum is the first spectrum in the file
   // Read the spectral information

   rate = rdfitscol(crab_spe_file+"+1","RATE");
   stat_err = rdfitscol(crab_spe_file+"+1","STAT_ERR");

   // Define energy boundaries:

   extname = "[JMX"+strj+"-FBDS-MOD]";
   e_min = rdfitscol(rmf_grp_file+extname,"E_MIN",silent=1);
   e_max = rdfitscol(rmf_grp_file+extname,"E_MAX",silent=1);
   extname = "[JMX"+strj+"-RMF.-RSP]";
   elo = rdfitscol(rmf_grp_file+extname,"ENERG_LO",silent=1);
   n_eline = numberof(elo);
   ehi = rdfitscol(rmf_grp_file+extname,"ENERG_HI",silent=1);
   matrix = rdfitscol(rmf_grp_file+extname,"MATRIX",silent=1);
   eline = sqrt(elo*ehi);

   // --    rebinning can be done here if required

   //+ rebin = indgen(46:223);
   //+ e_min = e_min(rebin);
   //+ e_max = e_max(rebin);
   //+ matrix = matrix(rebin,);
   //+ rate = rate(rebin);
   //+ stat_err = stat_err(rebin);

   //===================================================================

   if( pflag ) {

      // Plot the original data

      window,0;

      dataplot, sqrt(e_min*e_max),rate/(e_max-e_min), \
             stat_err/(e_max-e_min),xbar=1,itype=3, \
             title="Original data + HE fit", \
             xtitle="Energy [keV]";
   }


   //   Define the spectral model

   spectrcode = "PL";

   const = 9.7;
   param1 = 2.1;
   nh = 0.365; // in units of 1.e22
   sigma = 0.4;
   eflt = array(1.,500);

   //   Generate the input spectrum

   flux = arffit_photspec([const,param1,nh]);
   bcnts = flux * (ehi - elo) * arfc;

   c2base = chi2rel(matrix(,+)*(bcnts*eflt)(+), rate, stat_err);
   efltmin = eflt;
   write,"c2base = ", c2base;

//+// ================   Work on medium high energy part   ==============
//+
//+   // Find index of "e_min" for 10 keV < E < vh keV
//+   i10keV = where( min(abs(e_min-10))==abs(e_min-10))(1);
//+   ivhkeV = where( min(abs(e_min-vh))==abs(e_min-vh))(1);
//+   //+ w = indgen(i10keV:numberof(e_min));
//+   w = indgen(i10keV:ivhkeV);
//+   c2hbase = chi2rel((matrix(,+)*(bcnts*eflt)(+))(w), rate(w), stat_err(w));
//+
//+   c2hmin = c2hbase;
//+   almin = 0.0;
//+   fkmin = 1.0;
//+   for( al = 0.9; al > -0.9; al -= 0.01 ) {
//+      eflt_exp = (eline/10.)^al;
//+      c2h = chi2rel((matrix(,+)*(bcnts*eflt_exp)(+))(w), rate(w), stat_err(w), fk);
//+      if( c2h < c2hmin ) {
//+         almin = al;
//+         c2hmin = c2h;
//+         fkmin = fk;
//+      }
//+   }
//+
//+   write,"Medium high energy slope: ", almin;
//+   eflt = (eline/10.)^almin;
//+
//+   if( pflag ) {
//+       oplot, sqrt(e_min*e_max), \
//+          fkmin*(matrix(,+)*(bcnts*eflt)(+))/(e_max-e_min),ps=10;
//+       ans = "";
//+       read,prompt="Continue ... ",format="%s",ans;
//+   }
//+
//+// ================   Work on very high energy part   ==============
//+
//+   jvhkeV = where( min(abs(eline-vh))==abs(eline-vh))(1);
//+   v = indgen(jvhkeV:numberof(eline));
//+   w = indgen(ivhkeV:numberof(e_min));
//+   c2hbase = chi2rel((matrix(,+)*(bcnts*eflt)(+))(w), rate(w), stat_err(w));
//+
//+   c2hmin = c2hbase;
//+   almin = 0.0;
//+   fkmin = 1.0;
//+   for( al = 0.9; al > -0.9; al -= 0.01 ) {
//+      eflt_exp = (eline/vh)^al;
//+      c2h = chi2rel((matrix(,+)*(bcnts*eflt_exp)(+))(w), rate(w), stat_err(w), fk);
//+      if( c2h < c2hmin ) {
//+         almin = al;
//+         c2hmin = c2h;
//+         fkmin = fk;
//+      }
//+   }
//+
//+   // Combine the medium high and very high
//+
//+   write,"Very high energy slope: ", almin;
//+   efltv = (eline/vh)^almin;
//+   eflt(v) = efltv(v)*eflt(jvhkeV)/efltv(jvhkeV);
//+
//+   if( pflag ) {
//+       oplot, sqrt(e_min*e_max), \
//+          fkmin*(matrix(,+)*(bcnts*eflt)(+))/(e_max-e_min),ps=10;
//+       ans = "";
//+       read,prompt="Continue ... ",format="%s",ans;
//+   }


// ================   Work on low energy part   ==============

   nxl = 57;
   xl = spanl(2., 40., nxl);
   dxl = delta(xl);

   c2min = chi2rel(matrix(,+)*(bcnts*eflt)(+), rate, stat_err);
   fkmin = 1.0;
   // Find index of "eline" for 3 keV
   i3keV = where( min(abs(eline-3))==abs(eline-3))(1);
   // Define smallest slope of ARF below 3 keV
   eta = 0.5;

   if( pflag ) {
      window,1;
      //+ window,2;
   }

   do {
      c2min_prev = c2min;

      rxl = xl + (random(nxl)-0.5)*0.9*dxl;

      for( ampl = -0.02; ampl < 0.02001; ampl += 0.04 ) {
         for( i = 1; i<= nxl; i++ ) {

            eflt1 = add_peak_1d( eline, eflt, rxl(i), sigma*(rxl(i)/3.)^0.7, ampl);
            // Ensure a minimum slope of "eta":
            arfeflt = arfc * eflt1;
            for( j = i3keV; j >= 2; j-- ) {
               arfeflt(j-1) = min(arfeflt(j-1) , arfeflt(j)*(eline(j-1)/eline(j))^eta);
               eflt1(j-1) = arfeflt(j-1) / arfc(j-1);
            }
            c2 = chi2rel(matrix(,+)*(bcnts*eflt1)(+), rate, stat_err, fk);
            if( c2  <  c2min ) {
               write,"i c2 fk = ", i, c2, fk;
               c2min = c2;
               imin = i;
               efltmin = eflt1;
               fkmin = fk;
               if( pflag ) {
                  window,1;
                  plot, eline,eflt1,xtitle="Energy [keV]", \
                        itype=2, yr=[0.1,13.],xr=[2,40],title="EFLT";
                  //+ window,0;
                  //+ dataplot, sqrt(e_min*e_max),rate/(e_max-e_min), \
                  //+     stat_err/(e_max-e_min),xbar=1,itype=3, \
                  //+     xtitle="Energy [keV]"; //     ;,yr=[1.e-2,10];
                  //+ oplot, sqrt(e_min*e_max), \
                  //+   fk*(matrix(,+)*(bcnts*eflt1)(+))/(e_max-e_min),ps=10;
               }
            }
            // ans = ""
            // read,"Next ...",ans
            // * wait,0.1
         }
      }

      //  Start over with updated "eflt"

      eflt = efltmin;

   } while( (c2min_prev - c2min)/c2min_prev  >  1.e-3);

   countspec = fkmin * (matrix(,+)*(bcnts*efltmin)(+));

   if( pflag ) {
      window,1;
      plot, eline, efltmin, xtitle="Energy [keV]", \
                xr=[2,40],itype=2;
      window,0;
      dataplot, sqrt(e_min*e_max),rate/(e_max-e_min), \
          stat_err/(e_max-e_min),xbar=1,itype=3, \
          title="Data with best fit", \
          xtitle="Energy [keV]";
      oplot, sqrt(e_min*e_max), countspec/(e_max-e_min),ps=10;
   }

   wrmfitscols, new_eflt_file, "EFLT", efltmin, clobber=1;

   k = sum(countspec*rate/stat_err^2) / sum(countspec^2/stat_err^2);


   // Derive the new ARF

   newarf = fkmin * efltmin * arfc;

   // Write ARF values to new_arf_file

   arf2phaii, new_arf_file, newarf, elo, ehi, instrume="JMX"+strj;

   // Update ANCRFILE name in crab_spe_file

   fh = headfits( crab_spe_file+"+1" );
   colnum = fits_colnum(fh,"ANCRFILE");
   fits_bintable_poke,crab_spe_file+"+1",1,colnum, new_arf_file+"{1}";

   if( pflag ) {
      window,2;
      plot,eline,arfc,itype=3,yr=[1,200],title="Old and new ARF", \
             xtitle="Energy [keV]",ytitle="Area [cm2]";
      oplot,eline,newarf,color="green";
      annot,mode="i";
      annot,"Input ARF",li=1;
      annot,"New ARF",li=1,color="green";
      annot,pos=[0.5,0];
   }

   f = open("tmpfil","w");
   write,f,format="RESPFILE = '%s' / Response file for e.g. xspec\n", rmf_grp_file;
   close, f;

   write,"  Remember to update "+crab_spe_file+" with RESPFILE as "+rmf_grp_file;
   write,"  The appropriate 'tmpfil' has been written";

   write,"";
   write,"After that you are ready to do an XSPEC fit on "+crab_spe_file;
   write,"to check the effect of making a new EFLT array";
   write,"";


}

/* Function arffit_photspec */

func arffit_photspec( p )
/* DOCUMENT  phot_spec = arffit_photspec( p )

  Function that returns the photon spectrum for a
  given set of spectral parameters
  in array "p":  (norm, param1, nh/1.e22)

*/
{
   if( numberof(p)  !=  3 ) {
      write,"arffit_photspec must be called with 3 element array";
      return -1.;
   }

   //   Define the external variables

   extern  e_min, e_max, matrix, arf;
   extern  rate, stat_err, countspec, number;
   extern  elo, ehi, eline, spectrcode;
   extern  const, param1, nh, chi2red, sx;


   const = p(1);
   param1 = p(2);
   nh = p(3) * 1.e22;

   //   Generate the photon spectrum

   if( spectrcode == "PL" ) {
      flux = const * eline^(-param1) * absorp(nh, eline);
   }
   else if( spectrcode == "TB") {
      flux = const * (exp(-eline/param1) / eline) * absorp(nh, eline);
   }
   else if( spectrcode == "DF") {
      index = where( abs(eline-param1) == min(abs(eline-param1)))(1);
      flux = fltarr(numberof(eline))
      flux(index) = const * absorp(nh, param1)
   }
   else {
      write,"No such spectral model allowed: ", spectrcode;
      return [];
   }


   return flux;

}

/* Function j_pack_rmf */

func j_pack_rmf( dialog= )
/* DOCUMENT j_pack_rmf, dialog=

   Parameter file: j_pack_rmf.par
   must exist in current directory or pointed to by PFILES.

   Will copy a template RMF file to a new file and update
   its contents. A parameter value of "noop" will cause a
   "no operation". If the template RDM has a smaller dimension
   than the given RDM the latter will be rebinned before the
   updating happens.

   The keyword 'dialog' will activate a user dialog.

   2009-07-08/NJW

*/
{
   local filename, extno;

  /*
   *   RMF file contents
   *          0   PHDU
   *          1   Index table
   *          2   JMXi-RMF.-RSP
   *          3   JMXi-FBDS-MOD
   *          4   JMXi-AXIS-ARF
   *          5   JMXi-IMAG-ARF
   */

   parfile = "j_pack_rmf.par";
   if( !file_test(parfile) ) {
      parfiles = strmsplit(get_env("PFILES"),":;")+"/j_pack_rmf.par";
      for( i = 1; i <= numberof(parfiles); i++ ) {
         if( file_test(parfiles(i)) ) {
            parfile = parfiles(i);
            goto accepted;
         }
      }
      write,"j_pack_rmf.par was not found";
      return;
   }
   
  accepted:

   if( dialog ) {
      write,"INPUT template RMF file:";
      template_rmf_file = get_spars(parfile,"template_rmf_file");
      write,"INPUT DOL of RDM:";
      dol_rdm = get_spars(parfile,"dol_rdm");
      write,"INPUT DOL of IMAG-ARF (for mosaic_spec spectra):";
      dol_imag_arf = get_spars(parfile,"dol_imag_arf");
      write,"INPUT DOL of AXIS-ARF (for SRCL-RES spectra):";
      dol_axis_arf = get_spars(parfile,"dol_axis_arf");
      write,"OUTPUT Name of new RMF file:";
      new_rmf_file = get_spars(parfile,"new_rmf_file");
   } else {
      template_rmf_file = comgets(parfile,"template_rmf_file");
      dol_rdm = comgets(parfile,"dol_rdm");
      dol_imag_arf = comgets(parfile,"dol_imag_arf");
      dol_axis_arf = comgets(parfile,"dol_axis_arf");
      new_rmf_file = comgets(parfile,"new_rmf_file");
   }

  /*
   *    Testing existence of files
   */

   flag = 0;
   if( !file_test(template_rmf_file) ) {
      write,"Did not find "+template_rmf_file;
      flag = 1;
   }
   if( dol_rdm != "noop" ) {
      get_exten_no, dol_rdm, filename, extno;
      if( !file_test(filename) ) {
         write,"Did not find "+dol_rdm;
         flag = 1;
      }
   }
   if( dol_imag_arf != "noop" ) {
      get_exten_no, dol_imag_arf, filename, extno;
      if( !file_test(filename) ) {
         write,"Did not find "+imag_arf;
         flag = 1;
      }
   }
   if( dol_axis_arf != "noop" ) {
      get_exten_no, dol_axis_arf, filename, extno;
      if( !file_test(filename) ) {
         write,"Did not find "+axis_arf;
         flag = 1;
      }
   }
   if( flag ) return;

   //   Make new RMF file by copying

   cp, template_rmf_file, new_rmf_file;
   write,"Has copied template to new file";

   //   Update the RDM

   if( dol_rdm != "noop" ) {
      rdm = float(rdfitscol( dol_rdm, "matrix" ));
      tpl_rdm = rdfitscol( template_rmf_file+"+2", "matrix" );
      dms_rdm = dimsof(rdm);
      dms_tpl_rdm = dimsof(tpl_rdm);
   
      if( dms_rdm(3) != dms_tpl_rdm(3) ) {
         write,"Mismatching RDM second dimension";
         return;
      }
      if( dms_rdm(2) != dms_tpl_rdm(2) ) { // rebinning can be done
                                           // under certain requirements
         if( dms_rdm(2) != 256 ) {
            write,"Rebinning must be from 256 bins";
            return;
         }
         e_min = rdfitscol(template_rmf_file+"+3","e_min");
         e_max = rdfitscol(template_rmf_file+"+3","e_max");
         rdm = j_rdm_rebin( rdm, e_min, e_max );
      }
      fh = headfits( template_rmf_file+"+2" );
      colnum = fits_colnum( fh, "matrix" );
      fits_bintable_poke, new_rmf_file+"+2", 1, colnum, rdm;
      write,"has updated the RDM MATRIX";
   }

   //   Update the AXIS-ARF

   if( dol_axis_arf != "noop" ) {
      axarf = float(rdfitscol( dol_axis_arf, "specresp" ));
      tpl_axarf = rdfitscol( template_rmf_file+"+4", "specresp" );
      if( numberof(axarf) != numberof(tpl_axarf) ) {
         write,"Mismatching AXIS-ARF dimension";
         return;
      }
      axarf = reform(axarf,dimsof(tpl_axarf));
      fh = headfits(template_rmf_file+"+4");
      colnum = fits_colnum(fh,"specresp");
      fits_bintable_poke, new_rmf_file+"+4", 1, colnum, axarf;
      write,"has updated the AXIS-ARF";
   }

   //   Update the IMAG-ARF

   if( dol_imag_arf != "noop" ) {
      imarf = float(rdfitscol( dol_imag_arf, "specresp" ));
      tpl_imarf = rdfitscol( template_rmf_file+"+5", "specresp" );
      if( numberof(imarf) != numberof(tpl_imarf) ) {
         write,"Mismatching IMAG-ARF dimension";
         return;
      }
      imarf = reform(imarf,dimsof(tpl_imarf));
      fh = headfits(template_rmf_file+"+5");
      colnum = fits_colnum(fh,"specresp");
      fits_bintable_poke, new_rmf_file+"+5", 1, colnum, imarf;
      write,"has updated the IMAG-ARF";
   }

   write,"\n DONE!\n";

}

/* Function j_rdm_rebin */

func j_rdm_rebin( rdm, e_min_or_chanlow, e_max_or_chanhigh )
/* DOCUMENT new_rdm = j_rdm_rebin( rdm, e_min_or_chanlow, e_max_or_chanhigh )

   Returns a rebinned RDM array.

   The arguments:
    'rdm' is the original 256 x 500 RDM for JEM-X.
    integer  (int or long)     arrays: Taken to be PI values of bin limits
    floating (float or double) arrays: Taken to be energy (keV) values of bin limits

   2009-07-08/NJW
*/
{
   dms = dimsof(rdm);
   if( dms(2) != 256 ) {
      write,"Incompatible dimension of RDM";
      return [];
   }

   n_chans = numberof(e_min_or_chanlow);
   if( anyof(typeof(e_min_or_chanlow) == ["double","float"]) ) {
      emn = rdfitscol("/r6/jemx/ic/rmf_grp/jmx1_rmf_grp_0039.fits+3","e_min");
      emx = rdfitscol("/r6/jemx/ic/rmf_grp/jmx1_rmf_grp_0039.fits+3","e_max");
      e_min = e_min_or_chanlow;
      e_max = e_max_or_chanhigh;
      flage = 1; // we have energy bins
   } else {
      chanlow = e_min_or_chanlow;
      chanhigh = e_max_or_chanhigh;
      flage = 0; // we have PI bins
   }
   rdm_rebinned = array(float,n_chans,dms(3));
   for(i=1;i<=n_chans;i++) {
      // if energy bins, find lower PI index
      j = flage ? where(abs(e_min(i)-emn) == min(abs(e_min(i)-emn)) )(1) : chanlow(i);
      if( i > 1 ) { // test continuity
         if( j != k+1 ) {
            write,format="Warning i: %i, j = %i, prev k = %i\n", i,j,k;
         }
      }
      // if energy bins, find upper PI index
      k = flage ? where(abs(e_max(i)-emx) == min(abs(e_max(i)-emx)) )(1) : chanhigh(i);
      buf = rdm(j:k,);
      rdm_rebinned(i,) = buf(sum,);
   }

   return rdm_rebinned;

}

/* Function analyze_rdm */

func analyze_rdm( rmf_file, ener, pl= )
/* DOCUMENT analyze_rdm, rmf_file, energy, pl=

    Get relative FWHM (in detector energy) for a redistribution
    matrix found in a standard RMF file.

    Keyword 'pl' will give a plot.

    2009-07-07/NJW
*/
{

   if( !file_test( rmf_file ) ) {
      write,"File not found";
      return;
   }

   // init keywords

   if( is_void(ener) ) ener = 20.; // keV

   if( strpos( strlowcase(rmf_file), "jmx1" ) ) {
      jstr = "jmx1"; Jstr = "JMX1";
   } else if( strpos( strlowcase(rmf_file), "jmx2" )) {
      jstr = "jmx2"; Jstr = "JMX2";
   } else {
      fh = headfits(rmf_file+"+1");
      instrume = fxpar(fh,"instrume");
      if( is_void(instrume) ) {
         j = "";
         read,prompt="jemxNum not found, please enter : ... ", j;
         jstr = "jmx"+j; Jstr = "JMX"+j;
      }
   }
   eb1 = rdfitscol(rmf_file+"["+Jstr+"-FBDS-MOD]","e_min");
   eb2 = rdfitscol(rmf_file+"["+Jstr+"-FBDS-MOD]","e_max");
   ew = eb2 - eb1;
   escale = 0.5*(eb1 + eb2);
   sigma = sqrt(escale)*0.05;
   
   mat = rdfitscol(rmf_file+"["+Jstr+"-RMF.-RSP]","matrix");
   elo = rdfitscol(rmf_file+"["+Jstr+"-RMF.-RSP]","energ_lo");
   ehi = rdfitscol(rmf_file+"["+Jstr+"-RMF.-RSP]","energ_hi");
   eline = sqrt(elo*ehi);
   idx = where( min(abs(eline-ener)) == abs(eline-ener) )(1);
   
   c = fold_gaussx(escale,mat(,idx)/ew,sigma);
   ampl = max(c);
   mean = sum(escale*c)/sum(c);
   sig = 1.;
   coefs = gaussfit( escale, mat(,idx)/ew, [ampl,mean,sig], yfit);
   if( pl ) {
      plot,escale,mat(,idx)/ew, ps=10,xtitle="Energy [keV]", \
          title=esc_underscore(rmf_file),xr=[0,40];
      oplot,escale,c,ps=10,color="blue";
      oplot,escale,yfit,color="red";
   }
   fwhm = 2.3548 * coefs(3);
   write,format="Relative FWHM at %6.3f keV : %5.2f%%\n", ener, fwhm*100./ener;
   
}

/* Function chi2rel */

func chi2rel( model, y, dy, &factor )
/* DOCUMENT chi2value = chi2rel( model, y, dy, >factor )

 Evaluate chi-square (independent of factor)

  ~1995/NJW
  2004-09-28/NJW updated to return factor
  2009-06-26/NJW translated to yorick

*/
{
   nm = numberof(model);
   if( nm  !=  numberof(y) || nm  !=  numberof(dy) ) {
      write,"CHI2REL Error: The arrays have different dimensions !";
      return -1.;
   }

   dy2 = dy * dy;
   factor = sum(y*model/dy2) / sum(model*model/dy2);
   d = (y - factor*model) / dy;
   return sum(d*d);
}
%FILE% speed.i
extern speeddoc;
/* DOCUMENT ********************************
 *  Larnum/larnum speed tests etc.
 *
 *      speed_gen, n
 *      speed_ref
 *      speed_checkx
 *******************************************/
func speed_gen( n )
{
   // n random numbers with 12 - 16 digits
   sn = "0123456789";
   csn = (*pointer(sn))(1:10);

   sp = open("speed_divup.scm","w");

   for( i = 1; i <= n; i++ ) {
      ndig = 12+long(random()*5);
      r1 = long(random()*9) + 2;
      r  = long(random(ndig-1)*10) + 1;
      grow,r1,r;
      c = array(char,ndig);
      for(j=1;j<=ndig;j++) c(j) = csn(r1(j));
      grow,c,0;
      s = string(&c);
      write,sp,format="%18s\n", s;
   }
   close, sp;
   write,"Has written spee_divup.scm";

   // n random numbers with 8 - 11 digits

   sp = open("speed_divdown.scm","w");

   for( i = 1; i <= n; i++ ) {
      ndig = 8+long(random()*4);
      r1 = long(random()*9) + 2;
      r  = long(random(ndig-1)*10) + 1;
      grow,r1,r;
      c = array(char,ndig);
      for(j=1;j<=ndig;j++) c(j) = csn(r1(j));
      grow,c,0;
      s = string(&c);
      write,sp,format="%13s\n", s;
   }
   close, sp;
   write,"Has written spee_divdown.scm";
}

func speed_ref
{
   up = strtrim(rdfile("speed_divup.scm"));
   down = strtrim(rdfile("speed_divdown.scm"));
   sp = open("speed_divref.scm","w");
   n = numberof(up);
   for(i = 1; i <= n; i++ ) {
      q = div(str2ln(up(i)),str2ln(down(i)), r );
      write,sp,format="%13s %13s\n", ln2str(q), ln2str(r);
   }
   close, sp;
   write,"Has written spee_divref.scm";
}

func speed_checkx
{
   write,"This functionality requires that you are running Larnum";
   up = strtrim(rdfile("speed_divup.scm"));
   down = strtrim(rdfile("speed_divdown.scm"));
   rstab,"speed_divref.scm",2,q,r,typ="ss",silent=1;
   n = numberof(up);
   for(i = 1; i <= n; i++ ) {
      qp = _divx(str2ln(up(i)),str2ln(down(i)), rp );
      lnq = str2ln(q(i));
      lnr = str2ln(r(i));
      if( !ln_eq( lnq, qp ) || !ln_eq( lnr, rp ) ) {
         write,format="Discrepancy at #%i\n", i;
      }
   }
}
%FILE% spreg_a.i
//                     2006-05-31/NJW
//
// This is a package for spectral extraction with
// regularization as a prototype for j_src_properties
//
// Define aperture response function for two sources
// that are arrays with NPIX elements
//
NPIX = 10000;
NENER = 10;
NSRC = 3; // number of sources
//random_seed, 0.8574635413644;
e = spanl(3.,30.,NENER);
flux = array(double,NSRC*NENER);
pif = array(double,NSRC,NPIX); // Assume energy independence for a start
cvec = ["black","red","green","blue"];

for( src = 1; src <= NSRC; ++src ) {
   ran = random(4);
   // define spectral shape
   norm = 50. + 50.*ran(1);
   slope = 0.5 + 2.0*ran(2);
   idx = indgen(NENER) + (src-1)*NENER;
   flux(idx) = norm * e^(-slope);
   // define aperture functions
   x0 = 0. + 2*pi*ran(3);
   x1 = 5. + 15.*ran(4);
   pif(src,) = 0.5*(cos(span(x0,x1*2*pi,NPIX)) + 1);
}
// plot flux values
yrg = log10([min(flux), max(flux)]);
idx = indgen(NENER);
plot,log10(e), log10(flux(idx)), ps=10, yr=yrg;
for( src = 2; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(flux(idx)), ps=10, color=cvec(src);
}
// define measurements
// first all pixels in energy 1, then all pixels in energy 2 etc.
write,format="Calculate %s ...\n", "shadowgrams";
meas = array(double,NPIX*NENER);
numsmall = 0;
for(ener=1; ener<=NENER; ++ener) {
   for( pix=1; pix<=NPIX; ++pix) {
      summa = 0.0;
      for( src=1; src <= NSRC; ++src ) {
         summa += pif(src,pix) * flux((src-1)*NENER + ener);
      }
      meas((ener-1)*NPIX + pix) = poisson(summa);
      if( summa < 0.5 ) ++numsmall;
   }
}
write,format="%d of %d pixels with < 0.5 counts\n", numsmall, NENER*NPIX;

// define the key matrix
write,format="Defining the %s matrix ...\n","key";
mat = array(double,NPIX*NENER,NSRC*NENER);
for(src=1; src<=NSRC; ++src) {
   for(ener=1; ener<=NENER; ++ener ) {
      for(pix=1; pix<=NPIX; ++pix ) {
         mat((ener-1)*NPIX + pix,(src-1)*NENER + ener) = pif(src,pix);
      }
   }
}

// Solve for the fluxes by "Singular Value Decomposition"

write,format="Just before %s SVsolve\n","call of";
deriv_flux = SVsolve(mat, meas);
write,format="Just after %s SVsolve\n","call of";
w = where(deriv_flux <= 0);
nw = numberof(w);
if( nw > 0 ) {
   write,format="Warning! %d derived flux values are <= 0\n", numberof(w)
   deriv_flux(w) = 1.e-5;
}
// overplot flux values
for( src = 1; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(deriv_flux(idx)), ps=2, color=cvec(src);
}
%FILE% spreg_b.i
//                     2006-05-31/NJW
//
// This is a package for spectral extraction with
// regularization as a prototype for j_src_properties
//
// Define aperture response function for NSRC sources
// that are arrays with NPIX elements
//
require, "plot.i";
require, "idlx.i";
require, "image.i";

NPIX = 10000;
NENER = 12;
NSRC = 3; // number of sources
SIGMALOLIMIT = 1.0;
random_seed, 0.8564635413644;
e = spanl(3.,15.,NENER);
flux = array(double,NSRC*NENER);
pif = array(double,NSRC,NPIX); // Assume energy independence for a start
cvec = ["black","red","green","blue"];

for( src = 1; src <= NSRC; ++src ) {
   ran = random(4);
   // define spectral shape
   norm = 10. + 10.*ran(1);
   slope = 0.5 + 2.0*ran(2);
   idx = indgen(NENER) + (src-1)*NENER;
   flux(idx) = norm * e^(-slope);
   // define aperture functions
   x0 = 0. + 2*pi*ran(3);
   x1 = 5. + 15.*ran(4);
   pif(src,) = 0.5*(cos(span(x0,x1*2*pi,NPIX)) + 1);
}
// plot flux values
yrg = log10([min(flux), max(flux)]);
idx = indgen(NENER);
plot,log10(e), log10(flux(idx)), ps=10, yr=yrg;
for( src = 2; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(flux(idx)), ps=10, color=cvec(src);
}
// define measurements
// first all pixels in energy 1, then all pixels in energy 2 etc.
write,format="Calculate %s ...\n", "shadowgrams";
meas = array(double,NPIX*NENER);
sigma_meas = array(double,NPIX*NENER);
numsmall = 0;
numsmallsigma = 0;
for(ener=1; ener<=NENER; ++ener) {
   for( pix=1; pix<=NPIX; ++pix) {
      summa = 0.0;
      for( src=1; src <= NSRC; ++src ) {
         summa += pif(src,pix) * flux((src-1)*NENER + ener);
      }
      sigma = sqrt(summa);
      if( sigma < SIGMALOLIMIT ) {
         sigma = SIGMALOLIMIT;
         numsmallsigma++;
      }
      meas((ener-1)*NPIX + pix) = poisson(summa)/sigma;
      sigma_meas((ener-1)*NPIX + pix) = sigma;
      if( summa < 0.5 ) ++numsmall;
   }
}
write,format="%d of %d pixels with < 0.5 counts\n", numsmall, NENER*NPIX;
write,format="%d of %d pixels with sigma < %5.2f counts\n", \
      numsmallsigma, NENER*NPIX, SIGMALOLIMIT;

// define the key matrix
write,format="Defining the %s matrix ...\n","key";
mat = array(double,NPIX*NENER,NSRC*NENER);
apix = indgen(NPIX);
for(src=1; src<=NSRC; ++src) {
   for(ener=1; ener<=NENER; ++ener ) {
      mat((ener-1)*NPIX + apix,(src-1)*NENER + ener) \
                = pif(src,)/sigma_meas((ener-1)*NPIX + apix);
   }
}

//-----------------------------------------------------
//    Direct solution of mat * flux = meas
//-----------------------------------------------------
// Solve for the fluxes by "Singular Value Decomposition"

write,format="Just before %s SVsolve\n","call of";
deriv_flux = SVsolve(mat, meas);
write,format="Just after %s SVsolve\n","call of";
w = where(deriv_flux <= 0);
nw = numberof(w);
if( nw > 0 ) {
   write,format="Warning! %d derived flux values are <= 0\n", numberof(w)
   deriv_flux(w) = 1.e-5;
}
// overplot flux values
for( src = 1; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(deriv_flux(idx)), ps=2, color=cvec(src);
}

//---------------------------------------------------------
//   Solve transpose(mat)*mat * flux = transpose(mat) * meas
//---------------------------------------------------------

matt = transpose(mat);
mattmat = matt(,+) * mat(+,);
mattmeas = matt(,+) * meas(+);
write,format="Just before %s SVsolve (2)\n","call of";
deriv_flux2 = SVsolve(mattmat, mattmeas);
write,format="Just after %s SVsolve (2)\n","call of";
w = where(deriv_flux2 <= 0);
nw = numberof(w);
if( nw > 0 ) {
   write,format="Warning! %d derived flux2 values are <= 0\n", numberof(w)
   deriv_flux2(w) = 1.e-5;
}
// overplot flux2 values
for( src = 1; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(deriv_flux2(idx)), ps=2, color=cvec(src);
}

//---------------------------------------------------------
//  Prepare the regularization process
//---------------------------------------------------------

degree = 1; // impose linearity on fluxes
degree = 2; // impose 2. order on fluxes

bmat = spreg_bmat( NSRC, NENER, degree );
h = transpose(bmat)(,+) * bmat(+,);
lambda = 10000.0;

//-------------------------------------------------------------------------
//   Solve (transpose(mat)*mat + lambda*h) * flux = transpose(mat) * meas
//-------------------------------------------------------------------------

write,format="Just before %s SVsolve (3)\n","call of";
deriv_flux3 = SVsolve(mattmat + lambda*h, mattmeas);
write,format="Just after %s SVsolve (3)\n","call of";
w = where(deriv_flux3 <= 0);
nw = numberof(w);
if( nw > 0 ) {
   write,format="Warning! %d derived flux3 values are <= 0\n", numberof(w)
   deriv_flux3(w) = 1.e-5;
}
// overplot flux3 values
for( src = 1; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(deriv_flux3(idx)), color=cvec(src);
}
%FILE% spreg_c.i
//     2006-05-31/NJW, original version
//     2006-06-09/NJW, based on spreg_b.i
//
// This is a package for spectral extraction with
// regularization as a prototype for j_src_properties
//
// Define aperture response function for NSRC sources
// that are arrays with NPIX elements
//
require, "plot.i";
require, "idlx.i";
require, "image.i";
require, "spreg_f.i";

NPIX = 10000;
NENER = 12;
NSRC = 3; // number of sources
SIGMALOLIMIT = 1.0;
random_seed, 0.8564635413644;
e = spanl(3.,15.,NENER);
flux = array(double,NSRC*NENER);
pif = array(double,NSRC,NENER,NPIX);
cvec = ["black","red","green","blue"];

ran = random(2*NSRC+2*NSRC*NENER);

kr = 0;
for( src = 1; src <= NSRC; ++src ) {
   // define spectral shape
   norm = 10. + 10.*ran(++kr);
   slope = 0.5 + 2.0*ran(++kr);
   idx = indgen(NENER) + (src-1)*NENER;
   flux(idx) = norm * e^(-slope);
   x0 = 0. + 2*pi*ran(++kr);
   x1 = 5. + 15.*ran(++kr);
   for( ener = 1; ener <= NENER; ++ener ) {
      // define aperture functions
      // x0 = 0. + 2*pi*ran(++kr);
      // x1 = 5. + 15.*ran(++kr);
      pif(src,ener,) = 0.5*(cos(span(x0,x1*2*pi,NPIX)) + 1);
   }
}
// plot flux values
yrg = log10([min(flux), max(flux)]);
idx = indgen(NENER);
plot,log10(e), log10(flux(idx)), ps=10, yr=yrg;
for( src = 2; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(flux(idx)), ps=10, color=cvec(src);
}
// define measurements
// first all pixels in energy 1, then all pixels in energy 2 etc.
write,format="Calculate %s ...\n", "shadowgrams";
meas = array(double,NPIX*NENER);
sigma_meas = array(double,NENER,NPIX);
numsmall = 0;
numsmallsigma = 0;
for(ener=1; ener<=NENER; ++ener) {
   for( pix=1; pix<=NPIX; ++pix) {
      summa = 0.0;
      for( src=1; src <= NSRC; ++src ) {
         summa += pif(src,ener,pix) * flux((src-1)*NENER + ener);
      }
      sigma = sqrt(summa);
      if( sigma < SIGMALOLIMIT ) {
         sigma = SIGMALOLIMIT;
         numsmallsigma++;
      }
      meas((ener-1)*NPIX + pix) = poisson(summa)/sigma;
      sigma_meas(ener, pix) = sigma;
      if( summa < 0.5 ) ++numsmall;
   }
}
write,format="%d of %d pixels with < 0.5 counts\n", numsmall, NENER*NPIX;
write,format="%d of %d pixels with sigma < %5.2f counts\n", \
      numsmallsigma, NENER*NPIX, SIGMALOLIMIT;

// define the key matrix
write,format="Defining the %s matrix ...\n","key";
mat = array(double,NPIX*NENER,NSRC*NENER);
apix = indgen(NPIX);
for(src=1; src<=NSRC; ++src) {
   for(ener=1; ener<=NENER; ++ener ) {
      mat((ener-1)*NPIX + apix,(src-1)*NENER + ener) \
                = pif(src,ener,)/sigma_meas(ener,);
   }
}

//---------------------------------------------------------
//   Get AtA directly
//---------------------------------------------------------

// a(i,j)     i = 1, ... , NENER*NPIX; j = 1, ... , NSRC*NENER
//        ener = (i-1)/NPIX + 1
//        pix  = (i-1)%NPIX + 1
//        src  = (j-1)/NENER + 1
//        scol = (j-1)%NENER + 1 (submatrix column number, also energy)
//   if( scol != ener ) a(i,j) = 0;
//   else a(i,j) = pif(src,ener,pix) / sigma_meas(ener, pix);
//
//   AtA(k,l) = sum_s(a(s,k)*a(s,l));
//
AtA = array(double,NENER*NSRC,NENER*NSRC);
Atmeas = array(double,NENER*NSRC);
for( k = 1; k <= NENER*NSRC; k++ ) {
   src_k = (k-1)/NENER + 1;
   ener_k = (k-1)%NENER + 1;
   ask = pif(src_k,ener_k,) / sigma_meas(ener_k,);
   meas_aux = meas((ener_k-1)*NPIX + apix);
   Atmeas(k) = ask(+)*meas_aux(+);
   for( l = k; l <= NENER*NSRC; l++ ) { // exploit symmetry
      src_l = (l-1)/NENER + 1;
      ener_l = (l-1)%NENER + 1;
      if( ener_k == ener_l ) {
         asl = pif(src_l,ener_l,) / sigma_meas(ener_l,);
         AtA(k,l) = ask(+)*asl(+);
         AtA(l,k) = AtA(k,l);
      }
   }
}

//---------------------------------------------------------
//   Solve AtA * flux = Atmeas
//---------------------------------------------------------

write,format="Just before %s SVsolve (1)\n","call of";
deriv_flux1 = SVsolve(AtA, Atmeas);
write,format="Just after %s SVsolve (1)\n","call of";
w = where(deriv_flux1 <= 0);
nw = numberof(w);
if( nw > 0 ) {
   write,format="Warning! %d derived flux1 values are <= 0\n", numberof(w)
   deriv_flux1(w) = 1.e-5;
}
// overplot flux1 values
for( src = 1; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(deriv_flux1(idx)), ps=1, symsize=2, color=cvec(src);
}

//---------------------------------------------------------
//   Solve transpose(mat)*mat * flux = transpose(mat) * meas
//---------------------------------------------------------

matt = transpose(mat);
mattmat = matt(,+) * mat(+,);
mattmeas = matt(,+) * meas(+);
write,format="Just before %s SVsolve (2)\n","call of";
deriv_flux2 = SVsolve(mattmat, mattmeas);
write,format="Just after %s SVsolve (2)\n","call of";
w = where(deriv_flux2 <= 0);
nw = numberof(w);
if( nw > 0 ) {
   write,format="Warning! %d derived flux2 values are <= 0\n", numberof(w)
   deriv_flux2(w) = 1.e-5;
}
// overplot flux2 values
for( src = 1; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(deriv_flux2(idx)), ps=2, color=cvec(src);
}

//---------------------------------------------------------
//  Prepare the regularization process
//---------------------------------------------------------

degree = 1; // impose linearity on fluxes
degree = 2; // impose 2. order on fluxes

bmat = spreg_bmat( NSRC, NENER, degree );
h = transpose(bmat)(,+) * bmat(+,);
lambda = 10000.0;

//-------------------------------------------------------------------------
//   Solve (transpose(mat)*mat + lambda*h) * flux = transpose(mat) * meas
//-------------------------------------------------------------------------

write,format="Just before %s SVsolve (3)\n","call of";
deriv_flux3 = SVsolve(mattmat + lambda*h, mattmeas);
write,format="Just after %s SVsolve (3)\n","call of";
w = where(deriv_flux3 <= 0);
nw = numberof(w);
if( nw > 0 ) {
   write,format="Warning! %d derived flux3 values are <= 0\n", numberof(w)
   deriv_flux3(w) = 1.e-5;
}
// overplot flux3 values
for( src = 1; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(deriv_flux3(idx)), color=cvec(src);
}
%FILE% spreg_d.i
//     2006-05-31/NJW, original version
//     2006-06-09/NJW, based on spreg_b.i
//
// This is a package for spectral extraction with
// regularization as a prototype for j_src_properties
//
// Define aperture response function for NSRC sources
// that are arrays with NPIX elements
//
// The 'big' array is avoided here because the transpose(A)*A
// as well as transpose(A)*measurement is calculated directly
// so that the matrix dimension is NSRC * NENER

require, "plot.i";
require, "idlx.i";
require, "image.i";
require, "random.i";
require, "spreg_f.i";

NPIX = 10000;
NENER = 12;
NSRC = 4; // Number of sources. Last source is background
SIGMALOLIMIT = 1.0;
norm_vec = [20., 18., 10., 0.2];
slope_vec = [1.4, 1.2, 2.1, 0.0];
x0_vec = [0.268887,0.325119,0.897209,0.522255];
x1_vec = [0.762886,0.304217,0.308984,0.636851];
//random_seed, 0.8564635413644;
e = spanl(3.,15.,NENER);
flux = array(double,NSRC*NENER);
pif = array(double,NSRC,NENER,NPIX);
cvec = ["black","red","green","blue"];

ran = random(2*NSRC+2*NSRC*NENER);

kr = 0;
for( src = 1; src <= NSRC; ++src ) {
   // define spectral shape
   norm = norm_vec(src);
   slope = slope_vec(src);
   idx = indgen(NENER) + (src-1)*NENER;
   flux(idx) = norm * e^(-slope);
   x0 = 0. + 2*pi*x0_vec(src);
   x1 = 5. + 15.*x1_vec(src);
   for( ener = 1; ener <= NENER; ++ener ) {
      // define aperture functions
      // x0 = 0. + 2*pi*ran(++kr);
      // x1 = 5. + 15.*ran(++kr);
      if( src == NSRC ) {
         pif(src,ener,) = 1.0;
      } else {
         pif(src,ener,) = 0.5*(cos(span(x0,x1*2*pi,NPIX)) + 1);
      }
   }
}
// plot flux values
yrg = log10([min(flux), max(flux)]);
idx = indgen(NENER);
plot,log10(e), log10(flux(idx)), ps=10, yr=yrg;
for( src = 2; src <= NSRC; ++src ) {
   idx = indgen(NENER) + (src-1)*NENER;
   oplot, log10(e), log10(flux(idx)), ps=10, color=cvec(src);
}
// define measurements
// first all pixels in energy 1, then all pixels in energy 2 etc.
write,format="Calculate %s ...\n", "shadowgrams";
meas = array(double,NPIX*NENER);
sigma_meas = array(double,NENER,NPIX);
numsmall = 0;
numsmallsigma = 0;
stat_cnts = array(double, NENER);
stat_summa = array(double, NSRC, NENER);
for(ener=1; ener<=NENER; ++ener) {
   write,format="e %3d", ener;
   for( src = 1; src <= NSRC; ++src ) {
      stat_summa(src,ener) = pif(src,ener,sum) * flux((src-1)*NENER + ener);
      write,format="%8.2f ",stat_summa(src,ener);
   }
   sumsumma = 0.0;
   for( pix=1; pix<=NPIX; ++pix) {
      summa = 0.0;
      for( src=1; src <= NSRC; ++src ) {
         summa += pif(src,ener,pix) * flux((src-1)*NENER + ener);
      }
      sumsumma += summa;
      sigma = sqrt(summa);
      if( sigma < SIGMALOLIMIT ) {
         sigma = SIGMALOLIMIT;
         numsmallsigma++;
      }
      poi = poisson(summa);
      stat_cnts(ener) += poi;
      meas((ener-1)*NPIX + pix) = poi/sigma;
      sigma_meas(ener, pix) = sigma;
      if( summa < 0.5 ) ++numsmall;
   }
   write,format="%9.2f %9.2f\n", sumsumma, stat_cnts(ener);
}
write,format="%8d of %8d pixels with < 0.5 counts\n", numsmall, NENER*NPIX;
write,format="%8d of %8d pixels with sigma < %5.2f counts\n", \
      numsmallsigma, NENER*NPIX, SIGMALOLIMIT;

//---------------------------------------------------------
//   Get AtA directly
//---------------------------------------------------------

// a(i,j)     i = 1, ... , NENER*NPIX; j = 1, ... , NSRC*NENER
//        ener = (i-1)/NPIX + 1
//        pix  = (i-1)%NPIX + 1
//        src  = (j-1)/NENER + 1
//        scol = (j-1)%NENER + 1 (submatrix column number, also energy)
//   if( scol != ener ) a(i,j) = 0;
//   else a(i,j) = pif(src,ener,pix) / sigma_meas(ener, pix);
//
//   AtA(k,l) = sum_s(a(s,k)*a(s,l));
//
AtA = array(double,NENER*NSRC,NENER*NSRC);
Atmeas = array(double,NENER*NSRC);
apix = indgen(NPIX);
for( k = 1; k <= NENER*NSRC; k++ ) {
   src_k = (k-1)/NENER + 1;
   ener_k = (k-1)%NENER + 1;
   ask = pif(src_k,ener_k,) / sigma_meas(ener_k,);
   meas_aux = meas((ener_k-1)*NPIX + apix);
   Atmeas(k) = ask(+)*meas_aux(+);
   for( l = k; l <= NENER*NSRC; l++ ) { // exploit symmetry
      src_l = (l-1)/NENER + 1;
      ener_l = (l-1)%NENER + 1;
      if( ener_k == ener_l ) {
         asl = pif(src_l,ener_l,) / sigma_meas(ener_l,);
         AtA(k,l) = ask(+)*asl(+);
         AtA(l,k) = AtA(k,l);
      }
   }
}

//---------------------------------------------------------
//  Prepare the regularization process
//---------------------------------------------------------

degree = 2; // impose 2. order on fluxes
degree = 1; // impose linearity on fluxes

bmat = spreg_bmat( NSRC, NENER, degree );
H = transpose(bmat)(,+) * bmat(+,);

lambda = 100.0;
while( lambda < 101000.0 ) {

   //-------------------------------------------------------------------------
   //   Solve (AtA + lambda*H) * flux = At * meas
   //-------------------------------------------------------------------------

   write,format="Just before %s SVsolve (3)\n","call of";
   deriv_flux3 = SVsolve(AtA + lambda*H, Atmeas);
   write,format="Just after %s SVsolve (3)\n","call of";
   w = where(deriv_flux3 <= 0);
   nw = numberof(w);
   if( nw > 0 ) {
      write,format="Warning! %d derived flux3 values are <= 0\n", numberof(w)
      deriv_flux3(w) = 1.e-5;
   }
   // overplot flux3 values
   for( src = 1; src <= NSRC; ++src ) {
      idx = indgen(NENER) + (src-1)*NENER;
      if( lambda < 101.0 ) {
         oplot, log10(e), log10(deriv_flux3(idx)), ps=2, symsize=2, color=cvec(src);
      } else if ( lambda > 9999.0 ) {
         oplot, log10(e), log10(deriv_flux3(idx)), color=cvec(src);
      } else {
         oplot, log10(e), log10(deriv_flux3(idx)), li=2, color=cvec(src);
      }
   }

   lambda *= 10.0;

}
%FILE% spreg_f.i
/* Function spreg_bsub */

func spreg_bsub( num_energies, degree )
/* DOCUMENT bsub = spreg_bsub( num_energies, degree )

   returns a submatrix (num_energies-1-degree) x num_energies
   to include in general b-matrix
   degree: 0  constant
           1  linear
           2  quadratic

   spreg project 2006-06-08/NJW

*/
{
   if( degree < 0 || degree > 2 ) {
      write,format="Illegal value of degree: %d\n", degree;
      return [];
   }
   if( num_energies < 2 + degree ) {
      write,format="Dimension is too small: %d\n", num_energies;
      return [];
   }
   bs = array( double, num_energies-degree-1, num_energies );
   if( degree == 0 ) {
      for( k = 2; k <= num_energies; k++ ) {
         bs(k-1, k-1) = -1;
         bs(k-1, k  ) =  1;
      }
   } else if( degree == 1 ) {
      for( k = 3; k <= num_energies; k++ ) {
         bs(k-2, k-2) = -1;
         bs(k-2, k-1) =  2;
         bs(k-2, k  ) = -1;
      }
   } else {
      for( k = 4; k <= num_energies; k++ ) {
         bs(k-3, k-3) = -1;
         bs(k-3, k-2) =  3;
         bs(k-3, k-1) = -3;
         bs(k-3, k  ) =  1;
      }
   }

   return bs;

}
/* Function spreg_bmat */

func spreg_bmat( numsrcs, num_energies, degree )
/* DOCUMENT bmat = spreg_bmat( numsrcs, num_energies, degree )

   returns a matrix numsrcs*(num_energies-1-degree) x numsrcs*num_energies
   to include in general b-matrix
   degree: 0  constant
           1  linear
           2  quadratic

   spreg project 2006-06-08/NJW

*/
{
   bsub = spreg_bsub( num_energies, degree );
   bm = array( double, numsrcs*(num_energies-degree-1), numsrcs*num_energies );
   for( k = 1; k <= numsrcs; k++ ) {
      row1 = (k-1)*(num_energies - 1 - degree) + 1;
      col1 = (k-1)* num_energies               + 1;
      bm(row1:row1+num_energies-1-degree-1, col1:col1+num_energies-1) = bsub;
   }

   return bm;

}
%FILE% srcskymap.i
#include Y_CODE+"cyclicpeak.i"

func srcskymap( dolcat, outfile, dim=, sigma= )
/* DOCUMENT srcskymap, dolcat, outfile, dim=, sigma=

   Keyword 'dim' should be a multiple of 4
*/
{

   ra = rdfitscol( dolcat, "ra_obj");
   dec = rdfitscol( dolcat, "dec_obj");
   glb = galactic( ra, dec );
   lon = glb(,1);
   lat = glb(,2);

   if( is_void(dim) ) dim = 360;
   dim = 4*(dim/4); // ensure it is multiple of 4
   dimh = dim/2;
   dimq = dim/4;
   f = dim / 360.; // amplification factor

   nlon = numberof(lon);
   xy = aitoff(lon,lat);
   w = where(xy(1,) < 0.);
   if(numberof(w)) xy(1,w) += 360.;

   map = array(double,dim,dimh);
   amp = 1.0;
   if(is_void(sigma)) sigma = 0.6;

   for( i = 1; i <= nlon; i++ ) {
      ii = long(dim + 0.5 - f*xy(1,i) + dimh);
      jj = long(dimq + 0.5 + f*xy(2,i));
      map = cyclicpeak( map, amp, sigma, ii, jj );
   }

   ar = aitoff_area( map, inver=1);
   map(where(ar)) = max(map);

   // reverse lon axis
   //+ map = map(indgen(360:1:-1),);

   // Save the map

   kwds_init;
   kwds_set,"date",ndate(3),"Date of creation";
   kwds_set,"responsi","Niels J. Westergaard","Responsible";
   kwds_set,"extname","GLOBEMAP","name of extension";
   kwds_set,"maptype","PROJECTMAP","Map subjected to Aitoff projection";
   kwds_set,"ctype1","GLON-AIT","Hammer-Aitoff projection";
   kwds_set,"ctype2","GLAT-AIT","Hammer-Aitoff projection";
   kwds_set,"crpix1", dimh + 0.5,"reference pixel";
   kwds_set,"crpix2", dimq + 0.5,"reference pixel";
   kwds_set,"crval1",   0.0,"reference pixel value";
   kwds_set,"crval2",   0.0,"reference pixel value";
   kwds_set,"cdelt1",  -0.9/f,"degrees/pixel";
   kwds_set,"cdelt2",   0.9/f,"degrees/pixel";

   writefits, outfile, map, clobber=1;

   write,"Job is done";

}
%FILE% stat.i
/*************************************************

   'stat.i' - a package with statistical functions

   2010-05-27/NJW

**************************************************/

extern statdoc;
/* DOCUMENT stat.i

    poiss      Probability to get n counts when lambda is the average
    lpoiss     Logarithmic version of the above
    poiss_dist Returns array with Poisson distribution
    acpoiss    Probability to get n or more counts when lambda is the average

*/

/* Function poiss */

func poiss( n, lambda )
/* DOCUMENT p = poiss( n, lambda )

   Returns probability to get n counts when lambda is the average

   SEE ALSO: lpoiss, poiss_dist, poisson
*/
{
   return lambda^n * exp(-lambda) / facul(n);
}

/* Function lpoiss */

func lpoiss( n, lambda )
/* DOCUMENT p = lpoiss( n, lambda )

   Returns the natural logarithm of the probability
   to get n counts when lambda is the average.

   SEE ALSO: poiss, poiss_dist, poisson
*/
{
   return  n*log(lambda) - lambda - lfacul(n);
}

/* Function poiss_dist */

func poiss_dist( n, lambda )
/* DOCUMENT distribution = poiss_dist( n, lambda )

   Returns the Poisson distribution for an average of
   lambda from 0 to n-1 counts (i.e. n array elements).
*/
{
   distri = array(double, n);
   for(i = 0; i < n; i++ ) {
      distri(i+1) = exp(lpoiss(i,lambda));
   }
   return distri;
}

/* Function acpoiss */

func acpoiss( n, nb )
/* DOCUMENT p = acpoiss( n, nb )

   Returns the probability to get n or more counts
   with expected 'nb' in background.
*/
{
   p = 0.0;
   do {
      t = exp(lpoiss(n++,nb));
      p += t;
   } while( t > 1.e-4*p );
   return p;
}

%FILE% stitch.i
#include "varfuncs.i"

func stitch( x1,y1,x2,y2, lambda, &x, &y )
/* DOCUMENT stitch, x1, y1, x2, y2, lambda, >x, >y

     If the curve (x1,y1) overlaps in x with the
     curve (x2,y2) then the returned curve (x,y)
     is a gradual transition from curve 1 to curve 2.

     'lambda' is the parameter that describes the width
     of the transition zone in x.

     2012-12-04/NJW
*/
{
   if( x1(0) <= x2(1) ) error,"No overlap between curves";
   x = grow(x1,x2);
   x = x(sort(x));
   y1s = interp(y1,x1,x);
   y2s = interp(y2,x2,x);
   x0 = 0.5*(x1(0)+x2(1));
   y = y1s * (1 - sigmoid(x,x0,lambda)) + y2s * sigmoid(x,x0,lambda);
}
%FILE% string.i
/*
 * $Id: string.i,v 1.1.1.1 2005/09/18 22:06:00 dhmunro Exp $
 * String and related convenience functions.
 * (Based on routines contributed by Eric Theibaut.)
 */

/*---------------------------------------------------------------------------
 * string.i: string manipulation and miscellaneous functions for Yorick
 *           by Eric THIEBAUT.
 *----------------------------------------------------------------------------
 * History:
 *      01/23/05 by David Munro, reworked for yorick-1.6
 *      02/11/95 by Eric THIEBAUT: added definitions of `scalar()' and
 *              `is_vector()'.
 */

/* ------------------------------------------------------------------------ */

func gettime(&time)
/* DOCUMENT gettime -- get current time in the form "HH:MM:SS"
 *
 * SYNOPSIS: time= gettime();
 *           gettime, time;
 *
 * HISTORY: October 30, 1995 by Eric THIEBAUT.
 *
 * SEE ALSO: getdate, parsedate, timestamp.
 */
{ return (time= strpart(timestamp(), 12:19)); }

func getdate(&date)
/* DOCUMENT getdate -- get date of the day in the form "DD/MM/YY"
 *
 * SYNOPSIS: date= getdate();
 *           getdate, date;
 *
 * HISTORY: October 30, 1995 by Eric THIEBAUT.
 *
 * SEE ALSO: gettime, parsedate, timestamp.
 */
{
  local day, month, year;
  parsedate, timestamp(), day, month, year;
  year-= (year>=2000)? 2000 : 1900; 
  return (date= swrite(format="%02d/%02d/%02d", day, month, year));
}

func parsedate(timestamp, &day, &month, &year, &hour, &minute, &second)
/* DOCUMENT parsedate -- get numerical version of a timestamp
 *
 * SYNOPSIS: parsedate, timestamp, day,month,year, hour,minute,second;
 *           parsedate(timestamp)
 *
 * HISTORY: October 30, 1995 by Eric THIEBAUT.
 *   DHM modified for yorick-1.6 23/Jan/05
 *
 * SEE ALSO: gettime, getdate, timestamp.
 */
{
  dayName= "";
  monthName= "";
  day= year= hour= minute= second= 0;
  sread, timestamp, format="%s%s%d%d:%d:%d%d", dayName, monthName,
    day, hour, minute, second, year;
  month= where(monthName == ["Jan", "Feb", "Mar", "Apr",
                             "May", "Jun", "Jul", "Aug",
                             "Sep", "Oct", "Nov", "Dec"]);
  month= numberof(month)? month(1) : 13;
  return [day, month, year, hour, minute, second];
}

/* ------------------------------------------------------------------------ */

func strtoupper(s)
/* DOCUMENT strtoupper -- convert a string to upper case letters
 *
 * SYNOPSIS: s2 = strtoupper(s)
 *
 * HISTORY: October 10, 1995 by Eric THIEBAUT.
 *   DHM modified for yorick-1.6 23/Jan/05
 *
 * ********** DEPRECATED **************
 *   new code should use strcase directly
 *
 * SEE ALSO: strtolower
 */
{
  return strcase(1, s);
}

func strtolower(s)
/* DOCUMENT strtolower -- convert a string to lower case letters
 *
 * SYNOPSIS: s2 = strtolower(s)
 *
 * HISTORY: October 10, 1995 by Eric THIEBAUT.
 *   DHM modified for yorick-1.6 23/Jan/05
 *
 * ********** DEPRECATED **************
 *   new code should use strcase directly
 *
 * SEE ALSO: strtoupper
 */
{
  return strcase(0, s);
}

/* DHM removed strtrim, now in i0/ystr.i */

func strchr(s, c, last=)
/* DOCUMENT strchr -- get first/last index of a character in a string 
 *
 * SYNOPSIS: i = strchr(s, c)
 *           i = strchr(s, c, last=1)
 *
 * DIAGNOSTIC: returns 0 if character C is not found in string S.
 *
 * HISTORY: October 27, 1995 by Eric THIEBAUT.
 *   DHM modified for yorick-1.6 23/Jan/05
 *
 * ********** DEPRECATED **************
 *   new code should use strfind directly
 *
 * SEE ALSO: strmatch
 */
{
  if (is_void(last)) last = 0;
  return max(strfind(string(&char(c)), s, back=last)(2,..), 0);
}

/* ------------------------------------------------------------------------ */

func is_scalar(x)
/* DOCUMENT is_scalar(object)
 *    returns 1 if OBJECT is a scalar, else 0.
 * SEE ALSO: is_array, is_func, is_void, is_range, is_struct, is_stream
 */
{ return is_array(x) && !dimsof(x)(1); }

func is_vector(x)
/* DOCUMENT is_vector(object)
 *    returns 1 if OBJECT is a vector (i.e., OBJECT has a single
 *    dimension), else 0.
 * SEE ALSO: is_array, is_func, is_void, is_range, is_struct, is_stream
 */
{ return is_array(x) && dimsof(x)(1)==1; }

/* ------------------------------------------------------------------------ */

func scalar(x, def, lt=, le=, gt=, ge=, type=, arg=, fn=)
/* DOCUMENT scalar -- get optional scalar parameter
 *
 * PROTOTYPE
 *   x = scalar(xarg, xdef, lt=, le=, gt=, ge=, type=, arg=, fn=);
 *
 * ARGUMENTS
 *   XARG    argument passed to the function.
 *   XDEF    default value for the scalar argument (optional, if not
 *           specified, then it is guessed that the caller must supply the
 *           argument).
 * KEYWORDS
 *   GE=     to be valid, XARG must be >= GE (optional, only one of GT or GE
 *           can be used).
 *   GT=     to be valid, XARG must be >  GT (optional, only one of GT or GE
 *           can be used).
 *   LE=     to be valid, XARG must be <= LE (optional, only one of LT or LE
 *           can be used).
 *   LT=     to be valid, XARG must be <  LT (optional, only one of LT or LE
 *           can be used).
 *   TYPE=   data type of the scalar (optional).
 *   FN=     function name for error messages (optional string).
 *   ARG=    argument name for error messages (optional string).
 *
 * DESCRIPTION
 *   Check XARG and return a scalar value (i.e., either XARG converted to TYPE
 *   if it is not void or XDEF otherwise).  If XARG is not within any specified
 *   bound or if it is not a scalar or if it is void (e.g., not specified) and
 *   there is no default value XDEF, an error message is written out.
 *
 * EXAMPLE
 *   The following function has 2 scalar arguments X and Y, the 1st one is an
 *   integer (of type long) which must be specified and be strictly greater
 *   than 22 while the 2nd default to .5 and must be in [0., 1.]:
 *     func foo(x,y) {
 *         x= scalar(x,     gt=22,        type=long,   fn="foo", arg="X");
 *         y= scalar(y, .5, ge=0., le=1., type=double, fn="foo", arg="Y");
 *         ...
 *     }
 *
 * WARNING
 *   There is no checking of consistency of options.
 *
 * HISTORY: 29 Sept. 1995 by Eric THIEBAUT.  (Modified slightly by DHM)
 */
{
  /* Efficiency note (DHM):
     This is pretty slow no matter what because of the long argument list.
     A faster implementation might be:
       check_range(default_value(x, def), lower, upper, flags)
     since you could optionally perform the various checks.  Of course,
     the total number of arguments for a complete test isn't any smaller,
     and there would be extra overhead in multiple function calls.
     Furthermore, it would be difficult to pass in the "user friendly"
     function and argument name options.  (The names of the routines in
     the current call chain would be a handy thing to make available by
     means of a Yorick builtin function call, as would the ability to
     have the error function "pop up" some number of levels so it left
     the person in dbug mode at the level of the caller of functions
     like this one...  That still leaves the argument name, though in
     principal Yorick can figure that out at runtime, too.)
   */

  /* get default x if necessary */
  if (is_void(x)) {
    if (is_void(def)) _scalar_err, 5;
    x= def;
  }

  /* check that x is indeed scalar */
  dims= dimsof(x);
  if (is_void(dims) || dims(1)) _scalar_err, 6;

  /* convert data type if required (note type could be function too) */
  if (!is_void(type)) x= type(x);

  /* check that x is in range */
  if (!is_void(lt) && x>=lt) _scalar_err, 1, lt;
  if (!is_void(le) && x>le) _scalar_err, 2, le;
  if (!is_void(gt) && x<=gt) _scalar_err, 3, gt;
  if (!is_void(ge) && x<ge) _scalar_err, 4, ge;

  return x;
}

func _scalar_err(oops, value)
{
  if (is_void(fn)) fn= "";
  else fn= fn+": ";
  if (is_void(arg)) arg= "argument";

  if (oops==5) {
    error, fn+"no default value for "+arg;
  } else if (oops==6) {
    error, fn+arg+" not a scalar value";
  } else {
    error, fn+arg+" must be "+["<","<=",">",">="](oops)+pr1(value);
  }
}

/* ------------------------------------------------------------------------ */
%FILE% string_2106.i
/*
 * $Id: string.i,v 1.1.1.1 2005/09/18 22:06:00 dhmunro Exp $
 * String and related convenience functions.
 * (Based on routines contributed by Eric Theibaut.)
 */

/*---------------------------------------------------------------------------
 * string.i: string manipulation and miscellaneous functions for Yorick
 *           by Eric THIEBAUT.
 *----------------------------------------------------------------------------
 * History:
 *      01/23/05 by David Munro, reworked for yorick-1.6
 *      02/11/95 by Eric THIEBAUT: added definitions of `scalar()' and
 *              `is_vector()'.
 */

/* ------------------------------------------------------------------------ */

func gettime(&time)
/* DOCUMENT gettime -- get current time in the form "HH:MM:SS"
 *
 * SYNOPSIS: time= gettime();
 *           gettime, time;
 *
 * HISTORY: October 30, 1995 by Eric THIEBAUT.
 *
 * SEE ALSO: getdate, parsedate, timestamp.
 */
{ return (time= strpart(timestamp(), 12:19)); }

func getdate(&date)
/* DOCUMENT getdate -- get date of the day in the form "DD/MM/YY"
 *
 * SYNOPSIS: date= getdate();
 *           getdate, date;
 *
 * HISTORY: October 30, 1995 by Eric THIEBAUT.
 *
 * SEE ALSO: gettime, parsedate, timestamp.
 */
{
  local day, month, year;
  parsedate, timestamp(), day, month, year;
  year-= (year>=2000)? 2000 : 1900; 
  return (date= swrite(format="%02d/%02d/%02d", day, month, year));
}

func parsedate(timestamp, &day, &month, &year, &hour, &minute, &second)
/* DOCUMENT parsedate -- get numerical version of a timestamp
 *
 * SYNOPSIS: parsedate, timestamp, day,month,year, hour,minute,second;
 *           parsedate(timestamp)
 *
 * HISTORY: October 30, 1995 by Eric THIEBAUT.
 *   DHM modified for yorick-1.6 23/Jan/05
 *
 * SEE ALSO: gettime, getdate, timestamp.
 */
{
  dayName= "";
  monthName= "";
  day= year= hour= minute= second= 0;
  sread, timestamp, format="%s%s%d%d:%d:%d%d", dayName, monthName,
    day, hour, minute, second, year;
  month= where(monthName == ["Jan", "Feb", "Mar", "Apr",
                             "May", "Jun", "Jul", "Aug",
                             "Sep", "Oct", "Nov", "Dec"]);
  month= numberof(month)? month(1) : 13;
  return [day, month, year, hour, minute, second];
}

/* ------------------------------------------------------------------------ */

func strtoupper(s)
/* DOCUMENT strtoupper -- convert a string to upper case letters
 *
 * SYNOPSIS: s2 = strtoupper(s)
 *
 * HISTORY: October 10, 1995 by Eric THIEBAUT.
 *   DHM modified for yorick-1.6 23/Jan/05
 *
 * ********** DEPRECATED **************
 *   new code should use strcase directly
 *
 * SEE ALSO: strtolower
 */
{
  return strcase(1, s);
}

func strtolower(s)
/* DOCUMENT strtolower -- convert a string to lower case letters
 *
 * SYNOPSIS: s2 = strtolower(s)
 *
 * HISTORY: October 10, 1995 by Eric THIEBAUT.
 *   DHM modified for yorick-1.6 23/Jan/05
 *
 * ********** DEPRECATED **************
 *   new code should use strcase directly
 *
 * SEE ALSO: strtoupper
 */
{
  return strcase(0, s);
}

/* DHM removed strtrim, now in i0/ystr.i */

func strchr(s, c, last=)
/* DOCUMENT strchr -- get first/last index of a character in a string 
 *
 * SYNOPSIS: i = strchr(s, c)
 *           i = strchr(s, c, last=1)
 *
 * DIAGNOSTIC: returns 0 if character C is not found in string S.
 *
 * HISTORY: October 27, 1995 by Eric THIEBAUT.
 *   DHM modified for yorick-1.6 23/Jan/05
 *
 * ********** DEPRECATED **************
 *   new code should use strfind directly
 *
 * SEE ALSO: strmatch
 */
{
  if (is_void(last)) last = 0;
  return max(strfind(string(&char(c)), s, back=last)(2,..), 0);
}

/* ------------------------------------------------------------------------ */

//func is_scalar(x)
/* DOCUMENT is_scalar(object)
 *    returns 1 if OBJECT is a scalar, else 0.
 * SEE ALSO: is_array, is_func, is_void, is_range, is_struct, is_stream
 */
//{ return is_array(x) && !dimsof(x)(1); }

//func is_vector(x)
/* DOCUMENT is_vector(object)
 *    returns 1 if OBJECT is a vector (i.e., OBJECT has a single
 *    dimension), else 0.
 * SEE ALSO: is_array, is_func, is_void, is_range, is_struct, is_stream
 */
//{ return is_array(x) && dimsof(x)(1)==1; }

/* ------------------------------------------------------------------------ */

func scalar(x, def, lt=, le=, gt=, ge=, type=, arg=, fn=)
/* DOCUMENT scalar -- get optional scalar parameter
 *
 * PROTOTYPE
 *   x = scalar(xarg, xdef, lt=, le=, gt=, ge=, type=, arg=, fn=);
 *
 * ARGUMENTS
 *   XARG    argument passed to the function.
 *   XDEF    default value for the scalar argument (optional, if not
 *           specified, then it is guessed that the caller must supply the
 *           argument).
 * KEYWORDS
 *   GE=     to be valid, XARG must be >= GE (optional, only one of GT or GE
 *           can be used).
 *   GT=     to be valid, XARG must be >  GT (optional, only one of GT or GE
 *           can be used).
 *   LE=     to be valid, XARG must be <= LE (optional, only one of LT or LE
 *           can be used).
 *   LT=     to be valid, XARG must be <  LT (optional, only one of LT or LE
 *           can be used).
 *   TYPE=   data type of the scalar (optional).
 *   FN=     function name for error messages (optional string).
 *   ARG=    argument name for error messages (optional string).
 *
 * DESCRIPTION
 *   Check XARG and return a scalar value (i.e., either XARG converted to TYPE
 *   if it is not void or XDEF otherwise).  If XARG is not within any specified
 *   bound or if it is not a scalar or if it is void (e.g., not specified) and
 *   there is no default value XDEF, an error message is written out.
 *
 * EXAMPLE
 *   The following function has 2 scalar arguments X and Y, the 1st one is an
 *   integer (of type long) which must be specified and be strictly greater
 *   than 22 while the 2nd default to .5 and must be in [0., 1.]:
 *     func foo(x,y) {
 *         x= scalar(x,     gt=22,        type=long,   fn="foo", arg="X");
 *         y= scalar(y, .5, ge=0., le=1., type=double, fn="foo", arg="Y");
 *         ...
 *     }
 *
 * WARNING
 *   There is no checking of consistency of options.
 *
 * HISTORY: 29 Sept. 1995 by Eric THIEBAUT.  (Modified slightly by DHM)
 */
{
  /* Efficiency note (DHM):
     This is pretty slow no matter what because of the long argument list.
     A faster implementation might be:
       check_range(default_value(x, def), lower, upper, flags)
     since you could optionally perform the various checks.  Of course,
     the total number of arguments for a complete test isn't any smaller,
     and there would be extra overhead in multiple function calls.
     Furthermore, it would be difficult to pass in the "user friendly"
     function and argument name options.  (The names of the routines in
     the current call chain would be a handy thing to make available by
     means of a Yorick builtin function call, as would the ability to
     have the error function "pop up" some number of levels so it left
     the person in dbug mode at the level of the caller of functions
     like this one...  That still leaves the argument name, though in
     principal Yorick can figure that out at runtime, too.)
   */

  /* get default x if necessary */
  if (is_void(x)) {
    if (is_void(def)) _scalar_err, 5;
    x= def;
  }

  /* check that x is indeed scalar */
  dims= dimsof(x);
  if (is_void(dims) || dims(1)) _scalar_err, 6;

  /* convert data type if required (note type could be function too) */
  if (!is_void(type)) x= type(x);

  /* check that x is in range */
  if (!is_void(lt) && x>=lt) _scalar_err, 1, lt;
  if (!is_void(le) && x>le) _scalar_err, 2, le;
  if (!is_void(gt) && x<=gt) _scalar_err, 3, gt;
  if (!is_void(ge) && x<ge) _scalar_err, 4, ge;

  return x;
}

func _scalar_err(oops, value)
{
  if (is_void(fn)) fn= "";
  else fn= fn+": ";
  if (is_void(arg)) arg= "argument";

  if (oops==5) {
    error, fn+"no default value for "+arg;
  } else if (oops==6) {
    error, fn+arg+" not a scalar value";
  } else {
    error, fn+arg+" must be "+["<","<=",">",">="](oops)+pr1(value);
  }
}

/* ------------------------------------------------------------------------ */
%FILE% sunposition.i
func sunposition( IJD_or_dattim )
/* DOCUMENT v = sunposition( IJD_or_dattim )
    where v(1) returns RA(Sun) and v(2) returns Dec(Sun)
    in degrees.

    Approximate Solar Coordinates from Naval Oceanography Portal
    http://www.usno.navy.mil/USNO/astronomical-applications/astr...

    The accuracy is reported to better than a couple of arcminutes.

    Translated to Yorick: 2009-10-20/NJW

*/
{
   if( typeof(IJD_or_dattim) == "string" ) {
      ijd = dattim2ijd(IJD_or_dattim);
   } else {
      ijd = IJD_or_dattim;
   }

   dr = pi/180;
   D = ijd - 0.5;

   g = 357.529 + 0.98560028*D;
   g_rad = zero2pi(g*dr);
   q = 280.459 + 0.98564736*D;
   q_rad = zero2pi(q*dr);
   L = q_rad/dr + 1.915*sin(g_rad) + 0.020*sin(2*g_rad);

   R = 1.00014 - 0.01671*cos(g_rad) - 0.00014*cos(2*g_rad);

   e = 23.439 - 0.00000036*D;

   RA = zero2pi(atan(cos(e*dr)*sin(L*dr),cos(L*dr)))/dr;
   d = asin(sin(e*dr)*sin(L*dr))/dr;

   return [RA, d];

}
%FILE% swid_timeline.i
/* Function swid_timeline */

func swid_timeline( swidlist, &xb, title=, color=, ntbins=, nz= )
/* DOCUMENT swid_timeline, swidlist, >xb, title=, color=, ntbins=, nz=
    swidindex = swid_timeline( swidlist, >xb, title=, color=, ntbins=, nz= )

    Makes a plot of the time distribution of the SWIDs

    Keyword  ntbins    Number of time bins (defaults to 100)
             nz        Number of consecutive zeros to define a break
                                           (defaults to 2)

    The returned argument 'xb' array (2 x number_of_chunks) contains IJDs
    for start and stop times of the suggested chunks.

    The returned array 'swidindex' gives the indices for the chunks:

       list_chunk_n = swidlist(where(swidindex == n));
    
*/
{
  /*
   *  Make a histogram of the number of seconds (to be precize: the number
   *  of 100s) in a 100th of the interval from first to last observation
   */

   local tstart, tstop;
   local x1, x2;

   if( is_void(ntbins) ) ntbins = 100;
   if( is_void(nz) ) nz = 2;

   // count and sort

   nswids = numberof(swidlist);
   swidlist = swidlist(sort(swidlist));

   // prepare chunk index array

   swidindex = array(long, nswids);

   tswids = dtswids = array(double,nswids);
   mtswids = [];
   for( i = 1; i <= nswids; i++ ) {
      get_time_for_swid, swidlist(i), tstart, tstop;
      tswids(i) = 0.5*(tstart+tstop);
      dtswids(i) = tstop-tstart;
      // 0.001 days = 86.4 s
      n = long((tstop-tstart)/0.001) + 1;
      grow, mtswids, span(tstart,tstop,n+1)(zcen);
   }
   tot_time = sum(dtswids);
   write,format="Total time in SWIDs : %10.4f days\n", tot_time;
   tspan = tswids(0) - tswids(1)+ dtswids(0)/2 + dtswids(1)/2; // in IJD (days)
   xtspan = 1.1*tspan;
   histos,mtswids,h,x,bmin=tswids(1)-dtswids(1)/2-0.05*tspan, \
                      bmax=tswids(0)+dtswids(0)/2+0.05*tspan,binsize=xtspan/ntbins;
   hour_plot = 0;
   if( xtspan > 1000 ) { // don't subtract a number of 1000s
      // a = 1000*long(x(1)/1000.);
      a = 0;
   } else if( xtspan > 100 ) { // subtract a number of 100s
      a = 100*long(x(1)/100.);
   } else if( xtspan > 10 ) { // subtract a number of 10s
      a = 10*long(x(1)/10.);
   } else if( xtspan > 1 ) { // subtract a number of 1s
      a = long(x(1));
   } else { // timespan is less than a day, convert to hours
      a = long(x(1));
      xh = (x - a)*24.;
      plot,xh,h,ps=10,title=title,xtitle="Hours from IJD "+itoa(a);
      plhisc,h,xh,color=color;
      hour_plot = 1;
   }
   if( !hour_plot ) {
      if( a == 0 ) { // do nothing
         plot,x,h,ps=10,title=title, xtitle="IJD";
      } else {
         plot,x-a,h,ps=10,title=title, xtitle="IJD - "+itoa(a);
      }
      plhisc,h,x-a,color=color;
   }

  /*
   *    Suggest limits for time breaks
   */

   nh = numberof(h);
   hl = h > 1.e-10;
   get_boundaries, x, x1, x2;
   //+ plot,x,hl*1.3,ps=10,yr=[0,2];
   //+ plhisc,hl*1.3,x,color="red";

   // locate and remove leading and trailing zeros in 'hl'

   i = 1; while(hl(i) == 0) i++;
   j = nh; while(hl(j) == 0) j--;

   hll = hl(i:j);
   x1 = x1(i:j);
   x2 = x2(i:j);
   xx = x(i:j);
   nhl = numberof(hll);

   // replace series of consecutive zeros with one when their number
   // is smaller than 'nz'

   for( nzeros = 1; nzeros < nz; nzeros++ ) {

      // locate and update patterns "1,nzeros,1" to "1,1,..,1"

      for( i = 1; i < nhl-nzeros; i++ ) {
         patt = array(0,nzeros+2);
         patt(1) = patt(0) = 1;
         if(noneof(hll(i:i+1+nzeros)-patt)) hll(i:i+1+nzeros) = 1;
      }

   }
   //+ plhisc,hll*0.7,xx,color="blue";

   u = uniq(hll);
   grow,u,nhl+1;
   nu = numberof(u);

   //+ write,"nu = ", nu;
   nchunks = nu/2;
   xb = array(double,2,nchunks);

   // The chunks are the odd numbers of 'u'

   xb(1,) = x1(u(1:0:2));
   xb(2,) = x2(u(2:0:2)-1);

   for( i = 1; i <= nchunks; i++ ) {
      w = where( tswids > xb(1,i) & tswids < xb(2,i) );
      swidindex(w) = i;
   }

   for( i = 1; i <= nchunks; i++ ) {
      xxx1 = [xb(1,i),xb(1,i)] - a;
      xxx2 = [xb(2,i),xb(2,i)] - a;
      if( hour_plot ) {
         xxx1 = ([xb(1,i),xb(1,i)] - a) * 24.;
         xxx2 = ([xb(2,i),xb(2,i)] - a) * 24.;
      }
      oplot,xxx1,[0,3000],color="green",thick=2;
      oplot,xxx2,[0,3000],color="magenta",thick=2;
   }

   return swidindex;
   
}
%FILE% t2.i
func t2(n)
{
   s = 0;
   for(i = 0; i < n; i++ ) s += 2^i;
   write,format="%i %i\n", n, s;
}
%FILE% tempus.i
extern tempusdoc;
/* DOCUMENT **************************************
 *
 *     Light curve functions: Analysis and simulation
 *     Niels J. Westergaard
 *
 *   Contains:
 *                      define_lc
 *                      easy_fft
 *                      lcbinning
 *   2003-03-30
 *   2008-08-18/NJW, removed lcbinninga
 *
 ************************************************/

/* Function define_lc */

func define_lc(step, n, nf)
/* DOCUMENT  lc = define_lc( step, n, nf)
   Define a testlight curve for fft analysis
*/

{
   nyquist = 1./(2*step);
   f = indgen(nf)*nyquist/n;
   t = indgen(n)*step;
   lc = array(double,n);
   for(i=1;i<=nf;++i) {
      lc += cos(2*pi*f(i)*t);
      plot,lc
      pause,1000;
   }
   return lc;
}

/* Function easy_fft */

func easy_fft( lc, step )
/* DOCUMENT easy_fft, lc, step
   Plot fft result (PSD) for the given lightcurve with
   timestep 'step'
   2003-03-06/NJW
*/
{
   n = numberof(lc);
   nyquist = 1./(2*step);
   write,"Nyquist frequency = ", nyquist
   psd = (abs(fft(lc-avg(lc),1))(1:(n+1)/2))/n;
   f = double((indgen((n+1)/2)-1))/(n*step);
   plot,psd,f,ps=10;
}

/* Function psd */

func psd( lc, step, &freq )
/* DOCUMENT res = psd( lc, step, >freq )

      Returns the PSD as fft(lc)*conjugated(fft(lc))

      for positive frequencies (returned in 'freq' arg).

      The normalization may not be correct.
*/
{
   n = numberof(lc);
   nyquist = 1./(2*step);
   transf = fft(lc-avg(lc),1)(1:(n+1)/2);
   res = double(transf * conj(transf))/n;
   freq = double((indgen((n+1)/2)-1))/(n*step);

   return res;
}


/* Function lcbinning */

func lcbinning( timval_in, rate_in, err_in, step_in, &tc, &lc, &errc, \
     tunit=, stepunit=, mode= )
/* DOCUMENT lcbinning, timval, rate, err, step, tc, lc, errc,
		       tunit=, stepunit=, mode=

  2003-03-03/NJW
  2006-10-04/NJW Updated with first/last bin correction

  Binning or rebinning of event or light-curve data

  "timval" is event or bin time values. The unit
           can be given in keyword "tunit" as (string) IJD (default) or s
  "rate"   if 'rate' has same dimension as 'timval' then it is assumed to be
           a light curve.
           If 'rate' is a scalar or void then event data are assumed to exist in 'timval'
  "err"    If a light-curve is given in 'rate' then 'err' is the error (must have
           same dimension as 'rate').
           Else it should be given as an arbitrary scalar, or void.
  "step"   The desired time step for the resulting light-curve. The unit can be given
           in keyword "stepunit" as (string) "day" or "s" (default)
  "tc"     (Return) time values of bin centers. Same unit as "timval"
  "lc"     (Return) is the resulting light-curve
  "errc"   (Return) is the resulting error of the light-curve
 Keywords:
  "tunit"  Unit of input times "s" or "ijd" (default)
  "stepunit"  Unit of step "s" (default) or "ijd"
  "mode"   Mode for( output values "/s" (default) or "cts"

  Example when event arrival time list ('tk') is given in seconds and a light-curve with
  0.1 s bins is requested:

      > lcbinning,tk,1.,1.,0.1,tc,lc,errc,tunit="s",mode="cts"

*/
{

   //+ require, "newstring.i";

//   Get the mode

   if( is_void(mode) ) mode = "/s";

//   Get the time units

   orig_tunit = "ijd";
   if( numberof(tunit) ) {
      orig_tunit = "";
      //+ str = strtolower(tunit);
      str = strlowcase(tunit);
      if( strpart(str,1:1)  ==  "s" ) {
         orig_tunit = "s";
         write,"Convert time values to days";
         timval = double(timval_in) / 86400.0;
      }
      if( str  ==  "ijd" ) {
         orig_tunit = "ijd";
         write,"No time value conversion";
         timval = double(timval_in);
      }
      if( orig_tunit  ==  "" ) {
         write,"Illegal keyword tunit";
         return;
      }
   } else timval = double(timval_in);
   
   orig_stepunit = "s";
   if( numberof(stepunit) ) {
      orig_stepunit = "";
      str = strtolower(stepunit);
      if( str  ==  "ijd" ) {
         orig_stepunit = "ijd";
         write,"No step unit conversion";
         stepw = double(step_in);
      }
      if( strpart(str,1:1)  ==  "s" ) {
         orig_stepunit = "s";
         write,"Convert step time unit to days";
         stepw = double(step_in) / 86400.0;
      }
      if( orig_stepunit  ==  "" ) {
         write,"Illegal keyword stepunit";
         return;
      }
   } else {
      write,"Convert step time unit to days";
      stepw = double(step_in) / 86400.0; // default conversion
   }

//   Event list or light curve input ?

   is_lc = 1;
   if( numberof(rate_in)  ==  1 ) {
      is_lc = 0;
   } else {
      ratew = rate_in;
      errw = err_in;
   }

//   Determine original binsize

   nvals_orig = numberof(timval);
   
   if( is_lc ) {
      //+ dt = delta(timval);
      dt = timval(dif);
      dtmax = max(dt);
      dtmin = min(dt);
      if( dtmax  ==  dtmin ) {
         orig_binsize = dt(1);
      } else {
         av = avg(dt);
         rs = wrms(dt);
         sel = where( abs(dt - av)  <  0.5*rs );
         n_sel = numberof(sel);
         av = avg(dt(sel));
         rs = wrms(dt(sel));
         orig_binsize = av;
      }

//   Find rate correction factor

      rate_factor = orig_binsize / stepw;
   } else {
      ratew = array(1.0, nvals_orig);
      errw  = array(1.0, nvals_orig);
   }
   //
   //   Remove time values where the rate is zero
   //
   w = where( ratew  !=  0.0 );
   n_w = numberof(w);
   if( n_w  >  0 && n_w  <  nvals_orig ) {
      timval = timval(w);
      ratew = ratew(w);
      errw = errw(w);
      write,format="Rejected %i input bins where rate==0\n", nvals_orig-n_w;
   }
   if( n_w  ==  0 ) {
      write,"No non-zero rate values - terminate!";
      return;
   }

//   Setup array to hold the resulting light curve

   t1 = min(timval);
   t2 = max(timval);
   nvals = numberof(timval);
   nsteps = long((t2 - t1)/stepw) + 1;
   delta = 0.5*(nsteps*stepw - (t2 - t1));
   lc = array(float, nsteps);
   errc = array( float, nsteps); // to hold the error
   tcmin = t1 - delta;
   tcmax = t2 + delta;
   tc = span( tcmin+0.5*stepw, tcmax-0.5*stepw, nsteps );
   bin = long((timval - tcmin)/stepw) + 1;
   for( i = 1; i <= nvals; i++ ) {
      b = bin(i);
      if( b  <=  nsteps ) {
         lc(b) = lc(b)+ratew(i);
         errc(b) = errc(b) + errw(i)^2;
      } else write,format="Warning: b = %i\n", b;
   }

// Correction to first and last bin

   fraction = (tcmin + stepw - t1)/stepw;
   lc(1) = lc(1) / fraction;
   errc(1) = errc(1) / fraction;
   fraction = (t2 - tcmax + stepw)/stepw;
   lc(0) = lc(0) / fraction;
   errc(0) = errc(0) / fraction;

//  Convert to counts per second

   if( mode  ==  "/s" ) {
      if( is_lc ) {
         lc *= rate_factor;
         errc = sqrt(errc) * rate_factor;
      } else {
         lc /= (stepw * 86400.0);
         errc = sqrt(errc) / (stepw * 86400.0);
      }
   }

//   Convert to "seconds" if that was the input unit

   if( orig_tunit  ==  "s" ) {
      timval = timval * 86400.0;
      tc = tc * 86400.0;
      stepw = stepw * 86400.0;
   }
   
}
%FILE% test.i
Types = ["distance","flux","luminosity","temperature"];
udistance = _lst("cm","pc","kpc","Mpc");
uflux = _lst("erg/cm2s");
uluminosity = _lst("erg/s");
utemperature = _lst("K","MK","keV");

utypes = _lst( udistance, uflux, uluminosity, utemperature );
%FILE% test_ait.i
func test_ait( a )
{

   local ix, iy;

   // map
   map = array(double,360,180);
   for(glon = 0.; glon < 360.; glon += 30. ) {
      for(glat = -80.; glat <= 80.; glat+=0.1 ) {
         conv, glon, glat, ix, iy;
         map(ix,iy) = 1.0;
      }
   }
   for(glat = -80.; glat <= 80.; glat+=20.0 ) {
      for(glon = 0.; glon < 360.; glon += .1 ) {
         conv, glon, glat, ix, iy;
         map(ix,iy) = 1.0;
      }
   }

   N = 180;
   Nh = N/2;
   ait_map = array(double,2*N,N);
   delt = 180.0/N;
   substep = 0.2*delt;
   substeph = substep/2;

   for( i = 1; i <= 2*N; i++ ) {
      x1 = (i - N - 1) * delt;
      x2 = (i - N    ) * delt;
      for( j = 1; j <= N; j++ ) {
         y1 = (j - Nh - 1) * delt;
         y2 = (j - Nh    ) * delt;

         nvals = 0;
         valsum = 0.0;
         for(eps=substeph; eps < delt; eps += substep ) {
            for(eta=substeph; eta < delt; eta += substep ) {
               x = x1 + eps;
               y = y1 + eta;
               coords = rever_aitoff(x,y);
               if( is_void(coords) ) continue;
               conv, coords(1), coords(2), ii, jj;
               nvals++;
               valsum += map(ii,jj);
            }
         }
         if(nvals) ait_map(i,j) = valsum/nvals;
      }
   }


   kwds_init;
   kwds_set,"date",ndate(3),"Date of creation";
   kwds_set,"ctype1","RA---AIT","Hammer-Aitoff projection";
   kwds_set,"ctype2","DEC--AIT","Hammer-Aitoff projection";
   kwds_set,"crpix1", 180.5,"reference pixel";
   kwds_set,"crpix2",  90.5,"reference pixel";
   kwds_set,"crval1",   0.0,"reference pixel value";
   kwds_set,"crval2",   0.0,"reference pixel value";
   kwds_set,"cdelt1",  -0.9,"degrees/pixel";
   kwds_set,"cdelt2",   0.9,"degrees/pixel";

   writefits,"b.fits",ait_map,clobber=1;

   write,"Job is done";

}
%FILE% test_amoeba.i
#include Y_CODE+"datafit.i"

func fff(parm)
{
   extern xmeas, ymeas;
   return sum((parm(1)*xmeas + parm(2) - ymeas)^2);
}



/* Testing the 'amoeba' function

   Fitting a straight line parm(1)*x + parm(2)

*/

ymeas = [1.,1.5,1.3,1.8,2.3,2.0,2.3];
xmeas = 1.0*indgen(7);

p = array(double,3,2);

best_guess = [0.15, 1.0];
p(1,) = best_guess;
p(2,) = best_guess + [0.02, 0];
p(3,) = best_guess + [0, 0.1];

y = array(double,3);
for(i=1;i<=3;i++) y(i) = fff(p(i,));

p_res = amoeba( fff, p, y, 1.e-4, iter);
write,format="Number of iterations : %i\n", iter;

window,0;
plot, xmeas, ymeas, ps=2, symsize=2;
yfit = p_res(1)*xmeas + p_res(2);
oplot,xmeas,yfit;
%FILE% test_ijddat.i
r = 500. + 4500.*random(5000);
//+ dev = array(double,2000);
//+ for( i = 1; i <= 2000; i++ ) {
//+    d = ijd2dattim(r(i));
//+    t = dattim2ijd(d);
//+    dev(i) = r(i) - t;
//+ }
r = r(sort(r));
d = ijd2dattim(r);
t = dattim2ijd(d);
dev = r - t;
%FILE% textbox.i
/* Function textbox */

func textbox( x, y, str, &boxdevice, &boxworld, \
                     align=, notext=, nobox=, device=, height= )
/* DOCUMENT textbox, x, y, str, >boxdevice, >boxworld,
                    align=, notext=, nobox=, device=, height=

  Print out a text string "str" just as "xyouts". This procedure
  also returns a box [x1,y1,x2,y2] in normalized device coordinates around
  the text string

  The keyword "notext" inhibits the output of text to window
  but only sets the circumscribing box

  With keyword "device" set (x,y) must be in normalized device coordinates
  else in data coordinates

   991129/NJW
   2009-08-10/NJW translated to Yorick
*/
{

   local p, q;

   chsiz = 1.
   chsiz = is_void(charsize) ? 1. : charsize;
   align = is_void(align) ? 0.0 : align;
   dev = is_void(device) ? 0 : 1;
   height = is_void(height) ? 14 : height;
   notext = !is_void(notext);
   nobox = !is_void(nobox);

   if( height < 9 ) {
      height = 8; block = 1;
   } else if( height < 11 ) {
      height = 10; block = 2;
   } else if( height < 13 ) {
      height = 12; block = 3;
   } else if( height < 15 ) {
      height = 14; block = 4;
   } else {
      height = 16; block = 5;
   }

   if( align < 0.25 ) {
      just = "LA";
      align = 0.0;
   } else if( align < 0.75 ) {
      just = "CA";
      align = 0.5;
   } else {
      just = "RA";
      align = 1.0;
   }

   // Write string to window

   if( !notext ) {
      plt,str,x,y,height=height,justify=just,tosys=(1-dev);
   }

   // get string length in normalized device coordinates

   dfile = "/home/njw/yorick/char_sizes.scm";
   rstab,dfile,2,carr,lsiz,typ="cf",block=block,silent=1;
   wdevice = 0.0;
   cstr = *pointer(str);
   slen = strlen(str);
   for(i=1;i<=slen;i++) {
      w = where(cstr(i) == carr);
      if(numberof(w)>0) wdevice += lsiz(w(1));
   }

   // get the character size in y direction:

   h_charsize = height * 0.0013;

   // start of string position in device coordinates:

   if( dev ) {
      xstartdevice = x - align*wdevice;
      ystartdevice = y;
   } else {
      mcoord_conv, x, y, p, q, from="wor",to="ndc";
      xstartdevice = p - align*wdevice;
      ystartdevice = q;
   }
   ystartdevice -= 0.2*h_charsize;

   mcoord_conv, xstartdevice, ystartdevice, xstartworld, ystartworld, \
              from="ndc",to="wor";

   // end of string position in device coordinates:

   xenddevice = xstartdevice + wdevice;
   yenddevice = ystartdevice + h_charsize;
   mcoord_conv, xenddevice, yenddevice, xendworld, yendworld, \
              from="ndc",to="wor";

   boxdevice = [xstartdevice, ystartdevice, xenddevice, yenddevice];
   boxworld = [xstartworld, ystartworld, xendworld, yendworld];

   if( !nobox ) drawbox,boxworld;
}

func drawbox( box, device= )
/* DOCUMENT drawbox, box, device

    assumes box : [x1,y1,x2,y2]
*/
{
   local x1,y2, x2,y2;

   if( device ) {
      mcoord_conv, box(1),box(2), x1, y1, from="ndc", to="wor";
      mcoord_conv, box(3),box(4), x2, y2, from="ndc", to="wor";
   } else {
      x1 = box(1); y1 = box(2);
      x2 = box(3); y2 = box(4);
   }
   oplot,[x1,x2,x2,x1,x1], \
         [y1,y1,y2,y2,y1];
}
%FILE% tgf2.i
c0 = [3.5,4.1,6.3,0.9,2.0];
x = random(1000)*10.0;
y = random(1000)*10.0;
a = ((x-c0(2))/c0(4))^2 + ((y-c0(3))/c0(4))^2;
z = c0(1) * exp(-0.5*a) + c0(5) + random_n(1000)*0.1;
i1 = y > c0(3)-0.5;
i2 = y < c0(3)+0.5;
w = where( i1+i2 == 2 );
plot,x(w),z(w),ps=2;
c = gaussfit2ds_uam( x, y, z, nterm=5, chat=3);
write,format="%8.3f ", c;
write,format="%s\n","";
c1 = c0 / 2;
c2 = c0 * 2;
c3 = iniparest2d_u( x, y, z, c1, c2, 100);
d = gaussfit2d_uam( x, y, z, nterm=5, chat=3, esti=c3);
write,format="%8.3f ", d;
write,format="%s\n","";
%FILE% tpoi.i
func tpoi( lambda )
/* DOCUMENT res = tpoi( lambda )

   2006-06-21/NJW
  
               Testing Poisson distribution
  
*/
{
   require, "plot.i";
   require, "image.i";
   require, "idlx.i";
   require, "random.i";
   require, "scom.i";
   require, "string.i";
   require, "fits.i";
   require, "mfits.i";

   summa = 0.0;
   for(i=1;i<=10000;i++) summa += (poisson(lambda)-lambda)^2;
   return summa/10000.0;

}
%FILE% tredje.i
for( i = 1; i <= 100; i++ ) {
for( j = 1; j <= i; j++ ) {
   s = i^3 + j^3;
   rod = s^0.3333333333333333;
   for( k = 1; k <= rod; k++ ) {
      rest = s - k^3;
      rrod = rest^0.33333333333333333;
      irrod = long(rrod+0.5);
      if( abs(rrod-irrod) < 1.e-8 ) {
         if( k != i && k != j ) {
            write,i,j,k,irrod;
         }
      }
   }
}}
%FILE% tt.i
func tt(a)
{
   extern Scatter_file;

   if( is_void(Scatter_file) ) {
      write,"Scatter_file is void";
      return;
   }
   write,format="Scatter_file : %s\n", Scatter_file;
}
%FILE% tune.i
dr = pi / 180;
//+ ra_NGP = 192.8604; // old value

ra_CGAL = 266.4051 * dr; // J2000
dec_CGAL = -28.936175 * dr; // J2000
ex = [cos(ra_CGAL)*cos(dec_CGAL), \
      sin(ra_CGAL)*cos(dec_CGAL), sin(dec_CGAL)];
//+ ex = [-0.05487394293840,-0.87343697152730,-0.48383541329218];

step = 3.e-7;
n=15;
n2 = n/2;
res = array(double,n,n);
xax = yax = array(double,n);
for( ir = 1; ir <= n; ir++ ) {
for( id = 1; id <= n; id++ ) {
   reps = step*(ir-1-n2)+8.e-5;
   deps = step*(id-1-n2)-8.3145e-5;
   xax(ir) = reps*1.e6;
   yax(id) = deps*1.e6;
   ra_NGP = (192.859508+reps) * dr; // J2000
   dec_NGP = (27.128336+deps) * dr; // J2000
   ez = [cos(ra_NGP)*cos(dec_NGP), \
         sin(ra_NGP)*cos(dec_NGP), sin(dec_NGP)];
   //+ ez = [-0.86766645981482, -0.19809110265025,0.45597678621091];
   ey = crossprod( ez, ex );
   //+ write,format=" %14.6e %14.6e %16.8e %16.8e\n", \
   //+    reps, deps, sum(ex*ez), sum(ey^2)-1;
   res(ir,id) = sum(ex*ez);
}}
%FILE% uku.i
#include Y_CODE+"button_pack.i"

/**********************************************************************

   A package to solve a sudoku problem of a 9x9 square array subdivided
   into 9 subarrays. The array elements are the numbers from 1 thru 9
   arranged such that
   1) each row and column contains all the numbers 1 thru 9
   2) each 3x3 subarray contains all the numbers 1 thru 9

   A particular problem is presented by the array being partly filled and
   the task is then to fill out the remaining elements.

   Procedure:

   > cd,"c:/yo"
   > #include "uku.i"
   > uku_init

       Sets up a plot of 9x9 little squares representing the Sudoku array.
       Above the array a list of the numbers 1 thru 9 is shown.

   > uku_setup

       Here the given numbers are inserted by using the mouse to pick a number
       in the row above and then click on the little square where it is to be
       inserted. The sequence 'pick a number' & 'select target square' must be
       repeated for each predefined number. Termination is indicated by clicking
       in a spot on the plot with no squares.

   > uku_view

       Displays all the possible choices for each element. Unambiguous elements are
       reported as well as impossible situations.

   > uku_refresh

       Refreshes the plot with large, fat numbers for unambiguous elements.

   > uku_choice

       When uku_view reports neither unambiguous elements nor a conflict then a
       choice must be made in a manner similar to the 'init' process: A number is
       picked in the horizontal bar with numbers and placed in the selection square.

   > uku_goback

       When uku_view reports a conflict then one of the previous choices were bad.
       uku_goback puts be previous 'b' array up front and makes a new choice
       possible.

   > uku_run

       Once initialization including setup has been done issue the 'uku_run'
       command. Then the Sudoku will be solved.


   Externals:
     'b' holds the 9x9 array in the first two dimensions and the third dimension
             gives the
             b(i,j,1) is the number corresponding to array position (i,j).
             If it is 0 (zero) then its value has not yet been determined
             and then b(i,j,k), k = 2,..., hold the possible values until
             b(i,j,k) == -1
             At initialization b(i,j,1:11) = [0,1,2,3,4,5,6,7,8,9,-1]
             When the value in array position (i,j) has been determined
             b(i,j,1) acquires this value and b(i,j,2) == -1

      'nodes' holds the choices leading to a certain instance
             nodes(1,instance) = i value
             nodes(2,instance) = j value
             nodes(3,instance) = pointer to chosen value, initiated to 5
             nodes(4,instance) = max pointer value
             nodes(5,instance) = first possible value
             nodes(6,instance) = next possible value
                  ...
             nodes(14,instance) = next possible value

             value = nodes(nodes(3,instance)++,instance)

   2005-07-12/NJW

***********************************************************************/
func uku_init(a)
{

   extern button_arr;
   extern b;
   extern ibut;
   extern jbut;
   extern itab;
   extern jtab;
   extern ptab;
   extern bs;
   extern instance;
   extern nodes;

   button_arr = [];

   // the 'b' array holds all number distribution

   b = array(int,9,9,11);
   for(i=1;i<=9;i++){
      for(j=1;j<=9;j++){
         b(i,j,1) = 0;
         b(i,j,11) = -1;
         for(k=2;k<=10;k++) b(i,j,k) = k-1;
      }
   }

   // The 'bs' array holds instances of 'b'

   bs = array(int,9,9,11,20);
   nodes = array(int,14,20);
   instance = 0;

   //  auxiliary arrays: itab, jtab, ptab

   itab = array(long,9,9);
   c = [[1,4,7],[2,5,8],[3,6,9]];
   for(h = 1; h<=7; h+=3 ) {
   for(k = 1; k<=7; k+=3 ) {
      itab(h:h+2,k:k+2) = c;
   }}
   jtab = array(long,9,9);
   c = [[0,0,0],[0,0,0],[0,0,0]];
   g = 1;
   for(h = 1; h<=7; h+=3 ) {
   for(k = 1; k<=7; k+=3 ) {
      jtab(h:h+2,k:k+2) = c + (g++);
   }}
   ptab = array(long,9,9);
   c = [[0,0,0],[0,0,0],[0,0,0]];
   g = 1;
   for(k = 1; k<=7; k+=3 ) {
   for(h = 1; h<=7; h+=3 ) {
      ptab(h:h+2,k:k+2) = c + (g++);
   }}


   window,0,style="nobox.gs";

   plot,[0,1,1,0,0],1.2*[0,0,1,1,0];
   d = span(0.05,0.95,10);
   oplot,[d(4),d(4)],[d(1),d(10)],thick=5;
   oplot,[d(7),d(7)],[d(1),d(10)],thick=5;
   oplot,[d(1),d(10)],[d(4),d(4)],thick=5;
   oplot,[d(1),d(10)],[d(7),d(7)],thick=5;
   ibut = array(long,81);
   jbut = array(long,81);
   for(ia = 1; ia<=9; ia++ ) {
   for(ja = 1; ja<=9; ja++ ) {
      id = button_init([d(ia),d(ja),d(ia+1),d(ja+1)],"",charsize=1.5);
      ibut(id) = ia;
      jbut(id) = ja;
   }
   }
   for(ia = 1; ia<=9; ia++ ) {
      id = button_init([d(ia),1.05,d(ia+1),1.15],itoa(ia),charsize=1.5);
   }
}




func uku_setup(a)
{
   extern b;
   extern ibut;
   extern jbut;

   d = span(0.05,0.95,10);

   while( 1 ) {
      // Select the number
      id = button_query();
      if( id < 82 || id > 90 ) break;
      number = id - 81;
      // Find where to place it
      id = button_query();
      while( id < 1 || id > 81 ) {
         write(format="%s\n","Sorry, wrong button, try again ...");
         id = button_query();
      }
      b(ibut(id),jbut(id),1) = number;
      b(ibut(id),jbut(id),2) = -1;
      xyouts,0.5*(d(ibut(id))+d(ibut(id)+1)),d(jbut(id))+0.2*(d(jbut(id)+1)-d(jbut(id))), \
          itoa(number),charsize=1.5,align=0.5;
   }
}

func uku_refresh(a)
{
   extern b;

   plot,[0,1,1,0,0],1.2*[0,0,1,1,0];
   d = span(0.05,0.95,10);
   oplot,[d(4),d(4)],[d(1),d(10)],thick=5;
   oplot,[d(7),d(7)],[d(1),d(10)],thick=5;
   oplot,[d(1),d(10)],[d(4),d(4)],thick=5;
   oplot,[d(1),d(10)],[d(7),d(7)],thick=5;
   for( i = 1; i <= 10; i++ ) {
      oplot,d(1:10:9),d(i)*[1,1];
   }
   for( i = 1; i <= 10; i++ ) {
      oplot,d(i)*[1,1],d(1:10:9);
   }
   for( i = 1; i <= 10; i++ ) {
      oplot,d(i)*[1,1],[1.05,1.15];
      if( i < 10 ) xyouts,0.5*(d(i)+d(i+1)),1.07,itoa(i),charsize=1.5,align=0.5;
   }
   for( i = 1; i <= 9; i++ ) {
   for( j = 1; j <= 9; j++ ) {
      if( b(i,j,2) == -1 ) {
         xyouts,0.5*(d(i)+d(i+1)),d(j)+0.2*(d(j+1)-d(j)),itoa(b(i,j,1)), \
                   charsize=1.5,align=0.5;
      }
   }}
   oplot,d(1:10:9),[1.05,1.05];
   oplot,d(1:10:9),[1.15,1.15];

}

func uku_view(a)
{
   extern b;
   extern itab;
   extern jtab;
   extern ptab;
   extern instance;

   d = span(0.05,0.95,10);
   try_again = 1;
   try_again = 1;
   res = array(int,13);

   while ( try_again ) {

      try_again = 0;

      for( i = 1; i <=9; i++ ) {
      for( j = 1; j <=9; j++ ) {
         if( b(i,j,1) == 0 ) {
            k = 2;
            txp = -0.01667;
            typ = 0.055;
            while( b(i,j,k) != -1 ) {
               allow = 1;
               // test horizontally
               for( m = 1; m <= 9; m++ ) {
                  if( b(i,j,k) == b(m,j,1) ) allow = 0;
               }
               // test vertically
               for( m = 1; m <= 9; m++ ) {
                  if( b(i,j,k) == b(i,m,1) ) allow = 0;
               }
               // test local square
               p = ptab(i,j);
               for( q = 1; q <= 9; q++ ) {
                  if( b(i,j,k) == b(itab(p,q),jtab(p,q),1) ) allow = 0;
               }
               if( allow ) {
                  txp += 0.0333;
                  if( txp > 0.09 ) {
                     txp = 0.01667;
                     typ = 0.005;
                  }
                  xyouts,d(i)+txp,d(j)+typ,itoa(b(i,j,k)),charsize=0.8,align=0.5;
                  k++;
               } else {
                  m = k;
                  while( b(i,j,m) != -1 ) {
                     b(i,j,m) = b(i,j,m+1);
                     m++;
                  }
               }
            } // terminate: while b(ijk) != -1
            if( b(i,j,2) == -1 ) { // impossible, report
               n = write(format="Inst: %d, Conflict at i,j = %d,%d\n", instance, i,j);
               res(1) = -1;
               return res;
            } else {
               // If only a single possibility is left then push up
               if( b(i,j,3) == -1 ) {
                  b(i,j,1) = b(i,j,2);
                  b(i,j,2) = -1;
                  n = write(format="Inst: %d, Unambiguous solution in i,j = %d,%d\n", \
                             instance, i,j);
                  try_again = 1;
               }
            }
         } // terminate: if( b(ijk) == 0 )
   
      }}

   }

   // Locate cell with fewest possibilities
   n_min = 99;
   for( i = 1; i <= 9; i++ ) {
   for( j = 1; j <= 9; j++ ) {
      if( b(i,j,1) == 0 ) {
         k = 2;
         while( b(i,j,k) != -1 ) k++;
         if( k-2 < n_min ) {
            imin = i;
            jmin = j;
            n_min = k-2;
         }
      }
   }}
   if( n_min == 99 ) {
      res(1) = 99;
      return res;
   }
   res(1) = imin;
   res(2) = jmin;
   res(3) = n_min;
   for( i = 1; i <= n_min; i++ ) {
      res(3+i) = b(imin,jmin,i+1);
   }
   return res;
}

func uku_choice(a)
{
   extern b;
   extern instance;
   extern nodes;

   if( nodes(3,instance) > nodes(4,instance) ) return 0; // beyond limit

   // define the b array cell according to nodes(3,instance)

   b( nodes(1,instance), nodes(2,instance), 1 ) \
      =  nodes(nodes(3,instance),instance);
   b(nodes(1,instance),nodes(2,instance),2:11) = -1;

   nodes(3,instance)++;

   return 1;
}


func uku_setup_node( res )
{
   extern nodes;
   extern instance;

   nodes(1,instance) = res(1);
   nodes(2,instance) = res(2);
   nodes(3,instance) = 5; // pointer to next value to choose
   nodes(4,instance) = 4 + res(3); // highest address of value
   for( i = 1; i <= res(3); i++ ) nodes(i+4,instance) = res(i+3);

}

func uku_goback(a)
{
   extern b;
   extern bs;
   extern instance;

   if( instance > 0 ) {
      b = bs(,,,instance--);
      n = write(format="Retrieving instance #%d\n", instance+1);
   } else {
      write(format="Not possible, no instances saved\n");
   }
}

func uku_run(a)
{
   extern bs;
   extern nodes;
   extern instance;

   log = open("uku.log","w");

   res = uku_view();
   write,format="##1## res%s",": ";
   write,format=" %d",res;
   write,format="%s\n","";
   write,log,format="##1## res%s",": ";
   write,log,format=" %d",res;
   write,log,format="%s\n","";
   instance = 1;

   kount = 0;
   while( ++kount <= 20 ) { // run until exit by error or solution

      write,format="##2## kount = %d\n", kount;
      write,log,format="##2## kount = %d\n", kount;

      uku_setup_node, res;
      write,format="##3## nodes inst=%d: ",instance;
      write,format=" %d",nodes(,instance);
      write,format="%s\n","";
      for( inst = 1; inst <= instance; inst++ ) {
         write,log,format="##3## nodes inst=%d: ",inst;
         write,log,format=" %d",nodes(,inst);
         write,log,format="%s\n","";
      }

      flag = 1;
      while( flag ) {

         write,format="##4## kount = %d\n", kount;
         write,log,format="##4## kount = %d\n", kount;

         ok = nodes(3,instance) <= nodes(4,instance);
         if( ok ) {
            bs(,,,instance) = b;
            write,format="##5## saving b to instance# %d\n", instance;
            write,log,format="##5## saving b to instance# %d\n", instance;
            ok = uku_choice();
            instance++;
            res = uku_view();
            write,format="##6## res%s",": ";
            write,format=" %d",res;
            write,format="%s\n","";
            write,log,format="##6## res%s",": ";
            write,log,format=" %d",res;
            write,log,format="%s\n","";
         }
         if( ok && res(1) != -1 ) {
            flag = 0;
            write,format="##7## setting flag = %d\n", flag;
            write,log,format="##7## setting flag = %d\n", flag;
            if( allof( b(,,1) ) ) {
               write,format="Solution found%s\n","!";
               write,log,format="Solution found%s\n","!";
               uku_refresh;
               return;
            }
         } else {
            if( --instance < 1 ) {
               write,format="##8## No solution, alas%s\n","!";
               write,log,format="##8## No solution, alas%s\n","!";
               return;
            }
            b = bs(,,,instance);
            write,format="##9## Instance %d restored\n", instance;
            write,log,format="##9## Instance %d restored\n", instance;
            write,format="##10## nodes inst=%d: ",instance;
            write,format=" %d",nodes(,instance);
            write,format="%s\n","";
            write,log,format="##10## nodes inst=%d: ",instance;
            write,log,format=" %d",nodes(,instance);
            write,log,format="%s\n","";
         }

      }
   }

   close,log;

}

func uku_reset(a)
{
   extern instance;

   uku_init;
   f = openb("sumo.bin");
   restore,f,b;
   close,f;
   uku_refresh;
   instance = 1;
}
%FILE% used_det_area.i
func used_det_area( jemxNum, radius_limit, swid, status_limit )
/* DOCUMENT fraction = used_det_area( jemxNum, radius_limit, swid, status_limit )
     Returns fraction of area inside the JEM-X detector that is used in the
     spectral extraction

     2008-02-08/NJW
*/
{

   jstr = swrite(format="%i", jemxNum );
   system,"get_insta_swijd -swid "+swid+" "+jstr+" imod 8 > _tmp_";
   insta_imod = read_slist("_tmp_")(1);
   system,"/bin/rm _tmp_";

   imoddir = get_env("IC_BASE")+"/imod_grp/";
   imodfile = imoddir+"jmx"+jstr+"_imod_grp_"+insta_imod+".fits";

   structname = "[JMX"+jstr+"-DETE-MOD]";
   map = readfits(imodfile+structname);
   d = distances(256,256,127,124);
   w = where( d < radius_limit );
   num_active = numberof( where( map(w)-1 <= status_limit ) );

   return double(num_active) / numberof(w);

}
%FILE% util_fr.i
/*
 * util_fr.i
 * A collection of routines for general purpose.
 *
 * $Id: util_fr.i,v 1.3 2008/10/29 15:58:13 paumard Exp $
 *
 * Author: Francois Rigaut.
 * Written 2002
 * last revision/addition: 2004Oct15
 *
 * Copyright (c) 2003, Francois RIGAUT (frigaut@gemini.edu, Gemini
 * Observatory, 670 N A'Ohoku Place, HILO HI-96720).
 *
 * This program is free software; you can redistribute it and/or  modify it
 * under the terms of the GNU General Public License  as  published  by the
 * Free Software Foundation; either version 2 of the License,  or  (at your
 * option) any later version.
 *
 * 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.   See  the GNU
 * General Public License for more details (to receive a  copy  of  the GNU
 * General Public License, write to the Free Software Foundation, Inc., 675
 * Mass Ave, Cambridge, MA 02139, USA).
 *
 * $Log: util_fr.i,v $
 * Revision 1.3  2008/10/29 15:58:13  paumard
 * utils.i: reform would not work with empty dimlist. Fixed.
 * plot_fr.i, util_fr.i, utils.i: rename functions now standard in Yorick (color_bar, rdfile, reform)
 *
 * Revision 1.2  2007/12/27 15:22:07  frigaut
 * nothing. commit before tagging.
 *
 */

require,"style.i";

/*************************/
/* CONVENIENCE functions */
/*************************/

func ls_fr 
/* DOCUMENT ls: system command ls 
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: pwd, system, $.
 */
{system,"ls";}

func exist(arg)
/* DOCUMENT exist(arg)
 * Returns 0 if element is not set or is a <nuller>, 1 otherwise
 * F.Rigaut 2002/04/03
 * SEE ALSO: is_void, where
 */
{
  if (numberof(arg) == 0) {return 0;}
  else {return 1;}
}



func is_set(arg)
/* DOCUMENT is_set(arg)
 * Returns 0 if element is void or equal to zero, 1 otherwise
 * F.Rigaut 2002/06/03
 * SEE ALSO: is_void, where, exist
 */
{
  if (is_void(arg) | (arg == 0)) {return 0;}
  else {return 1;}
}



func tv(im,square=) 
/* DOCUMENT tv(im,square=) 
 * This routines does a frame advance, display the image
 * and set the limits to have the image full display.
 * Inspired from the IDL tvscl
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: fma, pli, plot_aux
 */
{
  fma; 
  pli,im; 
  limits,"e","e","e","e",square=square;
}



func plot_aux(vect,x,square=,histo=) 
/* DOCUMENT plot_aux(vect,x,square=,histo=)
 * Short cut for a fma + plg
 * Set histo to get plh_fr type plot
 * F.Rigaut 2001/10
 * SEE ALSO: plg, fma, tv, plh_fr
 */
{
  fma;
  if (is_set(histo)) {
    plh_fr,vect,x;
  } else {
    plg,vect,x;
  }
  limits,,,,,square=square;
}



func nprint(var,sep=,format=)
/* DOCUMENT func nprint(var,sep=,format=)
   Neat print of a 2d array.
   example:
   > nprint,optpos*pi/3.14e9,sep=", "
      +0, -5.003e-07,       +0, -9.005e-08,       +0,       +0 
      +0, -4.002e-07,       +0, +9.005e-08,       +0,       +0 
      +0, -3.002e-07,       +0, +9.005e-08,       +0,       +0 
      +0, -2.001e-07,       +0, +9.005e-08,       +0,       +0 
      +0, -1.801e-07,       +0, +9.005e-08,       +0,       +0 
      +0, -1.001e-07,       +0, +9.005e-08,       +0,       +0 
      +0, +1.001e-07,       +0, +9.005e-08,       +0,       +0
   sep= separator string. The default separator is two blanks ("  ").
   format= swrite format
   Restricted to 2D arrays
   SEE ALSO: pm
 */
{
  if (!is_set(sep)) sep = " ";
  if (!is_set(format)) format = "%+8.4g";
  dim = dimsof(var);
  if (dim(1) != 2) {error,"only implemented for 2D arrays";}
  for (i=1;i<=dim(3);i++) {
    for (j=1;j<=dim(2)-1;j++) {
      write,format=format+sep,var(j,i);
    }
    write,format=format,var(0,i);
    write,"";
  }
}



func typeReturn(void)
/* DOCUMENT typeReturn(void)
 * A simple convenient function that does what is name says.
 * SEE ALSO:
 */
{
  rep = rdline(prompt="type return to continue..."); 
  return rep;
}
hitReturn=typeReturn;



/****************************/
/* ADDITIONAL MATH function */
/****************************/

func round(arg) 
/* DOCUMENT round(arg)
 * Returns the rounded version of a floating point argument
 * modified 2007dec06 to fix problem with negative numbers
 * F.Rigaut 2001/10
 * SEE ALSO: ceil, floor
 */
{return long(arg+0.5)-(arg<0);}



func even(arg) 
/* DOCUMENT even(arg)
 * returns 1 is argument is even, zero otherwise. 
 * The argument should be an integer.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: odd
 */
{return ((arg % 2) == 0);}



func odd(arg) 
/* DOCUMENT odd(arg)
 * Returns 1 is argument is odd, zero otherwise. 
 * The argument should be an integer.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: even
 */
{return ((arg % 2) == 1);}



func minmax(arg) 
/* DOCUMENT minmax(arg)
 * Returns a vector containing the min and the max of the argument
 * F.Rigaut 2001/09
 * SEE ALSO:
 */
{return [min(arg),max(arg)];}



local clip;
func __clip(arg,lt,ht)
/* DOCUMENT func clip(arg, mini, maxi);
 * Returns the argument, which has been "clipped" to mini
 * and maxi, i.e. in which all elements lower than "mini"
 * have been replaced by "mini" and all elements greater
 * than "maxi" by "maxi". Array is converted to float.
 * Either "mini" and "maxi" can be ommited, in which case
 * the corresponding mini or maxi is not clipped.
 * Equivalent to the IDL ">" and "<" operators.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO:
 */
{
  if (lt != []) arg = max(arg,lt);
  if (ht != []) arg = min(arg,ht);
  return arg;
}
if (!is_func(clip)) clip = __clip;



local sinc;
func __mysinc(ar)
/* DOCUMENT func sinc(ar)
 * Return the sinus cardinal of the input array
 * F.Rigaut, 2002/04/03
 * SEE ALSO: Eric Thiebault wrote a sinc which is probably better.
 */
{
  local ar;
  ar = double(ar);
  w  = where(abs(ar) < 1e-10);
  if (exist(w)) {ar(w) = 1e-10;}
  return sin(ar)/ar;
}
if (!is_func(sinc)) sinc = __mysinc;



/************************************/
/* SYSTEM AND PERFORMANCE functions */
/************************************/

func tic(counterNumber)
/* DOCUMENT tic(counter_number)
 * Marks the beginning of a time lapse
 * ex: tic ; do_something ; tac()
 * will print out the time ellapsed between tic and tac
 * a counter number can optionaly be specified if several
 * counters have to be used in parallel.
 * F.Rigaut 2001/10
 * SEE ALSO: tac
 */
{
  if (counterNumber == []) counterNumber = 1;
  if (counterNumber > 10) error,"tic and tac are limited to 10 time counters !";

  el = array(double,3);
  timer,el;
  _nowtime(counterNumber) = el(3);
}
extern _nowtime;
 _nowtime = array(double,10);



func tac(counterNumber)
/* DOCUMENT tac(counter_number)
 * Marks the end of a time lapse
 * ex: tic ; do_something ; tac()
 * will print out the time ellapsed between tic and tac
 * a counter number can optionaly be specified if several
 * counters have to be used in parallel.
 * F.Rigaut 2001/10
 * SEE ALSO: tic
 */
{
  if (counterNumber == []) counterNumber = 1;

  el = array(double,3);
  timer,el;
  elapsed = el(3)-_nowtime(counterNumber);

  return elapsed;
}



func spawn_fr(command) 
/* DOCUMENT spawn_fr(command)
 * This function tries to group in one call the :
 * - call to system
 * - read the file created by the system call
 * - returns it
 * Inspired from the IDL function of the same name
 * F.Rigaut 2002/04/04
 * SEE ALSO: system, popen, exec in Eric/system.i
 * 
 * DEPRECATED: Use spawn/sys instead.
 */
{
  f   = popen(command,0);
  ans = rdline(f);
  l   = ans;
  while (l)
    {
      l = rdline(f);
      if (l) {ans = grow(ans,l);}
    }
  return ans;
}  



/*******************/
/* ARRAY functions */
/*******************/

func wheremin(ar) { return  where(ar == min(ar)); }
func wheremax(ar) { return  where(ar == max(ar)); }
/* DOCUMENT func wheremin(ar)
        and func wheremax(ar)
   Short hand for where(array == min(array) or max(array)
   SEE ALSO: where, where2, min, max
 */



func indices_fr(dim)
/* DOCUMENT indices_fr(dim)
 * Return a dimxdimx2 array. First plane is the X indices of the pixels
 * in the dimxdim array. Second plane contains the Y indices.
 * Inspired by the Python scipy routine of the same name.
 * New (June 12 2002): dim can either be :
 *   - a single number N (e.g. 128) in which case the returned array are
 *     square (NxN)
 *   - a Yorick array size, e.g. [#dimension,N1,N2], in which case
 *     the returned array are N1xN2
 *   - a vector [N1,N2], same result as previous case
 * F.Rigaut 2002/04/03
 * SEE ALSO: span
 */
{
  if (numberof(dim) == 1)
  {
    x  = span(1,dim,dim)(,-:1:dim);
    y  = transpose(x);
    return [x,y];
  } else
  {
    if (numberof(dim) == 3) {dim = dim(2:3);}
    x  = span(1,dim(1),dim(1))(,-:1:dim(2));
    y  = span(1,dim(2),dim(2))(,-:1:dim(1));
    y  = transpose(y);
    return [x,y];
  }
    
}



local dist;
func __dist(dim,xc=,yc=)
/* DOCUMENT func dist(size,xc=,yc=)
 * Returns an array which elements contains the distance to (xc,yc). xc
 * and yc can be omitted, in which case they are defaulted to size/2+1.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: indices, radial_distance
 */
{
  dim	= long(dim);
  if (xc == []) xc = int(dim/2)+1;
  if (yc == []) yc = int(dim/2)+1;
  x	= float(span(1,dim,dim)(,-:1:dim));
  y	= transpose(x);
  d	= float(sqrt((x-xc)^2.+(y-yc)^2.));
  d	= clip(d,1e-5,);
  return d;
}
if (!is_func(dist)) {dist = __dist;}



local eclat;
func __eclat(image)
/* DOCUMENT func eclat(image)
 * Equivalent, but slightly faster (?) than roll. Transpose the four main
 * quadrants of a 2D array. Mostly used for FFT applications.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: roll.
 */
{
  d	= dimsof(image);
  dx	= d(2);
  dy	= d(3);
  x1=1; x2=dx/2 ; x3=x2+1 ; x4=dx;
  y1=1; y2=dy/2 ; y3=y2+1 ; y4=dy;
  out	= image*0.;
  out(x1:x2,y1:y2) = image(x3:x4,y3:y4);
  out(x3:x4,y1:y2) = image(x1:x2,y3:y4);
  out(x1:x2,y3:y4) = image(x3:x4,y1:y2);
  out(x3:x4,y3:y4) = image(x1:x2,y1:y2);
  return out;
}
if (!is_func(eclat)) {eclat = __eclat;}



func makegaussian(size,fwhm,xc=,yc=,norm=) 
/* DOCUMENT makegaussian(size,fwhm,xc=,yc=)
 * Returns a centered gaussian of specified size and fwhm.
 * F.Rigaut 2001/09
 * norm returns normalized 2d gaussian
 * SEE ALSO:
 */
{
  tmp = exp(-(dist(size,xc=xc,yc=yc)/(fwhm/1.66))^2.);
  if (is_set(norm)) tmp = tmp/fwhm^2./1.140075;
  return tmp;
}



func bin2(image)
/* DOCUMENT bin2(image)
 * Returns the input image, binned by a factor of 2.
 * That is, a 512x512 image is transformed in a 256x256 image.
 * one output pixel is the average of the 4 corresponding input ones,
 * so that it conserves the total intensity.
 * SEE ALSO: undersample
 */
{
  d = dimsof(image);
  if (d(1) != 2) {
    error,"Bin only accepts images";
  }
  if (((d(2) % 2) != 0) || ((d(3) % 2) != 0)) {
    error,"Bin only accepts dimensions with even # of pixels";
  }
  sim= image+roll(image,[-1,-1])+roll(image,[-1,0])+roll(image,[0,-1]);
  return sim(::2,::2);
}



/*****************************/
/* STRING AND FILE functions */
/*****************************/

func fileExist(filename)
/* DOCUMENT fileExist(filename)
 *  Returns "1" if the file(s) exist(s), "0" if it does not.
 *  filename can be an array, in which case the results is an array
 *  of 0s and 1s.
 *  F.Rigaut 2002/01
 *  SEE ALSO:
 */
{
  exist = [];
  for (i=1;i<=numberof(filename);i++) {
    grow,exist,(open(filename(i),"r",1) ? 1:0);
  }
  if (numberof(filename) == 1) {return exist(1);}
  return exist;
}



func findfiles(files)
/* DOCUMENT findfiles(filter)
 * This routines returns a list of files which satisfy the filter
 * argument. The list is a string vector. If no files were found,
 * the results is the empty string.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: spawn
 */
{
  // parse input parameter into path and filename:
  tmp = strtok(files,"/",20);
  tmp = tmp(where(tmp));
  
  filereg = tmp(0);

  if (numberof(tmp)>1) {
    path = sum(tmp(1:-1)+"/");
    if (strpart(files,1:1)=="/") path = "/"+path;
  } else path=".";

  l = lsdir(path);

  // process result list:
  if (noneof(l)) return;

  w = where(strglob(filereg,l));
  if (numberof(w)==0) return;
  
  res = l(w);
  if (path==".") return res;

  return (path+res);
}



func __rdfile(file)
/* DOCUMENT func rdfile(file)
   Open, read, close and return the whole content of ascii file "file".
   AUTHOR : F.Rigaut, Oct 2004.
   SEE ALSO: load_text, dump_text
 */
{
  f = open(file,"r");
  fcontent = [];
  while (line=rdline(f)) grow,fcontent,line;
  return fcontent;
}
if (!rdfile) rdfile=__rdfile;




func parsedate_fr(strdate,format,dec=)
/* DOCUMENT parsedate(strdate,format,dec=)
 * Returns the date in integers as an array [[year],[month],[day]],
 * or in decimal if "dec" is set. The format has to be specified.
 * Does not yet accept dates in the form "2003jun05".
 * strdate = string array containing the date e.g. "2003/10/25"
 * format  = format in the form "yyyy/mm/dd"
 * Examples:
 * > parsedate(["2003/05/21","2003/02/15"],"yyyy/mm/dd",dec=1)
 * [2003.38,2003.12]
 * > parsedate(["2003/05/21","2003/02/15"],"yyyy/mm/dd")
 * [[2003,2003],[5,2],[21,15]]
 * SEE ALSO: parsetime
 ***** NEED TO UPGRADE THIS FUNCTION FOR THE 1.6 STR FUNCTIONS ****
 */
{
  exit,"not upgraded for use with the yorick-1.6.01 str functions";

  a = b = c = array(long,numberof(strdate));
  strdate = strtrim(strdate);

  format = strtolower(format);
  wy = strfind(format,"y"); ys = strjoin(array("y",numberof(wy)));
  wm = strfind(format,"m"); ms = strjoin(array("m",numberof(wm)));
  wd = strfind(format,"d"); ds = strjoin(array("d",numberof(wd)));
  format = strreplace(format,ys,"%"+swrite(numberof(wy),format="%d")+"d");
  format = strreplace(format,ms,"%"+swrite(numberof(wm),format="%d")+"d");
  format = strreplace(format,ds,"%"+swrite(numberof(wd),format="%d")+"d");

  sread,strdate,format=format,a,b,c;

  if (wy(1) < wm(1) & wm(1) < wd(1)) ymd= [a,b,c];
  if (wd(1) < wm(1) & wm(1) < wy(1)) ymd= [c,b,a];
  if (wm(1) < wd(1) & wd(1) < wy(1)) ymd= [c,a,b];
  if (wy(1) < wd(1) & wd(1) < wm(1)) ymd= [a,c,b];
  if (wd(1) < wy(1) & wy(1) < wm(1)) ymd= [b,c,a];
  if (wm(1) < wy(1) & wy(1) < wd(1)) ymd= [b,a,c];

  if (!dec) {return ymd;}

  mlength = [31.,28,31,30,31,30,31,31,30,31,30,31];
  // rought cut at bisextile years:
  bisext = (ymd(..,1)/4. == ymd(..,1)/4);
  // none of the date are bisextile:
  if (noneof(bisext)) {
    return ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum);
  }

  // all of the date are bisextile:
  if (allof(bisext)) {
    mlength(2) = 29;
    return ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum);
  }

  // mix of bisextile and not:
  tnotbi = ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum);
  mlength(2) = 29;
  tbi    = ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum);
  return tnotbi*(1-bisext) + tbi*bisext;
}



func parsetime_fr(strtime,dec=)
/* DOCUMENT parsetime(strtime,dec=)
 * Parse the input string array "strtime" and returns the time as a [hh,mm,ss]
 * vector (or array if strtime is an array of string) or returns the time
 * as a single decimal number (or vector if strtime is an array) if the
 * "dec" keyword is set.
 * Examples:
 * > parsetime(["22:30:25.792","22:20:33.852"],dec=1)
 * [22.5072,22.3427]
 * > parsetime(["22:30:25.792","22:20:33.852"])
 * [[22,22],[30,20],[25.792,33.852]]
 ***** NEED TO UPGRADE THIS FUNCTION FOR THE 1.6 STR FUNCTIONS ****
 * SEE ALSO: parsedate
 */
{
  exit,"not upgraded for use with the yorick-1.6.01 str functions";
  n = numberof(strtime);
  h = m = array(long,n);
  s = array(float,n);
  strtime = strtrim(strtime);
  if (allof(strmatch(strtime,":"))) {delim=":";} \
  else if (allof(strmatch(strtime," "))) {delim=" ";} \
  else if (allof(strmatch(strtime,";"))) {delim=";";} \
  else {error,"Can't figure out the delimiter";}
  f = "%2d"+delim+"%2d"+delim+"%f";
  sread,strtime,format=f,h,m,s;
  if (dec) return h+m/60.+s/3600.;
  return [h,m,s];
}


func secToHMS(time)
/* DOCUMENT secToHMS(time)
 * Convert from time (float in sec) to string in the form hh:mm:ss.s
 * AUTHOR : F.Rigaut, June 13 2002.
 * SEE ALSO: 
 */
{
  lt    = long(time);
  hh    = lt/3600;
  lt    = lt-hh*3600;
  mm    = lt/60;
  sec   = float(time)-hh*3600-mm*60;
  ts    = swrite(hh,mm,sec,format="%02i:%02i:%04.1f");
  return ts;
} 


/*********************/
/* GRAPHIC functions */
/*********************/

func colorbar(cmin, cmax,adjust=,levs=)
/* DOCUMENT colorbar
            colorbar, cmin, cmax
     draw a color bar to the right of the plot.  If CMIN and CMAX
     are specified, label the top and bottom of the bar with those
     numbers.
     adjust: x adjust. typically +/- 0.01 
     levs: number of ticks in color bar (plus one)
     upgraded 2007june02
   SEE ALSO: color_bar
 */
{
  if (adjust==[]) adjust=0.;
  cursys = plsys();

  get_style,landscape, systems, legends, clegends;

  left   = systems(cursys).viewport(2)+0.03+adjust;
  right  = systems(cursys).viewport(2)+0.05+adjust;
  bottom = systems(cursys).viewport(3);
  top    = systems(cursys).viewport(4);
  middle = (left+right)/2.;
  
  plsys, 0;
  pli, span(0,1,200)(-,), left, bottom, right, top, legend="";
  plg, [bottom,top,top,bottom],[right,right,left,left], closed=1,
    marks=0,color="fg",width=1,type=1,legend="";
  if (levs) {
    for (i=1;i<=(levs-1);i++) {
      y=bottom+(top-bottom)/levs*i;
      plg, [y,y],[left,right], marks=0,color="fg",width=1,type=1,legend="";
    }
  }
  plsys, cursys; 
  if (!is_void(cmin)) {
    plt, pr1(cmin), middle, bottom-0.005, justify="CT";
    plt, pr1(cmax), middle, top+0.005, justify="CB";
  }
}

// general equivalent (remove if you don't like them)
man=help;
%FILE% util_fr_2106.i
/*
 * util_fr.i
 * A collection of routines for general purpose.
 *
 * $Id: util_fr.i,v 1.3 2008/10/29 15:58:13 paumard Exp $
 *
 * Author: Francois Rigaut.
 * Written 2002
 * last revision/addition: 2004Oct15
 *
 * Copyright (c) 2003, Francois RIGAUT (frigaut@gemini.edu, Gemini
 * Observatory, 670 N A'Ohoku Place, HILO HI-96720).
 *
 * This program is free software; you can redistribute it and/or  modify it
 * under the terms of the GNU General Public License  as  published  by the
 * Free Software Foundation; either version 2 of the License,  or  (at your
 * option) any later version.
 *
 * 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.   See  the GNU
 * General Public License for more details (to receive a  copy  of  the GNU
 * General Public License, write to the Free Software Foundation, Inc., 675
 * Mass Ave, Cambridge, MA 02139, USA).
 *
 * $Log: util_fr.i,v $
 * Revision 1.3  2008/10/29 15:58:13  paumard
 * utils.i: reform would not work with empty dimlist. Fixed.
 * plot_fr.i, util_fr.i, utils.i: rename functions now standard in Yorick (color_bar, rdfile, reform)
 *
 * Revision 1.2  2007/12/27 15:22:07  frigaut
 * nothing. commit before tagging.
 *
 */

require,"style.i";

/*************************/
/* CONVENIENCE functions */
/*************************/

func ls_fr 
/* DOCUMENT ls: system command ls 
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: pwd, system, $.
 */
{system,"ls";}

func exist(arg)
/* DOCUMENT exist(arg)
 * Returns 0 if element is not set or is a <nuller>, 1 otherwise
 * F.Rigaut 2002/04/03
 * SEE ALSO: is_void, where
 */
{
  if (numberof(arg) == 0) {return 0;}
  else {return 1;}
}



func is_set(arg)
/* DOCUMENT is_set(arg)
 * Returns 0 if element is void or equal to zero, 1 otherwise
 * F.Rigaut 2002/06/03
 * SEE ALSO: is_void, where, exist
 */
{
  if (is_void(arg) | (arg == 0)) {return 0;}
  else {return 1;}
}



func tv(im,square=) 
/* DOCUMENT tv(im,square=) 
 * This routines does a frame advance, display the image
 * and set the limits to have the image full display.
 * Inspired from the IDL tvscl
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: fma, pli, plot_aux
 */
{
  fma; 
  pli,im; 
  limits,"e","e","e","e",square=square;
}



func plot_aux(vect,x,square=,histo=) 
/* DOCUMENT plot_aux(vect,x,square=,histo=)
 * Short cut for a fma + plg
 * Set histo to get plh_fr type plot
 * F.Rigaut 2001/10
 * SEE ALSO: plg, fma, tv, plh_fr
 */
{
  fma;
  if (is_set(histo)) {
    plh_fr,vect,x;
  } else {
    plg,vect,x;
  }
  limits,,,,,square=square;
}



func nprint(var,sep=,format=)
/* DOCUMENT func nprint(var,sep=,format=)
   Neat print of a 2d array.
   example:
   > nprint,optpos*pi/3.14e9,sep=", "
      +0, -5.003e-07,       +0, -9.005e-08,       +0,       +0 
      +0, -4.002e-07,       +0, +9.005e-08,       +0,       +0 
      +0, -3.002e-07,       +0, +9.005e-08,       +0,       +0 
      +0, -2.001e-07,       +0, +9.005e-08,       +0,       +0 
      +0, -1.801e-07,       +0, +9.005e-08,       +0,       +0 
      +0, -1.001e-07,       +0, +9.005e-08,       +0,       +0 
      +0, +1.001e-07,       +0, +9.005e-08,       +0,       +0
   sep= separator string. The default separator is two blanks ("  ").
   format= swrite format
   Restricted to 2D arrays
   SEE ALSO: pm
 */
{
  if (!is_set(sep)) sep = " ";
  if (!is_set(format)) format = "%+8.4g";
  dim = dimsof(var);
  if (dim(1) != 2) {error,"only implemented for 2D arrays";}
  for (i=1;i<=dim(3);i++) {
    for (j=1;j<=dim(2)-1;j++) {
      write,format=format+sep,var(j,i);
    }
    write,format=format,var(0,i);
    write,"";
  }
}



func typeReturn(void)
/* DOCUMENT typeReturn(void)
 * A simple convenient function that does what is name says.
 * SEE ALSO:
 */
{
  rep = rdline(prompt="type return to continue..."); 
  return rep;
}
hitReturn=typeReturn;



/****************************/
/* ADDITIONAL MATH function */
/****************************/

//func round(arg) 
/* DOCUMENT round(arg)
 * Returns the rounded version of a floating point argument
 * modified 2007dec06 to fix problem with negative numbers
 * F.Rigaut 2001/10
 * SEE ALSO: ceil, floor
 */
//{return long(arg+0.5)-(arg<0);}



func even(arg) 
/* DOCUMENT even(arg)
 * returns 1 is argument is even, zero otherwise. 
 * The argument should be an integer.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: odd
 */
{return ((arg % 2) == 0);}



func odd(arg) 
/* DOCUMENT odd(arg)
 * Returns 1 is argument is odd, zero otherwise. 
 * The argument should be an integer.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: even
 */
{return ((arg % 2) == 1);}



func minmax(arg) 
/* DOCUMENT minmax(arg)
 * Returns a vector containing the min and the max of the argument
 * F.Rigaut 2001/09
 * SEE ALSO:
 */
{return [min(arg),max(arg)];}



local clip;
func __clip(arg,lt,ht)
/* DOCUMENT func clip(arg, mini, maxi);
 * Returns the argument, which has been "clipped" to mini
 * and maxi, i.e. in which all elements lower than "mini"
 * have been replaced by "mini" and all elements greater
 * than "maxi" by "maxi". Array is converted to float.
 * Either "mini" and "maxi" can be ommited, in which case
 * the corresponding mini or maxi is not clipped.
 * Equivalent to the IDL ">" and "<" operators.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO:
 */
{
  if (lt != []) arg = max(arg,lt);
  if (ht != []) arg = min(arg,ht);
  return arg;
}
if (!is_func(clip)) clip = __clip;



local sinc;
func __mysinc(ar)
/* DOCUMENT func sinc(ar)
 * Return the sinus cardinal of the input array
 * F.Rigaut, 2002/04/03
 * SEE ALSO: Eric Thiebault wrote a sinc which is probably better.
 */
{
  local ar;
  ar = double(ar);
  w  = where(abs(ar) < 1e-10);
  if (exist(w)) {ar(w) = 1e-10;}
  return sin(ar)/ar;
}
if (!is_func(sinc)) sinc = __mysinc;



/************************************/
/* SYSTEM AND PERFORMANCE functions */
/************************************/

func tic(counterNumber)
/* DOCUMENT tic(counter_number)
 * Marks the beginning of a time lapse
 * ex: tic ; do_something ; tac()
 * will print out the time ellapsed between tic and tac
 * a counter number can optionaly be specified if several
 * counters have to be used in parallel.
 * F.Rigaut 2001/10
 * SEE ALSO: tac
 */
{
  if (counterNumber == []) counterNumber = 1;
  if (counterNumber > 10) error,"tic and tac are limited to 10 time counters !";

  el = array(double,3);
  timer,el;
  _nowtime(counterNumber) = el(3);
}
extern _nowtime;
 _nowtime = array(double,10);



func tac(counterNumber)
/* DOCUMENT tac(counter_number)
 * Marks the end of a time lapse
 * ex: tic ; do_something ; tac()
 * will print out the time ellapsed between tic and tac
 * a counter number can optionaly be specified if several
 * counters have to be used in parallel.
 * F.Rigaut 2001/10
 * SEE ALSO: tic
 */
{
  if (counterNumber == []) counterNumber = 1;

  el = array(double,3);
  timer,el;
  elapsed = el(3)-_nowtime(counterNumber);

  return elapsed;
}



func spawn_fr(command) 
/* DOCUMENT spawn_fr(command)
 * This function tries to group in one call the :
 * - call to system
 * - read the file created by the system call
 * - returns it
 * Inspired from the IDL function of the same name
 * F.Rigaut 2002/04/04
 * SEE ALSO: system, popen, exec in Eric/system.i
 * 
 * DEPRECATED: Use spawn/sys instead.
 */
{
  f   = popen(command,0);
  ans = rdline(f);
  l   = ans;
  while (l)
    {
      l = rdline(f);
      if (l) {ans = grow(ans,l);}
    }
  return ans;
}  



/*******************/
/* ARRAY functions */
/*******************/

func wheremin(ar) { return  where(ar == min(ar)); }
func wheremax(ar) { return  where(ar == max(ar)); }
/* DOCUMENT func wheremin(ar)
        and func wheremax(ar)
   Short hand for where(array == min(array) or max(array)
   SEE ALSO: where, where2, min, max
 */



func indices_fr(dim)
/* DOCUMENT indices_fr(dim)
 * Return a dimxdimx2 array. First plane is the X indices of the pixels
 * in the dimxdim array. Second plane contains the Y indices.
 * Inspired by the Python scipy routine of the same name.
 * New (June 12 2002): dim can either be :
 *   - a single number N (e.g. 128) in which case the returned array are
 *     square (NxN)
 *   - a Yorick array size, e.g. [#dimension,N1,N2], in which case
 *     the returned array are N1xN2
 *   - a vector [N1,N2], same result as previous case
 * F.Rigaut 2002/04/03
 * SEE ALSO: span
 */
{
  if (numberof(dim) == 1)
  {
    x  = span(1,dim,dim)(,-:1:dim);
    y  = transpose(x);
    return [x,y];
  } else
  {
    if (numberof(dim) == 3) {dim = dim(2:3);}
    x  = span(1,dim(1),dim(1))(,-:1:dim(2));
    y  = span(1,dim(2),dim(2))(,-:1:dim(1));
    y  = transpose(y);
    return [x,y];
  }
    
}



local dist;
func __dist(dim,xc=,yc=)
/* DOCUMENT func dist(size,xc=,yc=)
 * Returns an array which elements contains the distance to (xc,yc). xc
 * and yc can be omitted, in which case they are defaulted to size/2+1.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: indices, radial_distance
 */
{
  dim	= long(dim);
  if (xc == []) xc = int(dim/2)+1;
  if (yc == []) yc = int(dim/2)+1;
  x	= float(span(1,dim,dim)(,-:1:dim));
  y	= transpose(x);
  d	= float(sqrt((x-xc)^2.+(y-yc)^2.));
  d	= clip(d,1e-5,);
  return d;
}
if (!is_func(dist)) {dist = __dist;}



local eclat;
func __eclat(image)
/* DOCUMENT func eclat(image)
 * Equivalent, but slightly faster (?) than roll. Transpose the four main
 * quadrants of a 2D array. Mostly used for FFT applications.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: roll.
 */
{
  d	= dimsof(image);
  dx	= d(2);
  dy	= d(3);
  x1=1; x2=dx/2 ; x3=x2+1 ; x4=dx;
  y1=1; y2=dy/2 ; y3=y2+1 ; y4=dy;
  out	= image*0.;
  out(x1:x2,y1:y2) = image(x3:x4,y3:y4);
  out(x3:x4,y1:y2) = image(x1:x2,y3:y4);
  out(x1:x2,y3:y4) = image(x3:x4,y1:y2);
  out(x3:x4,y3:y4) = image(x1:x2,y1:y2);
  return out;
}
if (!is_func(eclat)) {eclat = __eclat;}



func makegaussian(size,fwhm,xc=,yc=,norm=) 
/* DOCUMENT makegaussian(size,fwhm,xc=,yc=)
 * Returns a centered gaussian of specified size and fwhm.
 * F.Rigaut 2001/09
 * norm returns normalized 2d gaussian
 * SEE ALSO:
 */
{
  tmp = exp(-(dist(size,xc=xc,yc=yc)/(fwhm/1.66))^2.);
  if (is_set(norm)) tmp = tmp/fwhm^2./1.140075;
  return tmp;
}



func bin2(image)
/* DOCUMENT bin2(image)
 * Returns the input image, binned by a factor of 2.
 * That is, a 512x512 image is transformed in a 256x256 image.
 * one output pixel is the average of the 4 corresponding input ones,
 * so that it conserves the total intensity.
 * SEE ALSO: undersample
 */
{
  d = dimsof(image);
  if (d(1) != 2) {
    error,"Bin only accepts images";
  }
  if (((d(2) % 2) != 0) || ((d(3) % 2) != 0)) {
    error,"Bin only accepts dimensions with even # of pixels";
  }
  sim= image+roll(image,[-1,-1])+roll(image,[-1,0])+roll(image,[0,-1]);
  return sim(::2,::2);
}



/*****************************/
/* STRING AND FILE functions */
/*****************************/

func fileExist(filename)
/* DOCUMENT fileExist(filename)
 *  Returns "1" if the file(s) exist(s), "0" if it does not.
 *  filename can be an array, in which case the results is an array
 *  of 0s and 1s.
 *  F.Rigaut 2002/01
 *  SEE ALSO:
 */
{
  exist = [];
  for (i=1;i<=numberof(filename);i++) {
    grow,exist,(open(filename(i),"r",1) ? 1:0);
  }
  if (numberof(filename) == 1) {return exist(1);}
  return exist;
}



func findfiles(files)
/* DOCUMENT findfiles(filter)
 * This routines returns a list of files which satisfy the filter
 * argument. The list is a string vector. If no files were found,
 * the results is the empty string.
 * F.Rigaut, 2001/11/10.
 * SEE ALSO: spawn
 */
{
  // parse input parameter into path and filename:
  tmp = strtok(files,"/",20);
  tmp = tmp(where(tmp));
  
  filereg = tmp(0);

  if (numberof(tmp)>1) {
    path = sum(tmp(1:-1)+"/");
    if (strpart(files,1:1)=="/") path = "/"+path;
  } else path=".";

  l = lsdir(path);

  // process result list:
  if (noneof(l)) return;

  w = where(strglob(filereg,l));
  if (numberof(w)==0) return;
  
  res = l(w);
  if (path==".") return res;

  return (path+res);
}



func __rdfile(file)
/* DOCUMENT func rdfile(file)
   Open, read, close and return the whole content of ascii file "file".
   AUTHOR : F.Rigaut, Oct 2004.
   SEE ALSO: load_text, dump_text
 */
{
  f = open(file,"r");
  fcontent = [];
  while (line=rdline(f)) grow,fcontent,line;
  return fcontent;
}
if (!rdfile) rdfile=__rdfile;




func parsedate_fr(strdate,format,dec=)
/* DOCUMENT parsedate(strdate,format,dec=)
 * Returns the date in integers as an array [[year],[month],[day]],
 * or in decimal if "dec" is set. The format has to be specified.
 * Does not yet accept dates in the form "2003jun05".
 * strdate = string array containing the date e.g. "2003/10/25"
 * format  = format in the form "yyyy/mm/dd"
 * Examples:
 * > parsedate(["2003/05/21","2003/02/15"],"yyyy/mm/dd",dec=1)
 * [2003.38,2003.12]
 * > parsedate(["2003/05/21","2003/02/15"],"yyyy/mm/dd")
 * [[2003,2003],[5,2],[21,15]]
 * SEE ALSO: parsetime
 ***** NEED TO UPGRADE THIS FUNCTION FOR THE 1.6 STR FUNCTIONS ****
 */
{
  exit,"not upgraded for use with the yorick-1.6.01 str functions";

  a = b = c = array(long,numberof(strdate));
  strdate = strtrim(strdate);

  format = strtolower(format);
  wy = strfind(format,"y"); ys = strjoin(array("y",numberof(wy)));
  wm = strfind(format,"m"); ms = strjoin(array("m",numberof(wm)));
  wd = strfind(format,"d"); ds = strjoin(array("d",numberof(wd)));
  format = strreplace(format,ys,"%"+swrite(numberof(wy),format="%d")+"d");
  format = strreplace(format,ms,"%"+swrite(numberof(wm),format="%d")+"d");
  format = strreplace(format,ds,"%"+swrite(numberof(wd),format="%d")+"d");

  sread,strdate,format=format,a,b,c;

  if (wy(1) < wm(1) & wm(1) < wd(1)) ymd= [a,b,c];
  if (wd(1) < wm(1) & wm(1) < wy(1)) ymd= [c,b,a];
  if (wm(1) < wd(1) & wd(1) < wy(1)) ymd= [c,a,b];
  if (wy(1) < wd(1) & wd(1) < wm(1)) ymd= [a,c,b];
  if (wd(1) < wy(1) & wy(1) < wm(1)) ymd= [b,c,a];
  if (wm(1) < wy(1) & wy(1) < wd(1)) ymd= [b,a,c];

  if (!dec) {return ymd;}

  mlength = [31.,28,31,30,31,30,31,31,30,31,30,31];
  // rought cut at bisextile years:
  bisext = (ymd(..,1)/4. == ymd(..,1)/4);
  // none of the date are bisextile:
  if (noneof(bisext)) {
    return ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum);
  }

  // all of the date are bisextile:
  if (allof(bisext)) {
    mlength(2) = 29;
    return ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum);
  }

  // mix of bisextile and not:
  tnotbi = ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum);
  mlength(2) = 29;
  tbi    = ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum);
  return tnotbi*(1-bisext) + tbi*bisext;
}



func parsetime_fr(strtime,dec=)
/* DOCUMENT parsetime(strtime,dec=)
 * Parse the input string array "strtime" and returns the time as a [hh,mm,ss]
 * vector (or array if strtime is an array of string) or returns the time
 * as a single decimal number (or vector if strtime is an array) if the
 * "dec" keyword is set.
 * Examples:
 * > parsetime(["22:30:25.792","22:20:33.852"],dec=1)
 * [22.5072,22.3427]
 * > parsetime(["22:30:25.792","22:20:33.852"])
 * [[22,22],[30,20],[25.792,33.852]]
 ***** NEED TO UPGRADE THIS FUNCTION FOR THE 1.6 STR FUNCTIONS ****
 * SEE ALSO: parsedate
 */
{
  exit,"not upgraded for use with the yorick-1.6.01 str functions";
  n = numberof(strtime);
  h = m = array(long,n);
  s = array(float,n);
  strtime = strtrim(strtime);
  if (allof(strmatch(strtime,":"))) {delim=":";} \
  else if (allof(strmatch(strtime," "))) {delim=" ";} \
  else if (allof(strmatch(strtime,";"))) {delim=";";} \
  else {error,"Can't figure out the delimiter";}
  f = "%2d"+delim+"%2d"+delim+"%f";
  sread,strtime,format=f,h,m,s;
  if (dec) return h+m/60.+s/3600.;
  return [h,m,s];
}


func secToHMS(time)
/* DOCUMENT secToHMS(time)
 * Convert from time (float in sec) to string in the form hh:mm:ss.s
 * AUTHOR : F.Rigaut, June 13 2002.
 * SEE ALSO: 
 */
{
  lt    = long(time);
  hh    = lt/3600;
  lt    = lt-hh*3600;
  mm    = lt/60;
  sec   = float(time)-hh*3600-mm*60;
  ts    = swrite(hh,mm,sec,format="%02i:%02i:%04.1f");
  return ts;
} 


/*********************/
/* GRAPHIC functions */
/*********************/

func colorbar(cmin, cmax,adjust=,levs=)
/* DOCUMENT colorbar
            colorbar, cmin, cmax
     draw a color bar to the right of the plot.  If CMIN and CMAX
     are specified, label the top and bottom of the bar with those
     numbers.
     adjust: x adjust. typically +/- 0.01 
     levs: number of ticks in color bar (plus one)
     upgraded 2007june02
   SEE ALSO: color_bar
 */
{
  if (adjust==[]) adjust=0.;
  cursys = plsys();

  get_style,landscape, systems, legends, clegends;

  left   = systems(cursys).viewport(2)+0.03+adjust;
  right  = systems(cursys).viewport(2)+0.05+adjust;
  bottom = systems(cursys).viewport(3);
  top    = systems(cursys).viewport(4);
  middle = (left+right)/2.;
  
  plsys, 0;
  pli, span(0,1,200)(-,), left, bottom, right, top, legend="";
  plg, [bottom,top,top,bottom],[right,right,left,left], closed=1,
    marks=0,color="fg",width=1,type=1,legend="";
  if (levs) {
    for (i=1;i<=(levs-1);i++) {
      y=bottom+(top-bottom)/levs*i;
      plg, [y,y],[left,right], marks=0,color="fg",width=1,type=1,legend="";
    }
  }
  plsys, cursys; 
  if (!is_void(cmin)) {
    plt, pr1(cmin), middle, bottom-0.005, justify="CT";
    plt, pr1(cmax), middle, top+0.005, justify="CB";
  }
}

// general equivalent (remove if you don't like them)
man=help;
%FILE% uuu.i
func uuu( arr )
/* DOCUMENT u = uuu( arr )

   A faster version of the 'uniq' function.

   There may be a problem for non-integer data types.
*/
{
   rra = shift(arr,1)
   d = rra - arr;
   d = shift(d,-1);
   d(1) = 1;
   return where(d);
}
%FILE% varfuncs.i
extern varfuncsdoc;
/* DOCUMENT varfuncs.i *******************************************

    Various functions - some intended for wavelet example

    2005-04-01/NJW

        e0      Integral -inf -> x[exp(-0.5*t*t)] / sqrt(2pi)
        e1      Integral -x -> x   [exp(-0.5*t*t)] / sqrt(2pi)
        expo    Shorthand for exponential function: exp(-0.5*(x/sigma)^2)
        h_int   Returns x*exp(-x*x/2)
        hxexp   Returns integral[0 to x] t*exp(-t*t/2)*dt
        sigmoid Returns 1/(1 + exp(-(x-x0)/lambda))
*********************************************/

/* Function expo */

func expo(x,sigma)
/* DOCUMENT res = expo(x,sigma)

   Shorthand for exponential function: exp(-0.5*(x/sigma)^2)
*/

{
   return exp(-0.5*(x/sigma)^2);
}

/* Function h_int */

func h_int(x)
/* DOCUMENT res = h_int(x)

   returns x*exp(-x*x/2)
*/

{
   return x * exp(-x*x/2);
}

/* Function hxexp */

func hxexp(x)
/* DOCUMENT res = hxexp(x)

   returns integral[0 to x] t*exp(-t*t/2)*dt
*/

{
   return 1.0 - exp(-0.5*x*x);
}

/* Function e0 */

func e0(x)
/* DOCUMENT res = e0(x)

   Integral -inf -> x[exp(-0.5*t*t)] / sqrt(2pi)
*/
{
   xnorm = 0.3989423;
   p     = 0.231642;
   b1    = 0.319382;
   b2    = -0.356564;
   b3    = 1.78148;
   b4    = -1.82126;
   b5    = 1.33027;

   if( is_scalar(x) ) x = [x];
   res = array(double,numberof(x));
   w = where( x < -5.0 );
   if( numberof(w) ) res(w) = 0.0;
   w = where( x >  5.0 );
   if( numberof(w) ) res(w) = 1.0;
   w = where( x >= -5.0 & x <= 5.0 );
   if( numberof(w) ) {
      a = x(w);
      v = where(a < 0.0 );
      u = where(a >= 0.0 );
      if( numberof(v) ) a(v) = -a(v);
      t = 1./(1. + p*a);
      z = xnorm * exp( -0.5 * a * a );
      t2 = t * t;
      t3 = t2 * t;
      y = z * (b1*t + b2*t2 + b3*t3 + b4*t2*t2 + b5*t2*t3);
      if( numberof(u) ) y(u) = 1.0 - y(u);
      res(w) = y;
   }
   return numberof(x) == 1 ? res(1) : res;
}

/* Function e1 */

func e1( x )
/* DOCUMENT res = e1( x )

   Integral -x -> x   [exp(-0.5*t*t)] / sqrt(2pi)
*/
{
   return e0(x) - e0(-x);
}

/* Function sigmoid */

func sigmoid( x, x0, lambda )
/* DOCUMENT y = sigmoid( x, x0, lambda )

    returns 1/(1 + exp(-(x-x0)/lambda))

    2008-04-25/NJW
*/
{
   if( is_void(lambda) ) lambda = 1.0;
   if( is_void(x0) ) x0 = 0.0;
   lambda = double(lambda);
   x0 = double(x0);
   arg = -(x-x0)/lambda;
   if( anyof(arg > 400.) ) {
      w = where(arg > 400.);
      m = where(arg <= 400.);
      res = double(x);
      s = is_scalar(x);
      if(s) res=[res];
      res(w) = 0.0;
      if( numberof(m) ) res(m) = 1.0/(1.0 + exp(-(x(m)-x0)/lambda));
      if(s) res=res(1);
      return res;
   }

   return 1.0/(1.0 + exp(-(x-x0)/lambda));

}

/* Function diomgis */

func diomgis( y, x0, lambda )
/* DOCUMENT x = diomgis( y, x0, lambda )

   returns  x0 - lambda*log((1-y)/y)

   i.e. the inverse of 'sigmoid'
*/
{
   if( anyof(y >= 1) || anyof(y <= 0) ) error,"DIOMGIS: y is outside limits";
   if( is_void(x0) ) x0 = 0.0;
   if( is_void(lambda) ) lambda = 1.0;
   x0 = double(x0);
   lambda = double(lambda);
   y = double(y);

   return x0 - lambda * log( (1-y) / y );

}

/* Function sigmoidab */

func sigmoidab( x, x0, lambda, a, b )
/* DOCUMENT y = sigmoidab(  x, x0, lambda, a, b )

   returns y = a + (b-a)*sigmoid(x,x0,lambda)
*/
{
   return a + (b-a)*sigmoid(x,x0,lambda);
}

/* Function badiomgis */

func badiomgis( y, x0, lambda, a, b )
/* DOCUMENT x = badiomgis( y, x0, lambda, a, b )

    Inverse function of sigmoidab
*/
{
   yhat = (y - a)/(b - a);
   return diomgis( yhat, x0, lambda );
}

/* Function guard */

func guard( x, a, b, c, d )
/* DOCUMENT xhat = guard( x, a, b, c, d )

    Returns scalar or array where:
       xhat = x for a <= x <= b
       xhat > c for x < a
       xhat < d for x > b

    such that xhat outside [a,b] is nicely connected to inside.

    Requirements:   c < a   AND   d > b
            AND     b > a   AND   d > c

    If 'c' or 'd' are given as void (omitted) then no action will
    be taken for the equivalent part.

    Working tool is 'sigmoid'
*/
{
   s = is_scalar(x);
   res = double(x);
   if(s) res = [res];

   // Deal with part between a and b

   if( is_void(a) ) a = min(res);
   if( is_void(b) ) b = max(res);

   w = where( x >= a & x <= b );
   nw = numberof(w);

   if( !is_void(c) && !is_void(d) ) {
      if( d <= c ) error," d <= c";
   }
   if( !is_void(c) ) {
      if( c >= a ) error," c >= a";
      w = where( x < a );
      nw = numberof(w);
      if( nw ) {
         dd = 2.*a - c;
         lambda = 0.5*(a - c);
         res(w) = sigmoidab( x(w), a, lambda, c, dd );
      }
   }
   if( !is_void(d) ) {
      if( d <= b ) error," d <= b";
      w = where( x > b );
      nw = numberof(w);
      if( nw ) {
         cc = 2.*b - d;
         lambda = 0.5*(d - b);
         res(w) = sigmoidab( x(w), b, lambda, cc, d );
      }
   }

   if(s) res = res(1);
   return res;

}
%FILE% virxobs.i
/***************************************************************
 *
 *     A virtual X-ray observatory
 *
 *  Prepare input to MT_RAYOR for an observation with user
 *  defined intensities and spectra.
 *
 *  A sky image is used as input to get the dimensions
 *  and coordinate system.
 *
 *  Two files are produced in the first step:
 *  k_image.fits and p1_image.fits
 *  for individual manipulation
 *
 *  The second step consists of storing these maps (images)
 *  in a sky spectral definition file (SSDF) called 'virSSDF.fits'.
 *
 *  Then the mt_rayor function 'mt_skyspec2skydef'
 *  can use it for building a sky definition file (SDF)
 *  that can be direct input to the simulating raytracing run (by mt_run).
 *
 *  Example:  'chandra_skyima.fits+1' is the original image.
 *
 *   > virxobs, "chandra_skyima.fits+1", "PL", 3.5e22
 *    [make changes to the two output files 'k_image.fits' and
 *     'p1_image.fits' according to what you want - don't change
 *     their names]
 *   > virxobs
 *     [combines 'k_image.fits' and 'p1_image.fits' to 'virSSDF.fits']
 *
 *  - now you have two options: with an already existing SDF file
 *    by name of 'skydef_main.fits' you can copy pointing etc. from it:
 *
 *   > mt_skyspec2skydef,"virSSDF.fits","skydef_vir.fits","skydef_main.fits", \
 *          fluxdir="/scratch/myown/fluxfiles"
 *     [this produces 'skydef_vir.fits']
 *
 *  - or you can define an independent SDF:
 *
 *   > mt_skyspec2skydef,"virSSDF.fits","skydef_vir_x.fits", 123.456, \
 *         23.456, 234.567, fraclim=0.1, exposure=1234.,e1=4., e2=80., \
 *         nchan=150,radius=0.1556,fluxdir="/scratch/myown/fluxfiles", \
 *         instrume="mt_rayor-2.5 sim",telescop="NuSTAR"
 *
 *   2010-10-08/NJW
 *
 ******************************************************************/

func virxobs( dol_skyimage, spectrcode, nh )
/* DOCUMENT virxobs, dol_skyimage, spectrcode, nh
            virxobs, dol_main_skydef

   dol_skyimage  :  template image
   spectrcode    :  spectral code  "PL", "TB", or "BB"
   nh            :  absorption column

   Step 1:
   When called with 3 arguments it will create maps for editing.

   Step 2:
   When called with no arguments the maps will be combined to a SSDF.

   NB: The FITS keywords (e.g. those for the sky coordinate system)
       are defined in the first step and no 'kwds_...'
       calls should be done before step 2 except for adding some
       extra keywords.
*/
{
   if( !is_void(dol_skyimage) ) {
      klist = "CRPIX1,CRVAL1,CDELT1,CTYPE1,";
      klist += "CRPIX2,CRVAL2,CDELT2,CTYPE2,";
      klist += "CD1_1,CD1_2,CD2_1,CD2_2,";
      klist += "CROTA2";

      ima = float(readfits(dol_skyimage));
      hdr = headfits(dol_skyimage);

      fits_copy_keys,hdr,list=klist,tokwds=1;
      kwds_set,"EXTNAME","NORM_MAP","name of this extension";
      kwds_set,"SC",spectrcode,"Spectral code";
      kwds_set,"NH",nh,"[/cm2] Absorption column";
      kwds_set,"DATA",ndate(3),"Date/time of creation";
      writefits,"k_image.fits",ima,clobber=1;
      kwds_set,"EXTNAME","P1MAP","name of this extension";
      writefits,"p1_image.fits",ima*0 + float(2.),clobber=1;
   } else {
      kima = readfits("k_image.fits[NORM_MAP]");
      khdr = headfits("k_image.fits[NORM_MAP]");
      p1ima = readfits("p1_image.fits[P1MAP]");
      p1hdr = headfits("p1_image.fits[P1MAP]");
      fits_copy_keys,khdr,tokwds=1;
      kwds_set,"EXTNAME","NORM_MAP","name of this extension";
      fh = writefits("virSSDF.fits",kima,clobber=1,cont=1);
      fits_copy_keys,p1hdr,tokwds=1;
      kwds_set,"EXTNAME","P1MAP","name of this extension";
      writefits,fh,p1ima;
   }
}
%FILE% wavelet.i
/* Wavelet examples */

#include Y_CODE+"romberg.i"
#include Y_CODE+"afits.i"

// Constructing the shape of the Mexican hat

r = span(0.,10.,100);
k = 3.0;
sig = 1.1; // Sigma of inner peak
SIG = 4.0; // Sigma of 'rim'
R = 10.0;
b = expo(R,sig);
B = expo(R,SIG);
f = k*(expo(r,sig) - b);
int_f = k*(sig*sig*hxexp(R/sig) - 0.5*R*R*b);
int_g = SIG*SIG*hxexp(R/SIG) - 0.5*R*R*B;
K = int_f / int_g;
g = K*(expo(r,SIG) - B);

hat = array(double,21,21);
d = distances(21,21,11,11);
w = where( d < R );
hat(w) = k*(expo(d(w),sig) - b) - K*(expo(d(w),SIG) - B);

// print,"Reading sky image ...";
// b = afits_getfarr("jmx2_sky_ima_006000480010.afits");

//b0 = random_n(511,511);
b0 = array(double,511,511);
b = add_peak( b0, 200.14, 300.56, 3.0, 1.1, 1.1 );
window,0;
disp, b;

print,"Making the FFT of kernel (hat) ...";
fk = fkernel( hat, 511, 511);

print,"Convolving ...";
c = fconvol( b, fk );

window,1;
disp,c;
%FILE% way.i
randomize; // set seed for random number depending on time

func way( input )
{

   tabel = "c:/yo/work/way_tabel.scm";
   ok_tekst = ["Godt klaret!", "Det er bare i orden"];
   lala_tekst = ["Ja, ja","Det er lala"];
   slemt_tekst = ["Nej, tag dig sammen!","Slut med kalorier!", \
                  "Mere motion - nu!"];
   start_dag = 4390.;
   start_masse = 84.;
   slut_dag = 4570.;
   slut_masse = 75.;
   slope = (slut_masse - start_masse)/(slut_dag - start_dag);

   nu = dattim2ijd(ndate(3));
   forventet_masse = start_masse + slope*(nu - start_dag);
   if( nu > 4570. ) forventet_masse = slut_masse;

   if( numberof(input) ) {
      masse = double(input);

      // skriv til tabel
      f = open(tabel,"a");
      write,f,format="%14.2f  %10.2f\n", nu, masse;
      close,f;
      forskel = masse - forventet_masse;
      if( forskel < -1. ) { // det er bare i orden
         idx = long(random()*numberof(ok_tekst)) + 1;
         write,format="%.1f kg under forventning, %s\n", abs(forskel), \
              ok_tekst(idx);
      } else if( forskel < 1. ) { // la la
         idx = long(random()*numberof(lala_tekst)) + 1;
         if( forskel < 0. ) {
            write,format="%.1f kg under forventning, %s\n", abs(forskel), \
                 lala_tekst(idx);
         } else {
            write,format="%.1f kg over forventning, %s\n", abs(forskel), \
                 lala_tekst(idx);
         }
      } else {
         idx = long(random()*numberof(slemt_tekst)) + 1;
         write,format="%.1f kg under forventning, %s\n", forskel, \
              slemt_tekst(idx);
      }
   } else { // Tegn diagram
      // hent forventning
      tforv = rscol(tabel,1,block=1,silent=1,nomem=1);
      mforv = rscol(tabel,2,block=1,silent=1,nomem=1);
      // hent sande tal
      tsand = rscol(tabel,1,block=2,silent=1,nomem=1);
      msand = rscol(tabel,2,block=2,silent=1,nomem=1);

      plot,tforv,mforv,yr=[min(mforv)-2.,max(mforv)+3.],color="green",thick=3;
      oplot,tsand,msand,color="red";
      oplot,tsand,msand,ps=24,fill=1,symsize=0.3,color="red";
   }
}
%FILE% wolter1.i
/* Equations for a Wolter I telescope system */

//  z i measured from final focal point
r1 = 300.;
z1 = 10000.;
f = 3000.;
//  coefficient for parabola
d = sqrt((z1 + 2*f)^2 + r1^2) - (z1 + 2*f);
write,format="d = %f\n", d;
// Now parabola fits together with hyperbola at z2
z2 = z1 - 500.;
r2 = sqrt(2*d*(z2+2*f) + d^2);
write,format="r2 = %f\n", r2;

// plot the parabola

z = span(-2*f, z1, 1000);
r = sqrt(2*d*(z+2*f) + d^2);
plot,z,r;
oplot,[-2*f,0],[0,0],ps=4;
oplot,[z2,z2],[0,r2],li=2;
oplot,[z1,z1],[0,r1],li=2;

// derive last parameter, a, for hyperbola

b = (z2+f)^2 + f^2 + r2^2;
a2_1 = 0.5*(b + sqrt(b^2 - 4*(z2+f)^2*f^2));
a2_2 = 0.5*(b - sqrt(b^2 - 4*(z2+f)^2*f^2));
write,format="a2_1 = %f, a2_2 = %f\n", a2_1, a2_2;
a_1 = sqrt(a2_1);
a_2 = sqrt(a2_2);

// test calculation of (r2,z2)

r2_1 = sqrt((z2+f)^2*((f^2-a_1^2)/a_1^2) - (f^2 - a_1^2));
r2_2 = sqrt((z2+f)^2*((f^2-a_2^2)/a_2^2) - (f^2 - a_2^2));
write,format="r2_1 = %f, r2_2 = %f\n", r2_1, r2_2;
z = span(0,z1,1000);
//r = sqrt((z+f)^2*((f^2-a_1^2)/a_1^2) - (f^2 - a_1^2));
//oplot,z,r,color="red";
r = sqrt((z+f)^2*((f^2-a_2^2)/a_2^2) - (f^2 - a_2^2));
oplot,z,r,color="blue";
%FILE% wsize_setup.i
/* Function wsize_setup */

func wsize_setup( pane=, vport=, xvport=, yvport= )
/* DOCUMENT wsize_setup, pane=, vport=, xvport=, yvport=

   Viewport setup.
   Defines a wsize.gs file in 'GISTDIR' with custom viewport.

   Keywords:
      pane      window number. Default 0.

      vport     The exterior frame defined as 'viewport' in NDC
                coordinates [xmin, xmax, ymin, ymax]
                Default: [0.1, 0.7, 0.1, 0.95]
      xvport    Defines the first two elements of 'viewport' and
                leaves the other two unchanged (as default).
      yvport    Defines the last two elements of 'viewport' and
                leaves the other two unchanged (as default).


   2011-06-10/NJW
*/
{

   if( is_void(pane) ) pane = 0;
   if( !is_void(vport) && !is_void(xvport) ) error,"vport and xvport are not both allowed";
   if( !is_void(vport) && !is_void(yvport) ) error,"vport and yvport are not both allowed";

   if( is_void(vport) ) {
      vport = [0.1, 0.7, 0.1, 0.95];
   } else {
      if( numberof(vport) != 4 ) error,"Wrong dimensionality of vport";
   }
   if( !is_void(xvport) ) {
      if( numberof(xvport) != 2 ) error,"Wrong dimensionality of xvport";
      vport(1:2) = xvport;
   }
   if( !is_void(yvport) ) {
      if( numberof(yvport) != 2 ) error,"Wrong dimensionality of yvport";
      vport(3:4) = yvport;
   }

   gs = rdfile(GISTDIR+"boxed_tpl.gs");

   // Find last occurrence of the word 'viewport'
   w = where(strmatch(gs,"viewport"))(0);
   // the new viewport must be written as
   //   viewport={ 0.1234,0.6543,0.2345,0.8765 } ,
   line = swrite(format=" viewport = { %.4f,  %.4f,  %.4f,  %.4f } ,", vport(1), vport(2), vport(3), vport(4));
   gs(w) = line;

   write_slist,GISTDIR+"wsize.gs", gs;

   window,pane,style="wsize.gs";

}

%FILE% xfit_lmfit.i
/* Function xfit_lmfit */

func xfit_lmfit( &p_res, cont= )
/* DOCUMENT chi2_red = xfit_lmfit( >p_res, cont= )

  Fitting a model to an observed spectrum by using 'lmfit'.
  If keyword 'cont' is set then p_res are the initial values
  for the fitting process.
  Freezing/thawing of a variable can be done with functions
  xfit_freeze and xfit_thaw resp.

    NJW/2002-06-28
    2008-03-14/NJW Translated to Yorick
    2011-05-11/NJW updated to be more general

*/
{

// ynclude = xfit_package.externs_fit
  extern  Chi2min,       Rate_model,     Frozen_value,  Nh_bf,         Param1_bf, \
          Chi2red,       Ehi,           N_freedom,     Normfit,       Spectrcode, \
          Const,         Elo,           Nh,            Param1,        Sx, \
          Const_bf,      Freeze,        Emin_std,      Emax_std, Logflag, Logfilename, \
          Rate, Stat_err;
// yxclude =

   Normfit = 0;

/*
 *********     BEGIN  FITTING  PROCESS    *******************
 */

   weight = array(0.0,numberof(Rate));
   w = where( Stat_err > 0.0 );
   weight(w) = 1./Stat_err(w)^2;

   fit = indgen(3);
   if( Freeze ) {
      fit = rem_elem(fit, Freeze);
      p_res(Freeze) = Frozen_value;
   }

   lmfit_res = lmfit( xfit_rate, dummy, p_res, Rate, weight, fit=fit );

   //  this call will silently update the 'Rate_model' external
   //  in 'xfit_rate'

/*
 *********     END  OF  FITTING   PROCESS    *******************
 */

   //   Present the results

   if( Logflag ) {
      fh = open( Logfilename, "a" );
      write,fh,format="// LM Fitting ...%s","\n";
   }

   N_freedom = numberof(Rate_model) - 3 + numberof(Freeze);

   Chi2min = xfit_chi2(p_res);
   chi2min_lm = lmfit_res.chi2_last;
   Chi2red = Chi2min/N_freedom;
   write,format="Chi2min    =   %10.4f\n", Chi2min;
   write,format="Chi2min_lm =   %10.4f\n", chi2min_lm;
   write,format="Chi2,red =   %10.4f\n", Chi2red;
   if( Logflag ) write,fh,format="// Chi2,red =   %10.4f\n", Chi2red;

   wstr = swrite(format="Constant =    %12.3e",p_res(1));
   if( !is_void(Freeze) ) {
      if( Freeze == 1 ) wstr += " (frozen)";
   }
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   wstr = swrite(format="Param1   =    %10.4f",p_res(2));
   if( !is_void(Freeze) ) {
      if( Freeze == 2 ) wstr += " (frozen)";
   }
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   wstr = swrite(format="Nh/1e22  =    %10.4f",p_res(3));
   if( !is_void(Freeze) ) {
      if( Freeze == 3 ) wstr += " (frozen)";
   }
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   // Setting externals with best fit parameters

   Const_bf = Const = p_res(1);
   Param1_bf = Param1 = p_res(2);
   Nh_bf = Nh = p_res(3)*1.e22;

   //   Get the photon spectrum and source intensity

   if( Spectrcode  ==  "DF" ) {
      flux = xfit_photspec(p_res);
      dum = max(flux);
      index = where(dum==flux)(1);
      Sx = dum * (Ehi(index)-Elo(index)) * 1.6e-9;
      write,format="Sx          = %13.4e erg/cm2/s\n", Sx;
      if( Logflag ) write,fh,format="// Sx          = %13.4e erg/cm2/s\n", Sx;
   } else {
      sx_eline = spanl(Emin_std,Emax_std,200);
      flux = xfit_photspec(p_res, eline=sx_eline);
      Sx = sflux( Emin_std, Emax_std, sx_eline, flux);
      write,format="Sx(%.0f-%.0f keV) = %13.4e erg/cm2/s\n", Emin_std, Emax_std, Sx;
      if( Logflag ) write,fh,format="// Sx(%.0f-%.0f keV) = %13.4e erg/cm2/s\n", Emin_std, Emax_std, Sx;
   }

   if( Logflag ) close, fh;

   return Chi2red;

}

%FILE% xfit_package-2.1.i
extern xfitdoc;
/* DOCUMENT ************************************************************
 *
 *    Functions for spectral modelling and fitting. PHA II spectral files
 *    are assumed.
 *
 *      xfit_anamin  analyze range of parameters for display
 *      xfit_bins    change detector bins to use in fit
 *      xfit_chi2    return Chi2 for at given parameter set
 *      xfit_chi2_1d_1
 *      xfit_chi2_1d_2
 *      xfit_chi2_1d_angle
 *      xfit_data    read spectral data from PHAII file + RMF
 *      xfit_ebase   set the powerlaw energy base (Ebase)
 *      xfit_fakeit  produces a simulated count spectrum
 *      xfit_fit     do the fitting using 'amoeba'
 *      xfit_freeze  freeze a given parameter to a value
 *      xfit_init    needs input from an observation
 *      xfit_lmfit   do the fitting using 'lmfit'
 *      xfit_log     define the log file
 *      xfit_model   sets the spectral model (Spectrcode)
 *      xfit_nfit    get the normalization
 *      xfit_pargrid find chi2 in a 2D grid
 *      xfit_photspec  define source spectrum from existing parameters
 *      xfit_plot    plotting results
 *      xfit_read    load basic information: RMF, ARF (for xfit_fakeit)
 *      xfit_show    Show variables in memory
 *      xfit_thaw    Thaw a given parameter (previously frozen)
 *      xfit_title   set the title for plots
 *      xfit_tune    Adjust statistical errors to chi2red = 1
 *
 *
 *      xfit_nustar_fakeit   fake a NuStar observation
 *      xfit_nustar_init  set up NuStar fitting
 *      xfit_nustar_plot  plotting NuStar results
 *
 *  Version 2.1, initiated 2012-03-28/NJW to rebin to sensible number of counts in each bin
 *      Version date: 2012-04-13/NJW
 *
 ***********************************************************************/

// setting the name of the parameter file (mainly for xfit_fakeit)

Parfilename = "xfit.par";

// setting the standard energy limits for the sflux calculation

Emin_std = 2.; // keV
Emax_std = 10.; // keV

Freeze = array(0,3);
Frozen_value = array(double,3);

// setting the default Ebase value

//+ Ebase = 5.; // [keV] Adequate value for LOFT WFC

Ebase = 1.0; // Commonly accepted value

/* Function xfit_pset */

func xfit_pset
/* DOCUMENT  xfit_pset

   is an interactive function for setting various
   external variables such as
      Emin_std, Emax_std, Ebase

*/
{
   extern Emin_std, Emax_std, Ebase;

   write,format="(1) Emin_std : %10.3f keV\n", Emin_std;
   write,format="(2) Emax_std : %10.3f keV\n", Emax_std;
   write,format="(3) Ebase    : %10.3f keV\n", Ebase;

   ans = strsplit(rdline(prompt="Enter number and new value : ... ")," ");
   n = atoi(ans(1));
   v = atof(ans(2));
   if( n == 1 ) {
      Emin_std = v;
      write,format="Emin_std : %10.3f keV\n", Emin_std;
   } else if( n == 2 ) {
      Emax_std = v;
      write,format="Emax_std : %10.3f keV\n", Emax_std;
   } else if( n == 3 ) {
      Ebase = v;
      write,format="Ebase    : %10.3f keV\n", Ebase;
   } else write,"Bad number, no action ...";

}

/* Function xfit_log */

func xfit_log( logfilename, reset= )
/* DOCUMENT xfit_log, logfilename, reset=
     or     xfit_log

    First version: A logging to 'logfilename' will be continued unless
                      the keyword 'reset' has been set.
    Second version: Terminates the logging

*/
{
// ynclude = xfit_package.externs_log
  extern  Logfilename,  Logflag;
// yxclude =

   if( is_void(logfilename) ) {
      Logflag = 0;
   } else {
      Logfilename = logfilename;
      Logflag = 1;
      cm = reset ? "w" : "a";
      f = open(logfilename,cm);
      write,f,format="//  Log file for xfit_package started %s\n", ndate(3);
      write,f,format="//    Errors are 3sigma i.e. 99%% confidenc%s\n","e";
      write,f,format="// %s\n", "colname = const";
      write,f,format="// %s\n", "colname = d_const";
      write,f,format="// %s\n", "colname = param1";
      write,f,format="// %s\n", "colname = d_param1";
      write,f,format="// %s\n", "colname = nh";
      write,f,format="// %s\n", "colname = d_nh";
      write,f,format="// %s\n", "colname = chi2red";
      write,f,format="// %s\n", "colname = specfile";
      close,f;
   }
}

/* Function xfit_init */

func xfit_init( dol_of_spec, dol_of_bkg, num_spec=, num_spec_bkg=, bins=, title=, model=, ebase= )
/* DOCUMENT xfit_init( dol_of_spec, dol_of_bkg, num_spec=, num_spec_bkg=, bins=, title=, model=, ebase= )

  Prepare fitting an observed X-ray spectrum from j_src_spectra or similar.
    Keywords:
         num_spec        row number of the spectrum to use (default: 1)
         num_spec_bkg    row number of the bkg spectrum to use (default: 1)
         bins            array with spectral bins to use in plots and fits
         title           plot title
         model           spectral model to use (PL, TB, BB, DF)
         ebase           Energy base for powerlaw spectrum

   Steps: xfit_init defines the energy channels, reads the spectrum,
                    defines the bins to use, reads the line energies,
                    reads and rebins the redistribution matrix, sets
                    the spectral model.
          xfit_fit  executes the fitting (no arguments)

          xfit_plot plots the data with the best fit

   NJW/2002-06-28
   2008-03-14/NJW translated from IDL to Yorick
   2011-05-10/NJW updated to get SPECRESP + ARF from header in spectral file

*/
{
   local specfile, extno, exposure, bexposure;
   local rate, stat_err, brate, bstat_err, rdm, brdm;

   //   Setup the common areas

// ynclude = xfit_package.externs_init
  extern  Arf,            E_max_orig,     Ehi,            Matrix_orig,    Spectrcode, \
          Dol_of_bkg,     E_min,          Eline,          Plottitle,      Stat_err, \
          Dol_of_spec,    E_min_orig,     Elo,            Rate,           Stat_err_orig, \
          E_max,          Ebase,          Matrix,         Rate_orig, Exposure;
// yxclude =

   if( !is_void(dol_of_spec) ) {
      get_exten_no, dol_of_spec, specfile, extno;
      if( !file_test(specfile) ) {
         write,format="Sorry, %s cannot be found\n", specfile;
         return;
      }
      Dol_of_spec = dol_of_spec;
   }
   if( !is_void(dol_of_bkg) ) {
      get_exten_no, dol_of_bkg, specfile, extno;
      if( !file_test(specfile) ) {
         write,format="Sorry, %s cannot be found\n", specfile;
         return;
      }
      Dol_of_bkg = dol_of_bkg;
   }
   Ebase = is_void(ebase) ? 1.0 : double(ebase);
   if( is_void(num_spec) ) num_spec = 1;
   if( is_void(num_spec_bkg) ) num_spec_bkg = 1;

   if( !is_void(dol_of_spec) ) { // Assume already known if not given

      if( is_void(title) ) {
         Plottitle = "";
         read,prompt="Enter the plot title: ... ",format="%s", Plottitle;
      } else {
         Plottitle = title;
      }

      //   Get the spectral data

      write,"Getting spectral data ...";
      type = j_get_src_spectrum( dol_of_spec, num_spec, rate, stat_err, rdm, exposure);
      Exposure = exposure;
      if( type == 1 ) write,"Warning! Spectrum flagged as BKG";

      //  Get the background spectrum if given as argument
      //    and do the subtraction with proper error assignment

      if( !is_void(dol_of_bkg) ) {
         write,"Getting background data ...";
         btype = j_get_src_spectrum( dol_of_bkg, num_spec_bkg, brate, bstat_err, brdm, bexposure);
         if( !near( bexposure, exposure, 0.99 ) ) {
            write,"Warning! BKG exposure differs from net exposure";
         }
         if( type != 1 ) write,"Warning! Bkg spectrum flagged as NET or TOTAL";
         rate -= brate;
         stat_err = sqrt(stat_err^2 + bstat_err^2);
      }

      Rate_orig = Rate = rate;
      Stat_err_orig = Stat_err = stat_err;

   }

   Matrix_orig = Matrix = *rdm.rdm;
   Elo = *rdm.energ_lo;
   Ehi = *rdm.energ_hi;
   Eline = sqrt(Elo * Ehi);
   Arf = *rdm.arf;
   E_min_orig = E_min = *rdm.e_min;
   E_max_orig = E_max = *rdm.e_max;

   //   Limit the spectral bins if requested

   if( !is_void(bins) ) xfit_bins, bins;

   //   Define the spectral model

   if( !is_void(model) ) {
      Spectrcode = strupcase(strtrim(model));
   } else {
      Spectrcode = "";
      while( Spectrcode != "PL" && Spectrcode != "TB" && Spectrcode != "BB" && Spectrcode != "DF" ) {
         read,prompt="What is the spectral model? (PL,TB,BB,DF) : ... ", \
               format="%s",Spectrcode;
         Spectrcode = strupcase(strtrim(Spectrcode));
      }
   }


}

/* Function xfit_data */

func xfit_data( dol_of_spec, dol_of_bkg, num_spec=, num_spec_bkg= )
/* DOCUMENT xfit_data, dol_of_spec, dol_of_bkg, num_spec=, num_spec_bkg=

  Prepare fitting an observed X-ray spectrum from j_src_spectra or similar.
    Keywords:
         num_spec        row number of the spectrum to use (default: 1)
         num_spec_bkg    row number of the bkg spectrum to use (default: 1)

   The detector energy bin selection is reset to all (can be updated with
                         'xfit_bins').

   Steps: xfit_data reads the spectrum and the associated anchor file and
                    RMF data.
          xfit_fit  executes the fitting (no arguments)

          xfit_plot plots the data with the best fit

   2011-05-13/NJW

*/
{
   local specfile, bkgfile, extno;
   local rate, stat_err, brate, bstat_err, rdm, brdm, exposure, bexposure;

   //   Setup the externals

// ynclude = xfit_package.externs_data
  extern  Arf,            E_max,          Ebase,          Matrix,         Rate_orig, \
          Bins,           E_max_orig,     Ehi,            Matrix_orig,    Specfile, \
          Dol_of_bkg,     E_min,          Eline,          Plottitle,      Stat_err, \
          Dol_of_spec,    E_min_orig,     Elo,            Rate,           Stat_err_orig, \
          Exposure;
// yxclude =

   if( !is_void(dol_of_spec) ) {
      get_exten_no, dol_of_spec, specfile, extno;
      if( !file_test(specfile) ) {
         write,format="Sorry, %s cannot be found\n", specfile;
         return;
      }
      Dol_of_spec = dol_of_spec;
   }
   if( !is_void(dol_of_bkg) ) {
      get_exten_no, dol_of_bkg, bkgfile, extno;
      if( !file_test(bkgfile) ) {
         write,format="Sorry, %s cannot be found\n", bkgfile;
         return;
      }
      Dol_of_bkg = dol_of_bkg;
   }
   Specfile = fullpath(specfile);
   Ebase = 1.0; // default setting
   Plottitle = specfile;
   if( is_void(num_spec) ) num_spec = 1;
   if( is_void(num_spec_bkg) ) num_spec_bkg = 1;

   //   Get the spectral data

   write,"Getting spectral data ...";
   type = j_get_src_spectrum( dol_of_spec, num_spec, rate, stat_err, rdm, exposure);
   Exposure = exposure;
   if( type == 1 ) write,"Warning! Spectrum flagged as BKG";

   //  Get the background spectrum if given as argument
   //    and do the subtraction with proper error assignment
   //    But only if spectral data are designated "TOTAL" (type == 2)

   if( !is_void(dol_of_bkg) && type == 2 ) {
      write,"Getting background data ...";
      btype = j_get_src_spectrum( dol_of_bkg, num_spec_bkg, brate, bstat_err, brdm, bexposure);
      if( !near( bexposure, exposure, 0.99 ) ) {
         write,"Warning! BKG exposure differs from net exposure";
      }
      if( type != 1 ) write,"Warning! Bkg spectrum flagged as NET or TOTAL";
      rate -= brate;
      stat_err = sqrt(stat_err^2 + bstat_err^2);
   }

   Rate_orig = Rate = rate;
   Stat_err_orig = Stat_err = stat_err;
   Bins = indgen(numberof(rate));

   Matrix_orig = Matrix = *rdm.rdm;
   Elo = *rdm.energ_lo;
   Ehi = *rdm.energ_hi;
   Eline = sqrt(Elo * Ehi);
   Arf = *rdm.arf;
   E_min_orig = E_min = *rdm.e_min;
   E_max_orig = E_max = *rdm.e_max;

}

/* Function xfit_model */

func xfit_model( model )
/* DOCUMENT xfit_model, spectrcode
    or      xfit_model

      Can be PL, TB, BB, or DF
*/
{
// ynclude = xfit_package.externs_model
  extern  Spectrcode;
// yxclude =

   //   Define the spectral model

   if( !is_void(model) ) {
      Spectrcode = strupcase(strtrim(model));
   } else {
      Spectrcode = "";
      while( Spectrcode != "PL" && Spectrcode != "TB" && Spectrcode != "BB" && Spectrcode != "DF" ) {
         read,prompt="What is the spectral model? (PL,TB,BB,DF) : ... ", \
               format="%s",Spectrcode;
         Spectrcode = strupcase(strtrim(Spectrcode));
      }
   }
}

/* Function xfit_fit */

func xfit_fit( &p_res, cont= )
/* DOCUMENT chi2_red = xfit_fit( >p_res, cont= )

  Fitting a model to an observed spectrum.
  If keyword 'cont' is set then p_res are the initial values
  for the fitting process.
  Freezing/thawing of a variable can be done with functions
  xfit_freeze and xfit_thaw resp.

    NJW/2002-06-28
    2008-03-14/NJW Translated to Yorick
    2011-05-11/NJW updated to be more general

*/
{

// ynclude = xfit_package.externs_fit
  extern  Chi2min,       Rate_model,     Frozen_value,  Nh_bf,         Param1_bf, \
          Chi2red,       Ehi,           N_freedom,     Normfit,       Spectrcode, \
          Const,         Elo,           Nh,            Param1,        Sx, \
          Const_bf,      Freeze,        Emin_std,      Emax_std, Logflag, Logfilename, \
          Rate, Stat_err;
// yxclude =

   Normfit = 0;

/*
 *********     BEGIN  FITTING  PROCESS    *******************
 */

   // Define weights

   m = where( Stat_err <= 0.0 );
   if( numberof(m) ) {
      write,"Warning - "+itoa(numberof(m))+" stat errs are zero or negative";
      Stat_err(m) = 1.;
   }
   weights = 1./Stat_err^2;

   p = [1.,1.,1.];
   if( cont && numberof(p_res) == 3 ) p = p_res;

   p_to_fit = [];
   if( Freeze(1) ) p(1) = Frozen_value(1);
   else grow,p_to_fit,1;
   if( Freeze(2) ) p(2) = Frozen_value(2);
   else grow,p_to_fit,2;
   if( Freeze(3) ) p(3) = Frozen_value(3);
   else grow,p_to_fit,3;

   resfit = lmfit( xfit_rate, dummy, p, Rate, weights, fit=p_to_fit );
   p_res = p;

   write,format="resfit.neval = %i\n", resfit.neval;
   write,format="resfit.niter = %i\n", resfit.niter;
   write,format="resfit.chi2_last = %f\n", resfit.chi2_last;

   //  this call will silently update the 'Rate_model' external
   //  in 'xfit_chi2'

/*
 *********     END  OF  FITTING   PROCESS    *******************
 */

   //   Present the results

   if( Logflag ) {
      fh = open( Logfilename, "a" );
      write,fh,format="// Fitting ...%s","\n";
   }

   N_freedom = numberof(Rate_model) - 3 + Freeze(sum);

   Chi2min = xfit_chi2(p_res);
   Chi2red = Chi2min/N_freedom;
   write,format="Chi2,red =   %10.4f\n", Chi2red;
   if( Logflag ) write,fh,format="// Chi2,red =   %10.4f\n", Chi2red;

   wstr = swrite(format="Constant =    %12.3e",p_res(1));
   if( Freeze(1) ) wstr += " (frozen)";
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   wstr = swrite(format="Param1   =    %10.4f",p_res(2));
   if( Freeze(2) ) wstr += " (frozen)";
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   wstr = swrite(format="Nh/1e22  =    %10.4f",p_res(3));
   if( Freeze(3) ) wstr += " (frozen)";
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   // Setting externals with best fit parameters

   Const_bf = Const = p_res(1);
   Param1_bf = Param1 = p_res(2);
   Nh_bf = Nh = p_res(3)*1.e22;

   //   Get the photon spectrum and source intensity

   if( Spectrcode  ==  "DF" ) {
      flux = xfit_photspec(p_res);
      dum = max(flux);
      index = where(dum==flux)(1);
      Sx = dum * (Ehi(index)-Elo(index)) * 1.6e-9;
      write,format="Sx          = %13.4e erg/cm2/s\n", Sx;
      if( Logflag ) write,fh,format="// Sx          = %13.4e erg/cm2/s\n", Sx;
   } else {
      sx_eline = spanl(Emin_std,Emax_std,200);
      flux = xfit_photspec(p_res, eline=sx_eline);
      Sx = sflux( Emin_std, Emax_std, sx_eline, flux);
      write,format="Sx(%.0f-%.0f keV) = %13.4e erg/cm2/s\n", Emin_std, Emax_std, Sx;
      if( Logflag ) write,fh,format="// Sx(%.0f-%.0f keV) = %13.4e erg/cm2/s\n", Emin_std, Emax_std, Sx;
   }

   if( Logflag ) close, fh;

   return Chi2red;

}

/* Function xfit_nfit */

func xfit_nfit( &p_res )
/* DOCUMENT chi2_red = xfit_nfit( >p_res )

  Fitting normalization for a model to an observed spectrum
  i.e. only one free parameter.

  p_res is both input and output
  p(1) will be calculated
  p(2) is Photon Index
  p(3) is NH - absorption column in 1e22 cm-2

    2008-08-20/NJW

*/
{

// ynclude = xfit_package.externs_nfit
  extern  Chi2min,     Const_bf,    Elo,         Nh_bf,       Param1_bf,   Stat_err, \
          Chi2red,     Rate_model,   N_freedom,   Normfit,     Rate,        Sx, \
          Const,       Ehi,         Nh,          Param1,      Spectrcode, Emin_std, Emax_std;
// yxclude =


   p_res(1) = 1.0;
   Normfit = 1;

   c2 = xfit_chi2( p_res );

   p_res(1) = sum((Rate/Stat_err)^2) / sum(Rate_model*Rate/Stat_err^2);

   //   Present the results

   N_freedom = numberof(Rate_model) - 1;

   Chi2min = xfit_chi2(p_res);
   // This call updates the external variable 'Rate_model'

   Chi2red = Chi2min/N_freedom;
   write,format="Chi2,red =   %10.4f\n", Chi2red;

   write,format="Constant =    %10.4f\n",p_res(1);
   write,format="Param1   =    %10.4f (frozen)\n",p_res(2);
   write,format="Nh/1e22  =    %10.4f (frozen)\n",p_res(3);

   // Defining the best fit parameters

   Const_bf = Const = p_res(1);
   Param1_bf = Param1 = p_res(2);
   Nh_bf = Nh = p_res(3)*1.e22;

   //   Get the photon spectrum and source intensity

   if( Spectrcode  ==  "DF" ) {
      flux = xfit_photspec(p_res);
      dum = max(flux);
      index = where(dum==flux)(1);
      Sx = dum * (Ehi(index)-Elo(index)) * 1.6e-9;
      write,format="Sx          = %13.4e erg/cm2/s\n", Sx;
   } else {
      sx_eline = spanl(Emin_std,Emax_std,200);
      flux = xfit_photspec(p_res, eline=sx_eline);
      Sx = sflux( Emin_std, Emax_std, sx_eline, flux);
      write,format="Sx(%.0f-%.0f keV) = %13.4e erg/cm2/s\n", Emin_std, Emax_std, Sx;
   }

   return Chi2red;

}

/* Function xfit_chi2 */

func xfit_chi2( p )
/* DOCUMENT res = xfit_chi2( p )

  Fit function that returns Chi2 for( a given set of parameters
  in array "p":  (norm, param1, nh/1.e22)

  Side effect:  Updates the external 'Rate_model' !

   NJW/2002-06-28
   2008-03-14/NJW Translated to Yorick
*/
{

   if( is_void(p) ) {
      write,"Syntax: chi2 = xfit_chi2(p)";
      return [];
   }
   if( numberof(p) !=  3 ) {
      write,"xfit_chi2 must be called with 3 element array";
      return [];
   }

   //   Define the externals

// ynclude = xfit_package.externs_chi2
  extern  Arf,        Ehi,        Elo,        Matrix,     Rate,       Stat_err, \
          Rate_model;
// yxclude =

   //   Generate the input spectrum

   flux = xfit_photspec(p);

   line_counts = flux * (Ehi - Elo) * Arf;
   Rate_model = Matrix(,+)*line_counts(+);

   c2 = chi2( Rate_model, Rate, Stat_err );

   return c2;

}

/* Function xfit_rate */

func xfit_rate( dummy, p, outfile= )
/* DOCUMENT res = xfit_rate( dummy, p, outfile= )

  Fit function that returns the model rate for a given set of parameters
  in array "p":  (norm, param1, nh/1.e22)
  'dummy' is an argument required by lmfit - not used here.

  Used as fitting function in 'lmfit' (xfit_lmfit)

  Side effect:  Updates the external 'Rate_model' !

   A FITS output file may be produced by setting keywork 'outfile' to a valid
   filename string.

   2011-09-15/NJW
*/
{

   //   Define the externals

// ynclude = xfit_package.externs_chi2
  extern  Arf,        Ehi,        Elo,        Matrix,    Rate_model, \
          E_min, E_max;
// yxclude =

   //   Generate the input spectrum

   line_counts = xfit_photspec(p) * (Ehi - Elo) * Arf;
   Rate_model = Matrix(,+)*line_counts(+);

   if( typeof(outfile) == "string" ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date/time of file production";
      kwds_set,"ORIGIN","xfit_package-2.1{xfit_rate}","Software";
      for( i = 1; i <= numberof(p); i++ ) {
         kwds_set,"PARAM"+itoa(i),p(i),"Parameter value";
      }
      wrmfitscols, outfile, "E_MIN", E_min, "E_max", E_max, "RATE", Rate_model;
   }

   return Rate_model;

}

/* Function xfit_nustar_fakeit */

func xfit_nustar_fakeit(a)
/* DOCUMENT xfit_nustar_fakeit


   NJW/2002-06-28
   2008-03-14/NJW Translated to Yorick
   2008-05-22/NJW
*/
{

   //   Define the externals

// ynclude = xfit_package.externs_nustar_fakeit
  extern  Arf,            Countspec_err,  Elo,            Nh,             Rate, \
          Const,          Ehi,            Exposure,       Param1,         Stat_err, \
          Countspec,      Eline,          Matrix, \
            Emin_std, Emax_std, Photonspec;
// yxclude =

   p = array(double,3);

   Const = 1.0; Param1 = 1.0; nh = 1.0;
   read,prompt="Enter constant : ... ",format="%f", Const;
   read,prompt="Enter param1   : ... ",format="%f", Param1;
   read,prompt="Enter NH/1.e22 : ... ",format="%f", nh;
   Exposure = 1.0;
   read,prompt="Enter exposure : ... ",format="%f", Exposure;


   p(1) = Const;
   p(2) = Param1;
   p(3) = nh;
   Nh = p(3) * 1.e22;

   //   Generate the input spectrum

   Photonspec = xfit_photspec(p);
   write,format="Sflux %.0f-%.0f keV = %12.3e erg/cm2/s\n", \
              Emin_std, Emax_std, sflux(Emin_std,Emax_std,Eline, Photonspec);

   // Note the difference between 'Countspec' that is the observed (or
   // simulated) number of counts, whereas 'Rate_model' is the result of
   // the current spectral parameter values.

   line_counts = Photonspec * (Ehi - Elo) * Arf;
   Countspec = (Matrix(,+)*line_counts(+))*Exposure;
   countspec_err = sqrt(Countspec);
   Countspec += random_n(numberof(Countspec))*countspec_err;
   Rate = Countspec / Exposure;
   Stat_err = countspec_err / Exposure;

   write,"Rate and Stat_err are now prepared for e.g. plotting";

}

/* Function xfit_nustar_init */

func xfit_nustar_init( dol_of_spec, num_spec )
/* DOCUMENT xfit_nustar_init( dol_of_spec, num_spec )

  prepare fitting an observed X-ray spectrum from j_src_spectra

   2008-05-22/NJW cloned from xfit_init.i

*/
{

   //   Setup the common areas

// ynclude = xfit_package.externs_nustar_init
  extern  Arf,         E_min,       Eline,       Matrix,      Spectrcode,  Stat_err, \
          E_max,       Ehi,         Elo,         Rate;
// yxclude =

   if( is_void(num_spec) ) num_spec = 1;
   number = num_spec;

   //   Set the rebinning i.e. avoid first 30 channels
   //   and last 56

   //+ rebin = indgen(200-30) + 30;

   //   Get the spectral data

   
   if( !is_void( dol_of_spec ) ) {
      j_get_src_spectrum, dol_of_spec, number, rate, stat_err;
      Rate = rate(rebin);
      Stat_err = stat_err(rebin);
   }


   //   Get the RMF data

   //+ j_get_pi_ebds, e_min, e_max;
   rmfname = "/home/njw/nustar/rmf.fits";
   arfname = "/home/njw/nustar/ARF_onaxis.fits";

   e_min = rdfitscol(rmfname+"+2","e_min");
   e_max = rdfitscol(rmfname+"+2","e_max");
   rebin = indgen(numberof(e_min));

   E_min = e_min(rebin);
   E_max = e_max(rebin);

   Elo = rdfitscol(rmfname+"[MATRIX]","ENERG_LO");
   Ehi = rdfitscol(rmfname+"[MATRIX]","ENERG_HI");
   Eline = sqrt(Elo*Ehi);
   matrix = rdfitscol(rmfname+"[MATRIX]","MATRIX");
   Arf = rdfitscol(arfname+"+1","SPECRESP");
   elo_Arf = rdfitscol(arfname+"+1","ENERG_LO");
   ehi_Arf = rdfitscol(arfname+"+1","ENERG_HI");
   e_Arf = 0.5*(elo_Arf + ehi_Arf);
   Arf = interp( Arf, e_Arf, Eline);

   Matrix = matrix(rebin,*);

   //   Define the spectral model

   Spectrcode = "";
   while( Spectrcode != "PL" && Spectrcode != "TB" && Spectrcode != "DF" ) {
      read,prompt="What is the spectral model? (PL,TB,DF) : ... ", \
            format="%s",Spectrcode;
      Spectrcode = strupcase(strtrim(Spectrcode));
   }


}

/* Function xfit_nustar_plot */

func xfit_nustar_plot( a )
/* DOCUMENT xfit_nustar_plot

  plots the result of rfitting
    Default is energy plot.

   NJW/2002-06-28
   2008-05-16/NJW translated to Yorick
*/
{

   //   Define the common areas

// ynclude = xfit_package.externs_nustar_plot
  extern  E_max,      E_min,      Plottitle,  Rate,       Stat_err;
// yxclude =

   window,0,style="boxed.gs";

   REBIN = 75;
   z = array(3,15); grow, REBIN, z;
   z = array(6,40); grow, REBIN, z;
   z = array(10,20); grow, REBIN, z;
   z = array(20,20); grow, REBIN, z;
   z = array(30,20); grow, REBIN, z;

   local eb1, eb2, orate, ostat_err;
   specrebinning, E_min, E_max, Rate, Stat_err, REBIN, eb1, eb2, orate, ostat_err;
   //+ w = where( Rate > Stat_err & Stat_err > 0.0 );
   //+ ymin = min((Rate(w)-Stat_err(w))/(E_max(w)-E_min(w)));
   //+ ymax = max((Rate(w)+Stat_err(w))/(E_max(w)-E_min(w)));
   //+ dataplot, 0.5*(E_min+E_max), Rate/(E_max-E_min), Stat_err/(E_max-E_min), \
   //+     yr=[ymin,ymax], xr=[5,80],  xbar=1,itype=3, \
   //+     xtitle="Energy [keV]",ytitle="Cts /s /keV",title=esc_underscore(Plottitle);
   w = where( orate > ostat_err & ostat_err > 0.0 );
   ymin = min((orate(w)-ostat_err(w))/(eb2(w)-eb1(w)));
   ymax = max((orate(w)+ostat_err(w))/(eb2(w)-eb1(w)));
   dataplot, 0.5*(eb1+eb2), orate/(eb2-eb1), ostat_err/(eb2-eb1), \
       yr=[ymin,ymax*2], xr=[3,90],  xbar=1,itype=3, \
       xtitle="Energy [keV]",ytitle="Cts /s /keV",title=esc_underscore(Plottitle);


}

/* Function xfit_photspec */

func xfit_photspec( p, eline=, spectrcode= )
/* DOCUMENT phot_spec = xfit_photspec( p, eline=, spectrcode= )


  Function that returns the photon spectrum for a
  given set of spectral parameters
  in array "p":  (norm, param1, nh/1.e22)

   Default operation uses the externals Eline and Spectrcode
   These can be overridden by the keywords.

   NJW/2002-06-28
   2011-05-11/NJW  updated with keywords

*/
{
   if( is_void(p) ) {
      write,"Syntax: flux = xfit_photspec(p)";
      return [];
   }
   if( numberof(p)  !=  3 ) {
      write,"xfit_photspec must be called with 3 element array";
      return [];
   }

   //   Define the common areas

// ynclude = xfit_package.externs_photspec
  extern  Const,       Ebase,       Eline,       Nh,          Param1,      Spectrcode;
// yxclude =

   Const = p(1);
   Param1 = p(2);
   Nh = p(3) * 1.e22;

   aEline = is_void(eline) ? Eline : eline;
   aSpectrcode = is_void(spectrcode) ? Spectrcode : strupcase(spectrcode);

   //   Generate the input spectrum


   if( aSpectrcode == "PL" ) {
                flux = Const * (aEline/Ebase)^(-Param1) * absorp(Nh, aEline);
   } else if( aSpectrcode == "TB" ) {
                // 2012-03-29  Param1 should allways > 0.1
                //+ proxy_param1 = guard( Param1, 0.1, , 0.01 );
                flux = Const * (exp(-aEline/Param1) / aEline) * absorp(Nh, aEline);
   } else if( aSpectrcode == "BB" ) {
                // 2012-03-29  Param1 should allways > 0.1
                //+ proxy_param1 = guard( Param1, 0.1, , 0.01 );
                flux = Const * (aEline^2 / (exp(aEline/Param1) - 1 )) * absorp(Nh, aEline);
   } else if( aSpectrcode == "DF" ) {
                dum = min(abs(aEline-Param1));
                index = where(dum==abs(aEline-Param1))(1);
                flux = array(double, numberof(aEline));
                flux(index) = Const * absorp(Nh, Param1);
   } else {
                write,format="No such spectral model allowed: %s\n", aSpectrcode;
                return [];
   }

   return flux;

}

/* Function xfit_plot */

func xfit_plot( frebin=, outfile=, pname=, win=, nofit= )
/* DOCUMENT xfit_plot, frebin=, outfile=, pname=, win=, nofit=

  Plots the current Rate, Stat_err

   outfile    (string) name of output text file with spectra
                <set>  the output file becomes xfit_nnnn.scm
   frebin     sets a rebinning before the plotting where the value
              is the maximal sigma/signal
   pname      is an optional plot name (string)
   win        defines plotting window (default is current)
   nofit      for plotting only data and skip the fit result

   NJW/2002-06-28
   2008-05-16/NJW translated to Yorick
*/
{

// ynclude = xfit_package.externs_plot
  extern  Const,         Dol_of_spec,   Freeze,        Nh,            Plottitle, \
          Rate_model,     E_max,         Frozen_value,  Normfit,       Rate, \
          Dol_of_bkg,    E_min,         N_freedom,     Param1,        Stat_err, \
           Emin_std, Emax_std, Spectrcode;
// yxclude =

   local oemin, oemax, orate, ostat_err, orate_model, xdum, ydum, zdum;

   if( is_void(win) ) win = 3;
   // Define two plot frames in the same window
   mplot_setup, 21, hideticklabels=1, vrelsize=[3,1], spacing=0.005, \
          vport=[0.15,0.7,0.4,0.85], pane=win;

   fstr = ["","",""];
   if( Freeze(sum) ) fstr(where(Freeze)) = " (frozen)";

   if( numberof(outfile) ) {
      if( typeof(outfile) == "string" ) {
         dump = 1;
      } else {
         outfile = get_next_filename("xfit_????.scm");
         dump = 1;
      }
   } else dump = 0;
 
   // Make sure that Rate_model is for the current parameters
   // but only if the variables exist

   if( !is_void(Const) && !is_void(Param1) && !is_void(Nh) && !nofit ) {
      chi2red = xfit_chi2( [Const, Param1, Nh*1.e-22] )/N_freedom;
      // this call updates 'Rate_model'
      sx_eline = span(Emin_std,Emax_std,200);
      flux = xfit_photspec( [Const, Param1, Nh*1.e-22], eline=sx_eline );
      sx = sflux( Emin_std, Emax_std, sx_eline, flux);
   }

   if( frebin ) {
      REBIN = specrebinninga( E_min, E_max, Rate, Stat_err, frebin, oemin, oemax, orate, ostat_err );
      specrebinning, E_min, E_max, Rate_model, Stat_err, REBIN, xdum, ydum, orate_model, zdum;
   } else {
      oemin = E_min;
      oemax = E_max;
      orate = Rate;
      ostat_err = Stat_err;
      orate_model = Rate_model;
   }

  /*
   *   Note that the Yorick peculiarity of plotting negative values on a log scale
   *   actually shows the absolute values. The negative rate values must therefore
   *   be changed to a resonable (positive) value before plotting.
   */

   wneg = where( orate <= 0.0 );
   nwneg = numberof( wneg );
   or = orate / (oemax - oemin);
   if( nwneg ) {
      wpos = where( orate >  0.0 );
      ymin = min(or(wpos));
      ymax = max(or(wpos));
      r = (ymax / ymin)^0.05;
      ymax *= r;
      ymin /= r;
      or(wneg) = ymin;
   } else {
      ymin = or(min);
      ymax = or(max);
      r = (ymax / ymin)^0.05;
      ymax *= r;
      ymin /= r;
   }

   //+ ymin = min([(orate-ostat_err)/(oemax-oemin),Countspec/(oemax-oemin)]);
   //+ ymax = max([(orate+ostat_err)/(oemax-oemin),Countspec/(oemax-oemin)]);
   //+ xmin = (0.5*(oemin+oemax))(1) * 0.98;
   //+ xmax = (0.5*(oemin+oemax))(0) * 1.02;
   xmin = oemin(1) * 0.95;
   xmax = oemax(0) * 1.05;

   // fix lower y boundaries < 0 to something positive

   ylower = orate/(oemax-oemin) - ostat_err/(oemax-oemin);
   wneg = where( ylower <= 0.0 );
   nwneg = numberof(wneg);
   if( nwneg ) ylower(wneg) = ymin;

   // fix upper y boundaries < 0 to something positive

   yupper = orate/(oemax-oemin) + ostat_err/(oemax-oemin);
   wneg = where( yupper <= 0.0 );
   nwneg = numberof(wneg);
   if( nwneg ) yupper(wneg) = ymin;

   dataplotf, oemin,sqrt(oemin*oemax), oemax,  \
       ylower, \
       //+ orate/(oemax-oemin) - ostat_err/(oemax-oemin), \
       or, \
       //+ orate/(oemax-oemin), \
       yupper, \
       //+ orate/(oemax-oemin) + ostat_err/(oemax-oemin), \
       xr=[xmin,xmax], yr=[ymin,ymax], itype=3, mpl=1, \
       ytitle="Cts /s /keV",title=esc_underscore(Plottitle), \
       xyadjust=[0.02,0.02],titlefont="times",xytitleheight=14;
   if( !is_void(orate_model) && !nofit ) oplthis,oemin, oemax, orate_model/(oemax-oemin), color="red";
   plotsign;
   if( structof(pname) == string ) plotname, pname;

   if( !nofit ) {

      ytxt = 0.55;
      dy   = 0.020;
      csize = 0.7;
      if( !is_void(chi2red) ) \
      xyouts,0.2,ytxt,swrite(format="!c^2^_red_  =     %9.3f",chi2red),device=1,charsize=csize;
      ytxt += dy;
      if( !is_void(sx) ) \
      xyouts,0.2,ytxt,swrite(format="S_x_ (%.0f-%.0f keV) =  %s erg/s/cm^2^", \
               Emin_std, Emax_std, f2scienota(sx,2)),device=1,charsize=csize;
      ytxt += dy;
      if( !is_void(Param1) ) \
      xyouts,0.2,ytxt,swrite(format="Param1   =     %9.3f%s",Param1,fstr(2)),device=1,charsize=csize;
      ytxt += dy;
      if( !is_void(Nh) ) \
      xyouts,0.2,ytxt,swrite(format="Nh/10^22^  =     %9.3f%s",Nh*1.e-22,fstr(3)),device=1,charsize=csize;
      ytxt += dy;
      if( !is_void(Const) ) {
         if( Const < 1.e-2 ) {
            xyouts,0.2,ytxt,swrite(format="Constant =     %s%s",f2scienota(Const,2),fstr(1)),device=1,charsize=csize;
         } else {
            xyouts,0.2,ytxt,swrite(format="Constant =     %9.3f%s",Const,fstr(1)),device=1,charsize=csize;
         }
      }
      ytxt += dy;
      if( !is_void(Spectrcode) ) \
      xyouts,0.2,ytxt,swrite(format="Spec model %s",Spectrcode),device=1,charsize=csize;

      // Plotting ratio

      if( !is_void(orate_model) ) {
         w = where( orate_model > 0.0 & orate > 0.0 );

         y = orate(w)/orate_model(w);
         ylower = orate(w)/orate_model(w) - ostat_err(w)/orate_model(w);
         yupper = orate(w)/orate_model(w) + ostat_err(w)/orate_model(w);
         ymin = y(min);
         ymax = y(max);
         r = (ymax / ymin)^0.15;
         ymax *= r;
         ymin /= r;

         // fix lower y boundaries < 0 to something positive

         wneg = where( ylower <= 0.0 );
         nwneg = numberof(wneg);
         if( nwneg ) ylower(wneg) = ymin;

         dataplotf,oemin(w), sqrt(oemin(w)*oemax(w)), oemax(w), \
            ylower, \
            //+ orate(w)/orate_model(w) - ostat_err(w)/orate_model(w), \
            y, \
            //+ orate(w)/orate_model(w), \
            yupper, \
            //+ orate(w)/orate_model(w) + ostat_err(w)/orate_model(w), \
            xr=[xmin,xmax],yr=[ymin,ymax],mpl=2,itype=3,xtitle="Energy [keV]", ytitle="Ratio", color="blue", \
             xyadjust=[0.02,0.02],titlefont="times",xytitleheight=14;
         oplot,sqrt(oemin*oemax),array(1.,numberof(oemin)),li=2,color="blue";
      }
   }

   // Dump results to file if required

   if( dump && !nofit ) {
      write,format="Saving curves in %s\n", outfile;
      hdr = [];
      grow, hdr, "// xfit results  "+ndate(3);
      grow, hdr, "// DOL_SPE = "+Dol_of_spec;
      if( numberof(Dol_of_bkg) ) grow, hdr, "// DOL_BKG = "+Dol_of_bkg;
      for( i = 1; i <= 3; i++ ) {
         if( Freeze(i) ) {
            grow, hdr,swrite(format="// freeze = %i", i);
            grow, hdr,swrite(format="// value = %f", Frozen_value(i));
         }
      }
      if( !is_void(chi2red) ) \
      grow, hdr, swrite(format="// Chi2red = %f", chi2red);
      if( !is_void(sx) ) \
      grow, hdr, swrite(format="// Sx = %e; erg/cm2/s", sx);
      if( !is_void(Const) ) \
      grow, hdr, swrite(format="// Const = %f", Const);
      if( !is_void(Param1) ) \
      grow, hdr, swrite(format="// Param1 = %f", Param1);
      if( !is_void(Nh) ) \
      grow, hdr, swrite(format="// Nh = %f; 1e22 /cm2", Nh*1.e-22);
      grow, hdr, "//";
      grow, hdr, "// colname = Energy; keV";
      grow, hdr, "// colname = Rate; cts/s";
      grow, hdr, "// colname = Stat_err; cts/s";
      grow, hdr, "// colname = Rate_model; cts/s the model";
      grow, hdr, "//";
      wstab,outfile,sqrt(E_min*E_max),Rate,Stat_err,Rate_model,hdr=hdr;
   }

}

/* Function xfit_show */

func xfit_show
/* DOCUMENT xfit_show

    For a dump to screen of the externals.
*/
{
// ynclude = xfit_package.externs_show
  extern  Dol_of_bkg,    E_max,         Ebase,         Elo,           Frozen_value, \
          Dol_of_spec,   E_min,         Ehi,           Freeze,        Spectrcode;
// yxclude =

   names = ["Const","Param1","Nh"];

   write,format="Dol_of_spec: %s\n", Dol_of_spec;
   if( is_void(Dol_of_bkg) ) {
      write,format="Dol_of_bkg: %s\n", "<not given>";
   } else {
      write,format="Dol_of_bkg: %s\n", Dol_of_bkg;
   }
   write,format="Ebase = %.3f keV, energy base for powerlaw\n", Ebase;
   write,format="E_min and E_max has %i bins from %.3f - %.3f keV\n", numberof(E_min), E_min(1), E_max(0);
   write,format="Elo and Ehi has %i elements from %.3f - %.3f keV\n", numberof(Elo), Elo(1), Ehi(0);
   write,format="Matrix, Arf, Eline exist, current spectral code: %s\n", Spectrcode;
   if( Freeze(sum) ) {
      for( i = 1; i <= 3; i++ ) {
         if( Freeze(i) ) \
         write,format="Parameter %i (%s) is frozen to %.3f\n",i, names(i), Frozen_value(i);
      }
   } else {
      write,"No frozen parameters";
   }
   write,"  Other variables:";
   write,"Arf Bins Chi2red Const Rate_model **_orig Freeze Frozen_value Nh Normfit";
   write,"Param1 Plottitle Rate Spectrcode Stat_err Sx";
   if( !is_void(Spectrcode) ) write,format="\nCurrent spectral model: %s\n", Spectrcode;

}

/* Function xfit_bins */

func xfit_bins( bins, bins2, cont= )
/* DOCUMENT xfit_bins, bins[, bins2][, cont=]

   Use a new subset of spectral bins for fitting etc.
   'bins' is void -> reset to include all bins
   'bins' is a positive scalar -> indgen(bins)
   'bins' is a negative scalar -> rebin to at lest -nbins counts in each bin
   'bins' is array -> no change
   'bins2' given and bins2 > bins (both scalar) -> indgen(bins:bins2)

    Keyword 'cont' is for 'continue' i.e. not setting it will rebin from start,
    but combined rebinning can be done by e.g.

    > xfit_bins, 100;
    > xfit_bins, -10, cont=1;

    that will use first 100 bins and then combine to have at least 10 counts in each.
*/
{
// ynclude = xfit_package.externs_bins
  extern  Bins,           E_min,          Matrix,         Rate,           Stat_err, \
          E_max,          E_min_orig,     Matrix_orig,    Rate_orig,      Stat_err_orig, \
          E_max_orig, Exposure;
// yxclude =

   if( cont ) {
      rate_start = Rate;
      stat_err_start = Stat_err;
      e_min_start = E_min;
      e_max_start = E_max;
      matrix_start = Matrix;
   } else {
      rate_start = Rate_orig;
      stat_err_start = Stat_err_orig;
      e_min_start = E_min_orig;
      e_max_start = E_max_orig;
      matrix_start = Matrix_orig;
   }

   if( is_void(bins) ) bins = indgen(numberof(rate_start));

   //   First see if 'bins' is scalar and negative

   if( is_scalar(bins) ) {
      if( bins < 0 ) {    // binning to at least -bins counts in each bin
         REBIN = specrebinningb( e_min_start, e_max_start, rate_start, stat_err_start, \
                      Exposure, double(-bins), E_min, E_max, Rate, Stat_err );
         Matrix = rebin_rdm( matrix_start, REBIN );
         write,format="New E_min/max: %.3f %.3f keV with %i bins\n", E_min(1), E_max(0), numberof(Rate);
         return;
      }
   }

   //  else apply bin specifications

   if( is_scalar(bins) ) {
      if( is_void(bins2) ) {
         bins = indgen(bins);
      } else {
         if( is_scalar(bins2) ) {
            if( bins2 > bins ) {
               bins = indgen(bins:bins2);
            } else error,"bins2 <= bins";
         } else error,"bins2 is not scalar";
      }
   }
   if( bins(0) > numberof(rate_start) ) error,"bins exceed range ("+itoa(numberof(rate_start))+")";
   Bins = bins;
   E_min = e_min_start(bins);
   E_max = e_max_start(bins);
   Matrix = matrix_start(bins,);
   Rate = rate_start(bins);
   Stat_err = stat_err_start(bins);
   write,format="New E_min/max: %.3f %.3f keV with %i bins\n", E_min(1), E_max(0), numberof(Bins);
}

/* Function xfit_ebase */

func xfit_ebase( ebase )
/* DOCUMENT xfit_ebase, new_ebase
     or     xfit_ebase

    Second version will reset to 1.0
*/
{
// ynclude = xfit_package.externs_ebase
  extern  Ebase;
// yxclude =

   Ebase = is_void(ebase) ? 1.0 : double(ebase);
}

/* Function xfit_title */

func xfit_title( plottitle )
/* DOCUMENT xfit_title, plottitle
      or    xfit_title

     Second version sets the title to an empty string
*/
{
// ynclude = xfit_package.externs_title
  extern  Plottitle;
// yxclude =

   Plottitle = is_void(plottitle) ? "" : plottitle;
}

/* Function xfit_freeze */

func xfit_freeze( parnum, val )
/* DOCUMENT  xfit_freeze, parnum, val

    'val' must be the parameter value that goes into the p array
    For Nh it should be Nh/1e22
*/
{

// ynclude = xfit_package.externs_freeze
  extern  Freeze,        Frozen_value;
// yxclude =

   Freeze(parnum) = 1;
   Frozen_value(parnum) = val;
}

/* Function xfit_thaw */

func xfit_thaw( parnum )
/* DOCUMENT  xfit_thaw, parnum
*/
{

// ynclude = xfit_package.externs_thaw
  extern  Freeze;
// yxclude =

   Freeze(parnum) = 0;
}

/* Function xfit_tune */

func xfit_tune
/* DOCUMENT xfit_tune

    Adjust the errors of observation to give a reduced Chi2 of 1.0
    for the current selection of bins.
*/
{
// ynclude = xfit_package.externs_tune
  extern  Chi2min,    Chi2red,    N_freedom,  Stat_err;
// yxclude =

   Stat_err *= sqrt(Chi2red);
   Chi2min = double(N_freedom);
}

/* Function xfit_pargrid */

func xfit_pargrid( dim1, dim2, range1, range2, win=  )
/* DOCUMENT xfit_pargrid, dim1, dim2[, range1, range2], win=

    Produces a 2D plot in window #2 or as defined by keyword 'win'

*/
{
// ynclude = xfit_package.externs_pargrid
  extern  Chi2min,       Delta_const,   Nh_bf,         Pargrid_arr,   Plottitle, \
          Const_bf,      Delta_param1,  Param1_bf;
// yxclude =
 
   if( is_void(win) ) win = 2;

   Pargrid_arr = array(double,dim1, dim2);
   p = [Const_bf, Param1_bf, Nh_bf*1.e-22];

   if( is_void(range1) ) range1 = Delta_const;
   if( is_void(range2) ) range2 = Delta_param1;
   vals1 = span(  Const_bf - 0.5*range1,  Const_bf + 0.5*range1, dim1 );
   vals2 = span(  Param1_bf - 0.5*range2,  Param1_bf + 0.5*range2, dim2 );
   for( i = 1; i <= dim1; i++ ) {
      for( j = 1; j <= dim2; j++ ) {
         p(1) = vals1(i);
         p(2) = vals2(j);
         Pargrid_arr(i,j) = xfit_chi2( p ) - Chi2min;
      }
   }
   window,win;
   dispc,Pargrid_arr,xax=vals1,yax=vals2,levels=[2.28,4.6,9.21],over=1, \
        title=esc_underscore(Plottitle),xtitle="Const",ytitle="Param1";
   oplot,[Const_bf],[Param1_bf],ps=12,thick=5,color="white",symsize=1.2;
}

/* Function xfit_chi2_1d_1 */

func xfit_chi2_1d_1( x )
{
// ynclude = xfit_package.externs_chi2_1d_1
  extern  Chi2min,  Level,    Pcur;
// yxclude =

   // x is p(1)

   Pcur(1) = x;
   return xfit_chi2( Pcur ) - Chi2min - Level;

}

/* Function xfit_chi2_1d_2 */

func xfit_chi2_1d_2( x )
{
// ynclude = xfit_package.externs_chi2_1d_2
  extern  Chi2min,  Level,    Pcur;
// yxclude =

   // x is p(2)

   Pcur(2) = x;
   return xfit_chi2( Pcur ) - Chi2min - Level;

}

/* Function xfit_chi2_1d_angle */

func xfit_chi2_1d_angle( xi )
{
// ynclude = xfit_package.externs_chi2_1d_angle
  extern  Angle,         Const_bf,      Delta_param1,  Param1_bf,     Pcur, \
          Chi2min,       Delta_const,   Level;
// yxclude =

   // x is p(2)

   Pcur(1) = Const_bf + Delta_const * xi * cos(Angle);
   Pcur(2) = Param1_bf + Delta_param1 * xi * sin(Angle);

   return xfit_chi2( Pcur ) - Chi2min - Level;

}

/* Function xfit_anamin */

func xfit_anamin( astep= )
/* DOCUMENT xfit_anamin[, astep=]

     Scans the const vs. param1 space for 99% confidence interval.

     Keyword 'astep' is angular step (in radians, defaults to 0.1*pi).
*/
{
// ynclude = xfit_package.externs_anamin
  extern  Angle,         Delta_const,   Logfilename,   Nh_bf,         Pcur, \
          Chi2red,       Delta_param1,  Logflag,       Param1_bf,     Specfile, \
          Const_bf,      Level,         Nh;
// yxclude =

   if( is_void(astep) ) astep = 0.1*pi;

  /*
   *  Locate the 99% confidence limits for Pcur(1) == Const
   *  corresponding to chi2 = Chi2min + 9.21
   */

   Pcur = [Const_bf, Param1_bf, Nh_bf*1.e-22];
   Level = 9.21;
   //  Search to the right
   tol = 1.e-5;
   ax = bx = Const_bf;
   do {
      bx *= 1.01;
      fb = xfit_chi2_1d_1(bx);
   } while ( fb <= 0. );
   const_max = zbrent( xfit_chi2_1d_1, ax, bx, tol );

   //  Search to the left
   ax = bx = Const_bf;
   do {
      bx *= 0.99;
      fb = xfit_chi2_1d_1(bx);
   } while ( fb <= 0. );
   const_min = zbrent( xfit_chi2_1d_1, ax, bx, tol );

   Delta_const = const_max - const_min;
   write,format="99%% confid. interval for Const: %.4f - %.4f (range %.4f)\n", \
                                      const_min, const_max, Delta_const;
   write,format="     for Param1 = %.4f and Nh/1e22 = %.4f\n", Param1_bf, Nh_bf*1.e-22;

  /*
   *  Locate the 99% confidence limits for Pcur(2) == Param1
   *  corresponding to chi2 = Chi2min + 9.21
   */

   Pcur = [Const_bf, Param1_bf, Nh_bf*1.e-22];
   //  Search to the right
   tol = 1.e-5;
   ax = bx = Param1_bf;
   do {
      bx *= 1.01;
      fb = xfit_chi2_1d_2(bx);
   } while ( fb <= 0. );
   param1_max = zbrent( xfit_chi2_1d_2, ax, bx, tol );

   //  Search to the left
   ax = bx = Param1_bf;
   do {
      bx *= 0.99;
      fb = xfit_chi2_1d_2(bx);
   } while ( fb <= 0. );
   param1_min = zbrent( xfit_chi2_1d_2, ax, bx, tol );

   Delta_param1 = param1_max - param1_min;
   write,format="99%% confid. interval for Param1: %.4f - %.4f (range %.4f)\n", \
                                      param1_min, param1_max, Delta_param1;
   write,format="     for Const = %.4f and Nh/1e22 = %.4f\n", Const_bf, Nh_bf*1.e-22;

   // Search various angles

   for( Angle = pi*0.2; Angle < 2*pi; Angle += astep ) {
      xi = 0.;
      do {
         xi += 0.1;
         fb = xfit_chi2_1d_angle( xi );
      } while( fb <= 0.0 );
      ximin = zbrent( xfit_chi2_1d_angle, 0., xi, tol );
      c = Const_bf + Delta_const * ximin * cos(Angle);
      if( c > const_max ) const_max = c;
      if( c < const_min ) const_min = c;
      c = Param1_bf + Delta_param1 * ximin * sin(Angle);
      if( c > param1_max ) param1_max = c;
      if( c < param1_min ) param1_min = c;
   }
   Delta_const = const_max-const_min;
   Delta_param1 = param1_max-param1_min;
   write,format="99%% confid. interval for Const: %.4f - %.4f (range %.4f)\n", \
                                      const_min, const_max, const_max-const_min;
   write,format="99%% confid. interval for Param1: %.4f - %.4f (range %.4f)\n", \
                                      param1_min, param1_max, param1_max-param1_min;

   if( Logflag ) {
      flog = open(Logfilename,"a");
      write,flog,format="// called xfit_anamin ...%s","\n";
      s = structof(Specfile) == string ? Specfile : "from \"xfit_fakeit\"";
      write,flog,format=" %12.3e %12.3e %.4f %.4f %.4f %.4f %.4f %s\n", Const_bf, 0.5*Delta_const, \
               Param1_bf, 0.5*Delta_param1, Nh*1.e-22, 0., Chi2red, s;
      close, flog;
   }
}

/* Function xfit_read */

func xfit_read( rmffile, arffile )
/* DOCUMENT xfit_read, rmffile, arffile

   Load the Matrix, Elo, Ehi, Eline, E_min, E_max for the
   relevant instrument.

   2011-09-07/NJW cloned from xfit_nustar_init.i

*/
{

// ynclude = xfit_package.externs_read
  extern  Arf,     E_max,   E_min,   Ehi,     Eline,   Elo,     Matrix, \
          E_min_orig, E_max_orig, Matrix_orig;
// yxclude =

   local elo, ehi, emin, emax;

   //   Get the RMF data

   Matrix_orig = Matrix = read_ogip_rmf( rmffile, elo, ehi, emin, emax );

   E_min_orig = E_min = emin;
   E_max_orig = E_max = emax;

   Elo = elo;
   Ehi = ehi;
   Eline = sqrt(Elo*Ehi);

   //    Get the ARF

   Arf = rdfitscol(arffile+"+1","SPECRESP");
   elo_Arf = rdfitscol(arffile+"+1","ENERG_LO");
   //+ ehi_Arf = rdfitscol(arffile+"+1","ENERG_HI");
   //  --- NB temporary fix for LOFT WFM data
   ehi_Arf = rdfitscol(arffile+"+1","ENERGY_HI");
   e_Arf = 0.5*(elo_Arf + ehi_Arf);
   Arf = interp( Arf, e_Arf, Eline);

   write,"Elo, Ehi, Matrix, Arf, E_min, and E_max have been loaded ...";
}

/* Function xfit_fakeit */

func xfit_fakeit( bkgdol, fbkg=, openfrac=, sc=, cst=, p1=, nh=, expo=, ia= )
/* DOCUMENT xfit_fakeit, bkgdol, fbkg=, openfrac=, sc=, cst=, p1=, nh=, expo=, ia=

    Simulate an observation using the ARF and RMF previously loaded by
    xfit_read.

    Giving the DOL of a background will include it in the simulation and fitting.
    The background table is assumed to be number of counts per detector channel
    in the time given by the EXPOSURE keyword on the entire detector.

    The keyword 'openfrac' will attenuate the background actually used with this
    factor (applies for a coded mask instrument).

    It is assumed that the open fraction for the source is covered by the Arf.

    The keyword 'fbkg' will distinguish between the two cases:
       1) The background is determined in the same observation as the source
          so it is determined with a statistical error with a possibility
          to 'overobserve' with a factor, namely fbkg. (fbkg > 0, usually 1,
          but can be 3 as for a 0.25 coded mask).
       2) The background is determined in a long observation so that
          a perfect subtraction can be done (fbkg is not set)
       This is inspired by the discussions around 2011-09-04 with Soren Brandt and
       Jerome Chenevez.

    keywords:
        sc:    Spectral code, "pl", "tb", "bb", or "df"
       cst:    Normalization
        p1:    Spectral parameter
        nh:    Column density in units of 1.e22 cm-2
      expo:    Exposure time in seconds
        ia:    Sets interactive mode

    2011-09-07/NJW cloned from xfit_nustar_fakeit
*/
{

   //   Define the externals

// ynclude = xfit_package.externs_fakeit
  extern  Arf,          Const,        Eline,        Nh,           Spectrcode, \
          Bkgexposure,  Countspec,    Elo,          Param1,       Stat_err, \
          Bkgspec,      Bkgrate, Ebase,        Matrix,       Rate,         Use_bkg, \
          Bkgspec_err,  Ehi,  Photonspec, Emin_std, Emax_std, N_freedom,  \
          Parfilename, Exposure, Fbkg, Logflag, Logfilename, Rate_orig, Stat_err_orig, \
          Matrix_orig;
// yxclude =

   if( is_void(openfrac) ) openfrac = 1.0;
   if( is_void(Ebase) ) Ebase = 1.; // [keV] pivot point for spectra
   if( is_void(bkgdol) ) {
      Use_bkg = 0;
   } else {
      local bkgfile, bkgext;
      get_exten_no, bkgdol, bkgfile, bkgext;

      if( !file_test(bkgfile) ) error,"Bkg file was not found";
      hdr = headfits( bkgdol );
      // reduce the background counts with the open fraction
      Bkgspec = openfrac*rdfitscol( bkgdol, "COUNTS" );
      Bkgspec_err = sqrt(Bkgspec);
      Bkgexposure = fxpar( hdr, "exposure" );
      Use_bkg = 1;
   }

   p = array(double,3);

   if( ia ) {
      Spectrcode = "";
      read,prompt="Enter spectrcode : ... ",format="%s", Spectrcode;
      Spectrcode = strupcase(Spectrcode);
      Const = 1.0; Param1 = 1.0; nhcol = 1.0;
      read,prompt="Enter constant : ... ",format="%f", Const;
      read,prompt="Enter param1   : ... ",format="%f", Param1;
      read,prompt="Enter NH/1.e22 : ... ",format="%f", nhcol;
      Exposure = 1.0;
      read,prompt="Enter exposure : ... ",format="%f", Exposure;
   } else {
      Const = numberof(cst) ? double(cst) : get_par( Parfilename, "const" );
      Spectrcode =  numberof(sc) ? strupcase(sc) : get_par( Parfilename, "spectrcode" );
      Param1 = numberof(p1) ? double(p1) : get_par( Parfilename, "param1" );
      nhcol = numberof(nh) ? double(nh) : get_par( Parfilename, "nh" ); // in units of 1.e22
      Exposure = numberof(expo) ? double(expo) : get_par( Parfilename, "exposure" );
   }
   set_par, Parfilename, "spectrcode", Spectrcode;
   set_par, Parfilename, "const", Const;
   set_par, Parfilename, "param1", Param1;
   set_par, Parfilename, "nh", nhcol;
   set_par, Parfilename, "exposure", Exposure;

   p(1) = Const;
   p(2) = Param1;
   p(3) = nhcol;
   Nh = p(3) * 1.e22;

   //   Generate the input photon spectrum

   Photonspec = xfit_photspec(p);
   write,format="Sflux %.0f-%.0f keV = %12.3e erg/cm2/s\n", \
              Emin_std, Emax_std, sflux(Emin_std,Emax_std,Eline, Photonspec);

   if( Logflag ) {
      fh = open( Logfilename, "a" );
      write,fh,format="// Call xfit_fakeit with ...%s","\n";
      write,fh,format="// Spectrcode = %s\n", Spectrcode;
      write,fh,format="// Const = %10.4f\n", Const;
      write,fh,format="// Param1 = %10.4f\n", Param1;
      write,fh,format="// Nh = %13.2e\n", nhcol*1.e22;
      write,fh,format="// Exposure = %13.2e\n", Exposure;
      write,fh,format="// Sflux %.0f-%.0f keV = %12.3e erg/cm2/s\n", \
              Emin_std, Emax_std, sflux(Emin_std,Emax_std,Eline, Photonspec);
      if( Use_bkg ) {
         write,fh,format="// dol_bkg = %s\n", bkgdol;
         if( fbkg ) {
            write,fh,format="// fbkg = %10.2f\n", fbkg;
         } else write, fh, format="// inf bkg determination%s","\n";
         write,fh,format="// openfraction = %10.5f\n", openfrac;
      } else write,fh,format="// no bkg used%s","\n";
      close, fh;
   }


   line_counts = Photonspec * (Ehi - Elo) * Arf;
   Countspec = (Matrix_orig(,+)*line_counts(+))*Exposure; // expected count spectrum
   //+ Countspec += random_n(numberof(Countspec))*countspec_err;

   // Note the difference between 'Countspec' that is the observed (or
   // simulated) number of counts, whereas 'Rate_model' is the result of
   // the current spectral parameter values.

   //  Add counting statistics for realistic simulation
   Countspec = poisson(Countspec);

   // Add background if supplied

   if( Use_bkg ) {
      Bkgspec *= (Exposure/Bkgexposure); // rescale to observation
      Countspec += poisson(Bkgspec);
      Fbkg = fbkg;
      if( fbkg ) Bkgspec = poisson(fbkg*Bkgspec)/fbkg;
      Bkgrate = Bkgspec / Exposure;
   }
   countspec_err = sqrt(Countspec); // usual expression
   Rate = Countspec / Exposure;
   if( Use_bkg ) Rate -= Bkgrate;
   Stat_err = countspec_err / Exposure;
   Rate_orig = Rate;
   Stat_err_orig = Stat_err;

   N_freedom = numberof(Rate) - 3; // to update the external for e.g. xfit_plot

   write,"Rate(_orig) and Stat_err(_orig) are now prepared for e.g. fitting and plotting.";
   if( Use_bkg ) write,"Bkgspec and Bkgrate have been loaded as well.";

}
%FILE% xfit_package.i
extern xfitdoc;
/* DOCUMENT ************************************************************
 *
 *    Functions for spectral modelling and fitting. PHA II spectral files
 *    are assumed.
 *
 *      xfit_anamin  analyze range of parameters for display
 *      xfit_bins    change detector bins to use in fit
 *      xfit_chi2    return Chi2 for at given parameter set
 *      xfit_chi2_1d_1
 *      xfit_chi2_1d_2
 *      xfit_chi2_1d_angle
 *      xfit_data    read spectral data from PHAII file + RMF
 *      xfit_ebase   set the powerlaw energy base (Ebase)
 *      xfit_fakeit  produces a simulated count spectrum
 *      xfit_fit     do the fitting using 'amoeba'
 *      xfit_freeze  freeze a given parameter to a value
 *      xfit_init    needs input from an observation
 *      xfit_lmfit   do the fitting using 'lmfit'
 *      xfit_log     define the log file
 *      xfit_model   sets the spectral model (Spectrcode)
 *      xfit_nfit    get the normalization
 *      xfit_pargrid find chi2 in a 2D grid
 *      xfit_photspec  define source spectrum from existing parameters
 *      xfit_plot    plotting results
 *      xfit_read    load basic information: RMF, ARF (for xfit_fakeit)
 *      xfit_show    Show variables in memory
 *      xfit_thaw    Thaw a given parameter (previously frozen)
 *      xfit_title   set the title for plots
 *      xfit_tune    Adjust statistical errors to chi2red = 1
 *
 *
 *      xfit_nustar_fakeit   fake a NuStar observation
 *      xfit_nustar_init  set up NuStar fitting
 *      xfit_nustar_plot  plotting NuStar results
 *
 *  Version 2.1, initiated 2012-03-28/NJW to rebin to sensible number of counts in each bin
 *      Version date: 2012-04-13/NJW
 *
 ***********************************************************************/

// setting the name of the parameter file (mainly for xfit_fakeit)

Parfilename = "xfit.par";

// setting the standard energy limits for the sflux calculation

Emin_std = 2.; // keV
Emax_std = 10.; // keV

Freeze = array(0,3);
Frozen_value = array(double,3);

// setting the default Ebase value

//+ Ebase = 5.; // [keV] Adequate value for LOFT WFC

Ebase = 1.0; // Commonly accepted value

/* Function xfit_pset */

func xfit_pset
/* DOCUMENT  xfit_pset

   is an interactive function for setting various
   external variables such as
      Emin_std, Emax_std, Ebase

*/
{
   extern Emin_std, Emax_std, Ebase;

   write,format="(1) Emin_std : %10.3f keV\n", Emin_std;
   write,format="(2) Emax_std : %10.3f keV\n", Emax_std;
   write,format="(3) Ebase    : %10.3f keV\n", Ebase;

   ans = strsplit(rdline(prompt="Enter number and new value : ... ")," ");
   n = atoi(ans(1));
   v = atof(ans(2));
   if( n == 1 ) {
      Emin_std = v;
      write,format="Emin_std : %10.3f keV\n", Emin_std;
   } else if( n == 2 ) {
      Emax_std = v;
      write,format="Emax_std : %10.3f keV\n", Emax_std;
   } else if( n == 3 ) {
      Ebase = v;
      write,format="Ebase    : %10.3f keV\n", Ebase;
   } else write,"Bad number, no action ...";

}

/* Function xfit_log */

func xfit_log( logfilename, reset= )
/* DOCUMENT xfit_log, logfilename, reset=
     or     xfit_log

    First version: A logging to 'logfilename' will be continued unless
                      the keyword 'reset' has been set.
    Second version: Terminates the logging

*/
{
// ynclude = xfit_package.externs_log
  extern  Logfilename,  Logflag;
// yxclude =

   if( is_void(logfilename) ) {
      Logflag = 0;
   } else {
      Logfilename = logfilename;
      Logflag = 1;
      cm = reset ? "w" : "a";
      f = open(logfilename,cm);
      write,f,format="//  Log file for xfit_package started %s\n", ndate(3);
      write,f,format="//    Errors are 3sigma i.e. 99%% confidenc%s\n","e";
      write,f,format="// %s\n", "colname = const";
      write,f,format="// %s\n", "colname = d_const";
      write,f,format="// %s\n", "colname = param1";
      write,f,format="// %s\n", "colname = d_param1";
      write,f,format="// %s\n", "colname = nh";
      write,f,format="// %s\n", "colname = d_nh";
      write,f,format="// %s\n", "colname = chi2red";
      write,f,format="// %s\n", "colname = specfile";
      close,f;
   }
}

/* Function xfit_init */

func xfit_init( dol_of_spec, dol_of_bkg, num_spec=, num_spec_bkg=, bins=, title=, model=, ebase= )
/* DOCUMENT xfit_init( dol_of_spec, dol_of_bkg, num_spec=, num_spec_bkg=, bins=, title=, model=, ebase= )

  Prepare fitting an observed X-ray spectrum from j_src_spectra or similar.
    Keywords:
         num_spec        row number of the spectrum to use (default: 1)
         num_spec_bkg    row number of the bkg spectrum to use (default: 1)
         bins            array with spectral bins to use in plots and fits
         title           plot title
         model           spectral model to use (PL, TB, BB, DF)
         ebase           Energy base for powerlaw spectrum

   Steps: xfit_init defines the energy channels, reads the spectrum,
                    defines the bins to use, reads the line energies,
                    reads and rebins the redistribution matrix, sets
                    the spectral model.
          xfit_fit  executes the fitting (no arguments)

          xfit_plot plots the data with the best fit

   NJW/2002-06-28
   2008-03-14/NJW translated from IDL to Yorick
   2011-05-10/NJW updated to get SPECRESP + ARF from header in spectral file

*/
{
   local specfile, extno, exposure, bexposure;
   local rate, stat_err, brate, bstat_err, rdm, brdm;

   //   Setup the common areas

// ynclude = xfit_package.externs_init
  extern  Arf,            E_max_orig,     Ehi,            Matrix_orig,    Spectrcode, \
          Dol_of_bkg,     E_min,          Eline,          Plottitle,      Stat_err, \
          Dol_of_spec,    E_min_orig,     Elo,            Rate,           Stat_err_orig, \
          E_max,          Ebase,          Matrix,         Rate_orig, Exposure;
// yxclude =

   if( !is_void(dol_of_spec) ) {
      get_exten_no, dol_of_spec, specfile, extno;
      if( !file_test(specfile) ) {
         write,format="Sorry, %s cannot be found\n", specfile;
         return;
      }
      Dol_of_spec = dol_of_spec;
   }
   if( !is_void(dol_of_bkg) ) {
      get_exten_no, dol_of_bkg, specfile, extno;
      if( !file_test(specfile) ) {
         write,format="Sorry, %s cannot be found\n", specfile;
         return;
      }
      Dol_of_bkg = dol_of_bkg;
   }
   Ebase = is_void(ebase) ? 1.0 : double(ebase);
   if( is_void(num_spec) ) num_spec = 1;
   if( is_void(num_spec_bkg) ) num_spec_bkg = 1;

   if( !is_void(dol_of_spec) ) { // Assume already known if not given

      if( is_void(title) ) {
         Plottitle = "";
         read,prompt="Enter the plot title: ... ",format="%s", Plottitle;
      } else {
         Plottitle = title;
      }

      //   Get the spectral data

      write,"Getting spectral data ...";
      type = j_get_src_spectrum( dol_of_spec, num_spec, rate, stat_err, rdm, exposure);
      Exposure = exposure;
      if( type == 1 ) write,"Warning! Spectrum flagged as BKG";

      //  Get the background spectrum if given as argument
      //    and do the subtraction with proper error assignment

      if( !is_void(dol_of_bkg) ) {
         write,"Getting background data ...";
         btype = j_get_src_spectrum( dol_of_bkg, num_spec_bkg, brate, bstat_err, brdm, bexposure);
         if( !near( bexposure, exposure, 0.99 ) ) {
            write,"Warning! BKG exposure differs from net exposure";
         }
         if( type != 1 ) write,"Warning! Bkg spectrum flagged as NET or TOTAL";
         rate -= brate;
         stat_err = sqrt(stat_err^2 + bstat_err^2);
      }

      Rate_orig = Rate = rate;
      Stat_err_orig = Stat_err = stat_err;

   }

   Matrix_orig = Matrix = *rdm.rdm;
   Elo = *rdm.energ_lo;
   Ehi = *rdm.energ_hi;
   Eline = sqrt(Elo * Ehi);
   Arf = *rdm.arf;
   E_min_orig = E_min = *rdm.e_min;
   E_max_orig = E_max = *rdm.e_max;

   //   Limit the spectral bins if requested

   if( !is_void(bins) ) xfit_bins, bins;

   //   Define the spectral model

   if( !is_void(model) ) {
      Spectrcode = strupcase(strtrim(model));
   } else {
      Spectrcode = "";
      while( Spectrcode != "PL" && Spectrcode != "TB" && Spectrcode != "BB" && Spectrcode != "DF" ) {
         read,prompt="What is the spectral model? (PL,TB,BB,DF) : ... ", \
               format="%s",Spectrcode;
         Spectrcode = strupcase(strtrim(Spectrcode));
      }
   }


}

/* Function xfit_data */

func xfit_data( dol_of_spec, dol_of_bkg, num_spec=, num_spec_bkg= )
/* DOCUMENT xfit_data, dol_of_spec, dol_of_bkg, num_spec=, num_spec_bkg=

  Prepare fitting an observed X-ray spectrum from j_src_spectra or similar.
    Keywords:
         num_spec        row number of the spectrum to use (default: 1)
         num_spec_bkg    row number of the bkg spectrum to use (default: 1)

   The detector energy bin selection is reset to all (can be updated with
                         'xfit_bins').

   Steps: xfit_data reads the spectrum and the associated anchor file and
                    RMF data.
          xfit_fit  executes the fitting (no arguments)

          xfit_plot plots the data with the best fit

   2011-05-13/NJW

*/
{
   local specfile, bkgfile, extno;
   local rate, stat_err, brate, bstat_err, rdm, brdm, exposure, bexposure;

   //   Setup the externals

// ynclude = xfit_package.externs_data
  extern  Arf,            E_max,          Ebase,          Matrix,         Rate_orig, \
          Bins,           E_max_orig,     Ehi,            Matrix_orig,    Specfile, \
          Dol_of_bkg,     E_min,          Eline,          Plottitle,      Stat_err, \
          Dol_of_spec,    E_min_orig,     Elo,            Rate,           Stat_err_orig, \
          Exposure;
// yxclude =

   if( !is_void(dol_of_spec) ) {
      get_exten_no, dol_of_spec, specfile, extno;
      if( !file_test(specfile) ) {
         write,format="Sorry, %s cannot be found\n", specfile;
         return;
      }
      Dol_of_spec = dol_of_spec;
   }
   if( !is_void(dol_of_bkg) ) {
      get_exten_no, dol_of_bkg, bkgfile, extno;
      if( !file_test(bkgfile) ) {
         write,format="Sorry, %s cannot be found\n", bkgfile;
         return;
      }
      Dol_of_bkg = dol_of_bkg;
   }
   Specfile = fullpath(specfile);
   Ebase = 1.0; // default setting
   Plottitle = specfile;
   if( is_void(num_spec) ) num_spec = 1;
   if( is_void(num_spec_bkg) ) num_spec_bkg = 1;

   //   Get the spectral data

   write,"Getting spectral data ...";
   type = j_get_src_spectrum( dol_of_spec, num_spec, rate, stat_err, rdm, exposure);
   Exposure = exposure;
   if( type == 1 ) write,"Warning! Spectrum flagged as BKG";

   //  Get the background spectrum if given as argument
   //    and do the subtraction with proper error assignment
   //    But only if spectral data are designated "TOTAL" (type == 2)

   if( !is_void(dol_of_bkg) && type == 2 ) {
      write,"Getting background data ...";
      btype = j_get_src_spectrum( dol_of_bkg, num_spec_bkg, brate, bstat_err, brdm, bexposure);
      if( !near( bexposure, exposure, 0.99 ) ) {
         write,"Warning! BKG exposure differs from net exposure";
      }
      if( type != 1 ) write,"Warning! Bkg spectrum flagged as NET or TOTAL";
      rate -= brate;
      stat_err = sqrt(stat_err^2 + bstat_err^2);
   }

   Rate_orig = Rate = rate;
   Stat_err_orig = Stat_err = stat_err;
   Bins = indgen(numberof(rate));

   Matrix_orig = Matrix = *rdm.rdm;
   Elo = *rdm.energ_lo;
   Ehi = *rdm.energ_hi;
   Eline = sqrt(Elo * Ehi);
   Arf = *rdm.arf;
   E_min_orig = E_min = *rdm.e_min;
   E_max_orig = E_max = *rdm.e_max;

}

/* Function xfit_model */

func xfit_model( model )
/* DOCUMENT xfit_model, spectrcode
    or      xfit_model

      Can be PL, TB, BB, or DF
*/
{
// ynclude = xfit_package.externs_model
  extern  Spectrcode;
// yxclude =

   //   Define the spectral model

   if( !is_void(model) ) {
      Spectrcode = strupcase(strtrim(model));
   } else {
      Spectrcode = "";
      while( Spectrcode != "PL" && Spectrcode != "TB" && Spectrcode != "BB" && Spectrcode != "DF" ) {
         read,prompt="What is the spectral model? (PL,TB,BB,DF) : ... ", \
               format="%s",Spectrcode;
         Spectrcode = strupcase(strtrim(Spectrcode));
      }
   }
}

/* Function xfit_fit */

func xfit_fit( &p_res, cont= )
/* DOCUMENT chi2_red = xfit_fit( >p_res, cont= )

  Fitting a model to an observed spectrum.
  If keyword 'cont' is set then p_res are the initial values
  for the fitting process.
  Freezing/thawing of a variable can be done with functions
  xfit_freeze and xfit_thaw resp.

    NJW/2002-06-28
    2008-03-14/NJW Translated to Yorick
    2011-05-11/NJW updated to be more general

*/
{

// ynclude = xfit_package.externs_fit
  extern  Chi2min,       Rate_model,     Frozen_value,  Nh_bf,         Param1_bf, \
          Chi2red,       Ehi,           N_freedom,     Normfit,       Spectrcode, \
          Const,         Elo,           Nh,            Param1,        Sx, \
          Const_bf,      Freeze,        Emin_std,      Emax_std, Logflag, Logfilename, \
          Rate, Stat_err;
// yxclude =

   Normfit = 0;

/*
 *********     BEGIN  FITTING  PROCESS    *******************
 */

   // Define weights

   m = where( Stat_err <= 0.0 );
   if( numberof(m) ) {
      write,"Warning - "+itoa(numberof(m))+" stat errs are zero or negative";
      Stat_err(m) = 1.;
   }
   weights = 1./Stat_err^2;

   p = [1.,1.,1.];
   if( cont && numberof(p_res) == 3 ) p = p_res;

   p_to_fit = [];
   if( Freeze(1) ) p(1) = Frozen_value(1);
   else grow,p_to_fit,1;
   if( Freeze(2) ) p(2) = Frozen_value(2);
   else grow,p_to_fit,2;
   if( Freeze(3) ) p(3) = Frozen_value(3);
   else grow,p_to_fit,3;

   resfit = lmfit( xfit_rate, dummy, p, Rate, weights, fit=p_to_fit );
   p_res = p;

   write,format="resfit.neval = %i\n", resfit.neval;
   write,format="resfit.niter = %i\n", resfit.niter;
   write,format="resfit.chi2_last = %f\n", resfit.chi2_last;

   //  this call will silently update the 'Rate_model' external
   //  in 'xfit_chi2'

/*
 *********     END  OF  FITTING   PROCESS    *******************
 */

   //   Present the results

   if( Logflag ) {
      fh = open( Logfilename, "a" );
      write,fh,format="// Fitting ...%s","\n";
   }

   N_freedom = numberof(Rate_model) - 3 + Freeze(sum);

   Chi2min = xfit_chi2(p_res);
   Chi2red = Chi2min/N_freedom;
   write,format="Chi2,red =   %10.4f\n", Chi2red;
   if( Logflag ) write,fh,format="// Chi2,red =   %10.4f\n", Chi2red;

   wstr = swrite(format="Constant =    %12.3e",p_res(1));
   if( Freeze(1) ) wstr += " (frozen)";
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   wstr = swrite(format="Param1   =    %10.4f",p_res(2));
   if( Freeze(2) ) wstr += " (frozen)";
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   wstr = swrite(format="Nh/1e22  =    %10.4f",p_res(3));
   if( Freeze(3) ) wstr += " (frozen)";
   write,format="%s\n", wstr;
   if( Logflag ) write, fh, format="// %s\n", wstr;

   // Setting externals with best fit parameters

   Const_bf = Const = p_res(1);
   Param1_bf = Param1 = p_res(2);
   Nh_bf = Nh = p_res(3)*1.e22;

   //   Get the photon spectrum and source intensity

   if( Spectrcode  ==  "DF" ) {
      flux = xfit_photspec(p_res);
      dum = max(flux);
      index = where(dum==flux)(1);
      Sx = dum * (Ehi(index)-Elo(index)) * 1.6e-9;
      write,format="Sx          = %13.4e erg/cm2/s\n", Sx;
      if( Logflag ) write,fh,format="// Sx          = %13.4e erg/cm2/s\n", Sx;
   } else {
      sx_eline = spanl(Emin_std,Emax_std,200);
      flux = xfit_photspec(p_res, eline=sx_eline);
      Sx = sflux( Emin_std, Emax_std, sx_eline, flux);
      write,format="Sx(%.0f-%.0f keV) = %13.4e erg/cm2/s\n", Emin_std, Emax_std, Sx;
      if( Logflag ) write,fh,format="// Sx(%.0f-%.0f keV) = %13.4e erg/cm2/s\n", Emin_std, Emax_std, Sx;
   }

   if( Logflag ) close, fh;

   return Chi2red;

}

/* Function xfit_nfit */

func xfit_nfit( &p_res )
/* DOCUMENT chi2_red = xfit_nfit( >p_res )

  Fitting normalization for a model to an observed spectrum
  i.e. only one free parameter.

  p_res is both input and output
  p(1) will be calculated
  p(2) is Photon Index
  p(3) is NH - absorption column in 1e22 cm-2

    2008-08-20/NJW

*/
{

// ynclude = xfit_package.externs_nfit
  extern  Chi2min,     Const_bf,    Elo,         Nh_bf,       Param1_bf,   Stat_err, \
          Chi2red,     Rate_model,   N_freedom,   Normfit,     Rate,        Sx, \
          Const,       Ehi,         Nh,          Param1,      Spectrcode, Emin_std, Emax_std;
// yxclude =


   p_res(1) = 1.0;
   Normfit = 1;

   c2 = xfit_chi2( p_res );

   p_res(1) = sum((Rate/Stat_err)^2) / sum(Rate_model*Rate/Stat_err^2);

   //   Present the results

   N_freedom = numberof(Rate_model) - 1;

   Chi2min = xfit_chi2(p_res);
   // This call updates the external variable 'Rate_model'

   Chi2red = Chi2min/N_freedom;
   write,format="Chi2,red =   %10.4f\n", Chi2red;

   write,format="Constant =    %10.4f\n",p_res(1);
   write,format="Param1   =    %10.4f (frozen)\n",p_res(2);
   write,format="Nh/1e22  =    %10.4f (frozen)\n",p_res(3);

   // Defining the best fit parameters

   Const_bf = Const = p_res(1);
   Param1_bf = Param1 = p_res(2);
   Nh_bf = Nh = p_res(3)*1.e22;

   //   Get the photon spectrum and source intensity

   if( Spectrcode  ==  "DF" ) {
      flux = xfit_photspec(p_res);
      dum = max(flux);
      index = where(dum==flux)(1);
      Sx = dum * (Ehi(index)-Elo(index)) * 1.6e-9;
      write,format="Sx          = %13.4e erg/cm2/s\n", Sx;
   } else {
      sx_eline = spanl(Emin_std,Emax_std,200);
      flux = xfit_photspec(p_res, eline=sx_eline);
      Sx = sflux( Emin_std, Emax_std, sx_eline, flux);
      write,format="Sx(%.0f-%.0f keV) = %13.4e erg/cm2/s\n", Emin_std, Emax_std, Sx;
   }

   return Chi2red;

}

/* Function xfit_chi2 */

func xfit_chi2( p )
/* DOCUMENT res = xfit_chi2( p )

  Fit function that returns Chi2 for( a given set of parameters
  in array "p":  (norm, param1, nh/1.e22)

  Side effect:  Updates the external 'Rate_model' !

   NJW/2002-06-28
   2008-03-14/NJW Translated to Yorick
*/
{

   if( is_void(p) ) {
      write,"Syntax: chi2 = xfit_chi2(p)";
      return [];
   }
   if( numberof(p) !=  3 ) {
      write,"xfit_chi2 must be called with 3 element array";
      return [];
   }

   //   Define the externals

// ynclude = xfit_package.externs_chi2
  extern  Arf,        Ehi,        Elo,        Matrix,     Rate,       Stat_err, \
          Rate_model;
// yxclude =

   //   Generate the input spectrum

   flux = xfit_photspec(p);

   line_counts = flux * (Ehi - Elo) * Arf;
   Rate_model = Matrix(,+)*line_counts(+);

   c2 = chi2( Rate_model, Rate, Stat_err );

   return c2;

}

/* Function xfit_rate */

func xfit_rate( dummy, p, outfile= )
/* DOCUMENT res = xfit_rate( dummy, p, outfile= )

  Fit function that returns the model rate for a given set of parameters
  in array "p":  (norm, param1, nh/1.e22)
  'dummy' is an argument required by lmfit - not used here.

  Used as fitting function in 'lmfit' (xfit_lmfit)

  Side effect:  Updates the external 'Rate_model' !

   A FITS output file may be produced by setting keywork 'outfile' to a valid
   filename string.

   2011-09-15/NJW
*/
{

   //   Define the externals

// ynclude = xfit_package.externs_chi2
  extern  Arf,        Ehi,        Elo,        Matrix,    Rate_model, \
          E_min, E_max;
// yxclude =

   //   Generate the input spectrum

   line_counts = xfit_photspec(p) * (Ehi - Elo) * Arf;
   Rate_model = Matrix(,+)*line_counts(+);

   if( typeof(outfile) == "string" ) {
      kwds_init;
      kwds_set,"DATE",ndate(3),"Date/time of file production";
      kwds_set,"ORIGIN","xfit_package-2.1{xfit_rate}","Software";
      for( i = 1; i <= numberof(p); i++ ) {
         kwds_set,"PARAM"+itoa(i),p(i),"Parameter value";
      }
      wrmfitscols, outfile, "E_MIN", E_min, "E_max", E_max, "RATE", Rate_model;
   }

   return Rate_model;

}

/* Function xfit_nustar_fakeit */

func xfit_nustar_fakeit(a)
/* DOCUMENT xfit_nustar_fakeit


   NJW/2002-06-28
   2008-03-14/NJW Translated to Yorick
   2008-05-22/NJW
*/
{

   //   Define the externals

// ynclude = xfit_package.externs_nustar_fakeit
  extern  Arf,            Countspec_err,  Elo,            Nh,             Rate, \
          Const,          Ehi,            Exposure,       Param1,         Stat_err, \
          Countspec,      Eline,          Matrix, \
            Emin_std, Emax_std, Photonspec;
// yxclude =

   p = array(double,3);

   Const = 1.0; Param1 = 1.0; nh = 1.0;
   read,prompt="Enter constant : ... ",format="%f", Const;
   read,prompt="Enter param1   : ... ",format="%f", Param1;
   read,prompt="Enter NH/1.e22 : ... ",format="%f", nh;
   Exposure = 1.0;
   read,prompt="Enter exposure : ... ",format="%f", Exposure;


   p(1) = Const;
   p(2) = Param1;
   p(3) = nh;
   Nh = p(3) * 1.e22;

   //   Generate the input spectrum

   Photonspec = xfit_photspec(p);
   write,format="Sflux %.0f-%.0f keV = %12.3e erg/cm2/s\n", \
              Emin_std, Emax_std, sflux(Emin_std,Emax_std,Eline, Photonspec);

   // Note the difference between 'Countspec' that is the observed (or
   // simulated) number of counts, whereas 'Rate_model' is the result of
   // the current spectral parameter values.

   line_counts = Photonspec * (Ehi - Elo) * Arf;
   Countspec = (Matrix(,+)*line_counts(+))*Exposure;
   countspec_err = sqrt(Countspec);
   Countspec += random_n(numberof(Countspec))*countspec_err;
   Rate = Countspec / Exposure;
   Stat_err = countspec_err / Exposure;

   write,"Rate and Stat_err are now prepared for e.g. plotting";

}

/* Function xfit_nustar_init */

func xfit_nustar_init( dol_of_spec, num_spec )
/* DOCUMENT xfit_nustar_init( dol_of_spec, num_spec )

  prepare fitting an observed X-ray spectrum from j_src_spectra

   2008-05-22/NJW cloned from xfit_init.i

*/
{

   //   Setup the common areas

// ynclude = xfit_package.externs_nustar_init
  extern  Arf,         E_min,       Eline,       Matrix,      Spectrcode,  Stat_err, \
          E_max,       Ehi,         Elo,         Rate;
// yxclude =

   if( is_void(num_spec) ) num_spec = 1;
   number = num_spec;

   //   Set the rebinning i.e. avoid first 30 channels
   //   and last 56

   //+ rebin = indgen(200-30) + 30;

   //   Get the spectral data

   
   if( !is_void( dol_of_spec ) ) {
      j_get_src_spectrum, dol_of_spec, number, rate, stat_err;
      Rate = rate(rebin);
      Stat_err = stat_err(rebin);
   }


   //   Get the RMF data

   //+ j_get_pi_ebds, e_min, e_max;
   rmfname = "/home/njw/nustar/rmf.fits";
   arfname = "/home/njw/nustar/ARF_onaxis.fits";

   e_min = rdfitscol(rmfname+"+2","e_min");
   e_max = rdfitscol(rmfname+"+2","e_max");
   rebin = indgen(numberof(e_min));

   E_min = e_min(rebin);
   E_max = e_max(rebin);

   Elo = rdfitscol(rmfname+"[MATRIX]","ENERG_LO");
   Ehi = rdfitscol(rmfname+"[MATRIX]","ENERG_HI");
   Eline = sqrt(Elo*Ehi);
   matrix = rdfitscol(rmfname+"[MATRIX]","MATRIX");
   Arf = rdfitscol(arfname+"+1","SPECRESP");
   elo_Arf = rdfitscol(arfname+"+1","ENERG_LO");
   ehi_Arf = rdfitscol(arfname+"+1","ENERG_HI");
   e_Arf = 0.5*(elo_Arf + ehi_Arf);
   Arf = interp( Arf, e_Arf, Eline);

   Matrix = matrix(rebin,*);

   //   Define the spectral model

   Spectrcode = "";
   while( Spectrcode != "PL" && Spectrcode != "TB" && Spectrcode != "DF" ) {
      read,prompt="What is the spectral model? (PL,TB,DF) : ... ", \
            format="%s",Spectrcode;
      Spectrcode = strupcase(strtrim(Spectrcode));
   }


}

/* Function xfit_nustar_plot */

func xfit_nustar_plot( a )
/* DOCUMENT xfit_nustar_plot

  plots the result of rfitting
    Default is energy plot.

   NJW/2002-06-28
   2008-05-16/NJW translated to Yorick
*/
{

   //   Define the common areas

// ynclude = xfit_package.externs_nustar_plot
  extern  E_max,      E_min,      Plottitle,  Rate,       Stat_err;
// yxclude =

   window,0,style="boxed.gs";

   REBIN = 75;
   z = array(3,15); grow, REBIN, z;
   z = array(6,40); grow, REBIN, z;
   z = array(10,20); grow, REBIN, z;
   z = array(20,20); grow, REBIN, z;
   z = array(30,20); grow, REBIN, z;

   local eb1, eb2, orate, ostat_err;
   specrebinning, E_min, E_max, Rate, Stat_err, REBIN, eb1, eb2, orate, ostat_err;
   //+ w = where( Rate > Stat_err & Stat_err > 0.0 );
   //+ ymin = min((Rate(w)-Stat_err(w))/(E_max(w)-E_min(w)));
   //+ ymax = max((Rate(w)+Stat_err(w))/(E_max(w)-E_min(w)));
   //+ dataplot, 0.5*(E_min+E_max), Rate/(E_max-E_min), Stat_err/(E_max-E_min), \
   //+     yr=[ymin,ymax], xr=[5,80],  xbar=1,itype=3, \
   //+     xtitle="Energy [keV]",ytitle="Cts /s /keV",title=esc_underscore(Plottitle);
   w = where( orate > ostat_err & ostat_err > 0.0 );
   ymin = min((orate(w)-ostat_err(w))/(eb2(w)-eb1(w)));
   ymax = max((orate(w)+ostat_err(w))/(eb2(w)-eb1(w)));
   dataplot, 0.5*(eb1+eb2), orate/(eb2-eb1), ostat_err/(eb2-eb1), \
       yr=[ymin,ymax*2], xr=[3,90],  xbar=1,itype=3, \
       xtitle="Energy [keV]",ytitle="Cts /s /keV",title=esc_underscore(Plottitle);


}

/* Function xfit_photspec */

func xfit_photspec( p, eline=, spectrcode= )
/* DOCUMENT phot_spec = xfit_photspec( p, eline=, spectrcode= )


  Function that returns the photon spectrum for a
  given set of spectral parameters
  in array "p":  (norm, param1, nh/1.e22)

   Default operation uses the externals Eline and Spectrcode
   These can be overridden by the keywords.

   NJW/2002-06-28
   2011-05-11/NJW  updated with keywords

*/
{
   if( is_void(p) ) {
      write,"Syntax: flux = xfit_photspec(p)";
      return [];
   }
   if( numberof(p)  !=  3 ) {
      write,"xfit_photspec must be called with 3 element array";
      return [];
   }

   //   Define the common areas

// ynclude = xfit_package.externs_photspec
  extern  Const,       Ebase,       Eline,       Nh,          Param1,      Spectrcode;
// yxclude =

   Const = p(1);
   Param1 = p(2);
   Nh = p(3) * 1.e22;

   aEline = is_void(eline) ? Eline : eline;
   aSpectrcode = is_void(spectrcode) ? Spectrcode : strupcase(spectrcode);

   //   Generate the input spectrum


   if( aSpectrcode == "PL" ) {
                flux = Const * (aEline/Ebase)^(-Param1) * absorp(Nh, aEline);
   } else if( aSpectrcode == "TB" ) {
                // 2012-03-29  Param1 should allways > 0.1
                //+ proxy_param1 = guard( Param1, 0.1, , 0.01 );
                flux = Const * (exp(-aEline/Param1) / aEline) * absorp(Nh, aEline);
   } else if( aSpectrcode == "BB" ) {
                // 2012-03-29  Param1 should allways > 0.1
                //+ proxy_param1 = guard( Param1, 0.1, , 0.01 );
                flux = Const * (aEline^2 / (exp(aEline/Param1) - 1 )) * absorp(Nh, aEline);
   } else if( aSpectrcode == "DF" ) {
                dum = min(abs(aEline-Param1));
                index = where(dum==abs(aEline-Param1))(1);
                flux = array(double, numberof(aEline));
                flux(index) = Const * absorp(Nh, Param1);
   } else {
                write,format="No such spectral model allowed: %s\n", aSpectrcode;
                return [];
   }

   return flux;

}

/* Function xfit_plot */

func xfit_plot( frebin=, outfile=, pname=, win=, nofit= )
/* DOCUMENT xfit_plot, frebin=, outfile=, pname=, win=, nofit=

  Plots the current Rate, Stat_err

   outfile    (string) name of output text file with spectra
                <set>  the output file becomes xfit_nnnn.scm
   frebin     sets a rebinning before the plotting where the value
              is the maximal sigma/signal
   pname      is an optional plot name (string)
   win        defines plotting window (default is current)
   nofit      for plotting only data and skip the fit result

   NJW/2002-06-28
   2008-05-16/NJW translated to Yorick
*/
{

// ynclude = xfit_package.externs_plot
  extern  Const,         Dol_of_spec,   Freeze,        Nh,            Plottitle, \
          Rate_model,     E_max,         Frozen_value,  Normfit,       Rate, \
          Dol_of_bkg,    E_min,         N_freedom,     Param1,        Stat_err, \
           Emin_std, Emax_std, Spectrcode;
// yxclude =

   local oemin, oemax, orate, ostat_err, orate_model, xdum, ydum, zdum;

   if( is_void(win) ) win = 3;
   // Define two plot frames in the same window
   mplot_setup, 21, hideticklabels=1, vrelsize=[3,1], spacing=0.005, \
          vport=[0.15,0.7,0.4,0.85], pane=win;

   fstr = ["","",""];
   if( Freeze(sum) ) fstr(where(Freeze)) = " (frozen)";

   if( numberof(outfile) ) {
      if( typeof(outfile) == "string" ) {
         dump = 1;
      } else {
         outfile = get_next_filename("xfit_????.scm");
         dump = 1;
      }
   } else dump = 0;
 
   // Make sure that Rate_model is for the current parameters
   // but only if the variables exist

   if( !is_void(Const) && !is_void(Param1) && !is_void(Nh) && !nofit ) {
      chi2red = xfit_chi2( [Const, Param1, Nh*1.e-22] )/N_freedom;
      // this call updates 'Rate_model'
      sx_eline = span(Emin_std,Emax_std,200);
      flux = xfit_photspec( [Const, Param1, Nh*1.e-22], eline=sx_eline );
      sx = sflux( Emin_std, Emax_std, sx_eline, flux);
   }

   if( frebin ) {
      REBIN = specrebinninga( E_min, E_max, Rate, Stat_err, frebin, oemin, oemax, orate, ostat_err );
      specrebinning, E_min, E_max, Rate_model, Stat_err, REBIN, xdum, ydum, orate_model, zdum;
   } else {
      oemin = E_min;
      oemax = E_max;
      orate = Rate;
      ostat_err = Stat_err;
      orate_model = Rate_model;
   }

  /*
   *   Note that the Yorick peculiarity of plotting negative values on a log scale
   *   actually shows the absolute values. The negative rate values must therefore
   *   be changed to a resonable (positive) value before plotting.
   */

   wneg = where( orate <= 0.0 );
   nwneg = numberof( wneg );
   or = orate / (oemax - oemin);
   if( nwneg ) {
      wpos = where( orate >  0.0 );
      ymin = min(or(wpos));
      ymax = max(or(wpos));
      r = (ymax / ymin)^0.05;
      ymax *= r;
      ymin /= r;
      or(wneg) = ymin;
   } else {
      ymin = or(min);
      ymax = or(max);
      r = (ymax / ymin)^0.05;
      ymax *= r;
      ymin /= r;
   }

   //+ ymin = min([(orate-ostat_err)/(oemax-oemin),Countspec/(oemax-oemin)]);
   //+ ymax = max([(orate+ostat_err)/(oemax-oemin),Countspec/(oemax-oemin)]);
   //+ xmin = (0.5*(oemin+oemax))(1) * 0.98;
   //+ xmax = (0.5*(oemin+oemax))(0) * 1.02;
   xmin = oemin(1) * 0.95;
   xmax = oemax(0) * 1.05;

   // fix lower y boundaries < 0 to something positive

   ylower = orate/(oemax-oemin) - ostat_err/(oemax-oemin);
   wneg = where( ylower <= 0.0 );
   nwneg = numberof(wneg);
   if( nwneg ) ylower(wneg) = ymin;

   // fix upper y boundaries < 0 to something positive

   yupper = orate/(oemax-oemin) + ostat_err/(oemax-oemin);
   wneg = where( yupper <= 0.0 );
   nwneg = numberof(wneg);
   if( nwneg ) yupper(wneg) = ymin;

   dataplotf, oemin,sqrt(oemin*oemax), oemax,  \
       ylower, \
       //+ orate/(oemax-oemin) - ostat_err/(oemax-oemin), \
       or, \
       //+ orate/(oemax-oemin), \
       yupper, \
       //+ orate/(oemax-oemin) + ostat_err/(oemax-oemin), \
       xr=[xmin,xmax], yr=[ymin,ymax], itype=3, mpl=1, \
       ytitle="Cts /s /keV",title=esc_underscore(Plottitle), \
       xyadjust=[0.02,0.02],titlefont="times",xytitleheight=14;
   if( !is_void(orate_model) && !nofit ) oplthis,oemin, oemax, orate_model/(oemax-oemin), color="red";
   plotsign;
   if( structof(pname) == string ) plotname, pname;

   if( !nofit ) {

      ytxt = 0.55;
      dy   = 0.020;
      csize = 0.7;
      if( !is_void(chi2red) ) \
      xyouts,0.2,ytxt,swrite(format="!c^2^_red_  =     %9.3f",chi2red),ndc=1,charsize=csize;
      ytxt += dy;
      if( !is_void(sx) ) \
      xyouts,0.2,ytxt,swrite(format="S_x_ (%.0f-%.0f keV) =  %s erg/s/cm^2^", \
               Emin_std, Emax_std, f2scienota(sx,2)),ndc=1,charsize=csize;
      ytxt += dy;
      if( !is_void(Param1) ) \
      xyouts,0.2,ytxt,swrite(format="Param1   =     %9.3f%s",Param1,fstr(2)),ndc=1,charsize=csize;
      ytxt += dy;
      if( !is_void(Nh) ) \
      xyouts,0.2,ytxt,swrite(format="Nh/10^22^  =     %9.3f%s",Nh*1.e-22,fstr(3)),ndc=1,charsize=csize;
      ytxt += dy;
      if( !is_void(Const) ) {
         if( Const < 1.e-2 ) {
            xyouts,0.2,ytxt,swrite(format="Constant =     %s%s",f2scienota(Const,2),fstr(1)),ndc=1,charsize=csize;
         } else {
            xyouts,0.2,ytxt,swrite(format="Constant =     %9.3f%s",Const,fstr(1)),ndc=1,charsize=csize;
         }
      }
      ytxt += dy;
      if( !is_void(Spectrcode) ) \
      xyouts,0.2,ytxt,swrite(format="Spec model %s",Spectrcode),ndc=1,charsize=csize;

      // Plotting ratio

      if( !is_void(orate_model) ) {
         w = where( orate_model > 0.0 & orate > 0.0 );

         y = orate(w)/orate_model(w);
         ylower = orate(w)/orate_model(w) - ostat_err(w)/orate_model(w);
         yupper = orate(w)/orate_model(w) + ostat_err(w)/orate_model(w);
         ymin = y(min);
         ymax = y(max);
         r = (ymax / ymin)^0.15;
         ymax *= r;
         ymin /= r;

         // fix lower y boundaries < 0 to something positive

         wneg = where( ylower <= 0.0 );
         nwneg = numberof(wneg);
         if( nwneg ) ylower(wneg) = ymin;

         dataplotf,oemin(w), sqrt(oemin(w)*oemax(w)), oemax(w), \
            ylower, \
            //+ orate(w)/orate_model(w) - ostat_err(w)/orate_model(w), \
            y, \
            //+ orate(w)/orate_model(w), \
            yupper, \
            //+ orate(w)/orate_model(w) + ostat_err(w)/orate_model(w), \
            xr=[xmin,xmax],yr=[ymin,ymax],mpl=2,itype=3,xtitle="Energy [keV]", ytitle="Ratio", color="blue", \
             xyadjust=[0.02,0.02],titlefont="times",xytitleheight=14;
         oplot,sqrt(oemin*oemax),array(1.,numberof(oemin)),li=2,color="blue";
      }
   }

   // Dump results to file if required

   if( dump && !nofit ) {
      write,format="Saving curves in %s\n", outfile;
      hdr = [];
      grow, hdr, "// xfit results  "+ndate(3);
      grow, hdr, "// DOL_SPE = "+Dol_of_spec;
      if( numberof(Dol_of_bkg) ) grow, hdr, "// DOL_BKG = "+Dol_of_bkg;
      for( i = 1; i <= 3; i++ ) {
         if( Freeze(i) ) {
            grow, hdr,swrite(format="// freeze = %i", i);
            grow, hdr,swrite(format="// value = %f", Frozen_value(i));
         }
      }
      if( !is_void(chi2red) ) \
      grow, hdr, swrite(format="// Chi2red = %f", chi2red);
      if( !is_void(sx) ) \
      grow, hdr, swrite(format="// Sx = %e; erg/cm2/s", sx);
      if( !is_void(Const) ) \
      grow, hdr, swrite(format="// Const = %f", Const);
      if( !is_void(Param1) ) \
      grow, hdr, swrite(format="// Param1 = %f", Param1);
      if( !is_void(Nh) ) \
      grow, hdr, swrite(format="// Nh = %f; 1e22 /cm2", Nh*1.e-22);
      grow, hdr, "//";
      grow, hdr, "// colname = Energy; keV";
      grow, hdr, "// colname = Rate; cts/s";
      grow, hdr, "// colname = Stat_err; cts/s";
      grow, hdr, "// colname = Rate_model; cts/s the model";
      grow, hdr, "//";
      wstab,outfile,sqrt(E_min*E_max),Rate,Stat_err,Rate_model,hdr=hdr;
   }

}

/* Function xfit_show */

func xfit_show
/* DOCUMENT xfit_show

    For a dump to screen of the externals.
*/
{
// ynclude = xfit_package.externs_show
  extern  Dol_of_bkg,    E_max,         Ebase,         Elo,           Frozen_value, \
          Dol_of_spec,   E_min,         Ehi,           Freeze,        Spectrcode;
// yxclude =

   names = ["Const","Param1","Nh"];

   write,format="Dol_of_spec: %s\n", Dol_of_spec;
   if( is_void(Dol_of_bkg) ) {
      write,format="Dol_of_bkg: %s\n", "<not given>";
   } else {
      write,format="Dol_of_bkg: %s\n", Dol_of_bkg;
   }
   write,format="Ebase = %.3f keV, energy base for powerlaw\n", Ebase;
   write,format="E_min and E_max has %i bins from %.3f - %.3f keV\n", numberof(E_min), E_min(1), E_max(0);
   write,format="Elo and Ehi has %i elements from %.3f - %.3f keV\n", numberof(Elo), Elo(1), Ehi(0);
   write,format="Matrix, Arf, Eline exist, current spectral code: %s\n", Spectrcode;
   if( Freeze(sum) ) {
      for( i = 1; i <= 3; i++ ) {
         if( Freeze(i) ) \
         write,format="Parameter %i (%s) is frozen to %.3f\n",i, names(i), Frozen_value(i);
      }
   } else {
      write,"No frozen parameters";
   }
   write,"  Other variables:";
   write,"Arf Bins Chi2red Const Rate_model **_orig Freeze Frozen_value Nh Normfit";
   write,"Param1 Plottitle Rate Spectrcode Stat_err Sx";
   if( !is_void(Spectrcode) ) write,format="\nCurrent spectral model: %s\n", Spectrcode;

}

/* Function xfit_bins */

func xfit_bins( bins, bins2, cont= )
/* DOCUMENT xfit_bins, bins[, bins2][, cont=]

   Use a new subset of spectral bins for fitting etc.
   'bins' is void -> reset to include all bins
   'bins' is a positive scalar -> indgen(bins)
   'bins' is a negative scalar -> rebin to at lest -nbins counts in each bin
   'bins' is array -> no change
   'bins2' given and bins2 > bins (both scalar) -> indgen(bins:bins2)

    Keyword 'cont' is for 'continue' i.e. not setting it will rebin from start,
    but combined rebinning can be done by e.g.

    > xfit_bins, 100;
    > xfit_bins, -10, cont=1;

    that will use first 100 bins and then combine to have at least 10 counts in each.
*/
{
// ynclude = xfit_package.externs_bins
  extern  Bins,           E_min,          Matrix,         Rate,           Stat_err, \
          E_max,          E_min_orig,     Matrix_orig,    Rate_orig,      Stat_err_orig, \
          E_max_orig, Exposure;
// yxclude =

   if( cont ) {
      rate_start = Rate;
      stat_err_start = Stat_err;
      e_min_start = E_min;
      e_max_start = E_max;
      matrix_start = Matrix;
   } else {
      rate_start = Rate_orig;
      stat_err_start = Stat_err_orig;
      e_min_start = E_min_orig;
      e_max_start = E_max_orig;
      matrix_start = Matrix_orig;
   }

   if( is_void(bins) ) bins = indgen(numberof(rate_start));

   //   First see if 'bins' is scalar and negative

   if( is_scalar(bins) ) {
      if( bins < 0 ) {    // binning to at least -bins counts in each bin
         REBIN = specrebinningb( e_min_start, e_max_start, rate_start, stat_err_start, \
                      Exposure, double(-bins), E_min, E_max, Rate, Stat_err );
         Matrix = rebin_rdm( matrix_start, REBIN );
         write,format="New E_min/max: %.3f %.3f keV with %i bins\n", E_min(1), E_max(0), numberof(Rate);
         return;
      }
   }

   //  else apply bin specifications

   if( is_scalar(bins) ) {
      if( is_void(bins2) ) {
         bins = indgen(bins);
      } else {
         if( is_scalar(bins2) ) {
            if( bins2 > bins ) {
               bins = indgen(bins:bins2);
            } else error,"bins2 <= bins";
         } else error,"bins2 is not scalar";
      }
   }
   if( bins(0) > numberof(rate_start) ) error,"bins exceed range ("+itoa(numberof(rate_start))+")";
   Bins = bins;
   E_min = e_min_start(bins);
   E_max = e_max_start(bins);
   Matrix = matrix_start(bins,);
   Rate = rate_start(bins);
   Stat_err = stat_err_start(bins);
   write,format="New E_min/max: %.3f %.3f keV with %i bins\n", E_min(1), E_max(0), numberof(Bins);
}

/* Function xfit_ebase */

func xfit_ebase( ebase )
/* DOCUMENT xfit_ebase, new_ebase
     or     xfit_ebase

    Second version will reset to 1.0
*/
{
// ynclude = xfit_package.externs_ebase
  extern  Ebase;
// yxclude =

   Ebase = is_void(ebase) ? 1.0 : double(ebase);
}

/* Function xfit_title */

func xfit_title( plottitle )
/* DOCUMENT xfit_title, plottitle
      or    xfit_title

     Second version sets the title to an empty string
*/
{
// ynclude = xfit_package.externs_title
  extern  Plottitle;
// yxclude =

   Plottitle = is_void(plottitle) ? "" : plottitle;
}

/* Function xfit_freeze */

func xfit_freeze( parnum, val )
/* DOCUMENT  xfit_freeze, parnum, val

    'val' must be the parameter value that goes into the p array
    For Nh it should be Nh/1e22
*/
{

// ynclude = xfit_package.externs_freeze
  extern  Freeze,        Frozen_value;
// yxclude =

   Freeze(parnum) = 1;
   Frozen_value(parnum) = val;
}

/* Function xfit_thaw */

func xfit_thaw( parnum )
/* DOCUMENT  xfit_thaw, parnum
*/
{

// ynclude = xfit_package.externs_thaw
  extern  Freeze;
// yxclude =

   Freeze(parnum) = 0;
}

/* Function xfit_tune */

func xfit_tune
/* DOCUMENT xfit_tune

    Adjust the errors of observation to give a reduced Chi2 of 1.0
    for the current selection of bins.
*/
{
// ynclude = xfit_package.externs_tune
  extern  Chi2min,    Chi2red,    N_freedom,  Stat_err;
// yxclude =

   Stat_err *= sqrt(Chi2red);
   Chi2min = double(N_freedom);
}

/* Function xfit_pargrid */

func xfit_pargrid( dim1, dim2, range1, range2, win=  )
/* DOCUMENT xfit_pargrid, dim1, dim2[, range1, range2], win=

    Produces a 2D plot in window #2 or as defined by keyword 'win'

*/
{
// ynclude = xfit_package.externs_pargrid
  extern  Chi2min,       Delta_const,   Nh_bf,         Pargrid_arr,   Plottitle, \
          Const_bf,      Delta_param1,  Param1_bf;
// yxclude =
 
   if( is_void(win) ) win = 2;

   Pargrid_arr = array(double,dim1, dim2);
   p = [Const_bf, Param1_bf, Nh_bf*1.e-22];

   if( is_void(range1) ) range1 = Delta_const;
   if( is_void(range2) ) range2 = Delta_param1;
   vals1 = span(  Const_bf - 0.5*range1,  Const_bf + 0.5*range1, dim1 );
   vals2 = span(  Param1_bf - 0.5*range2,  Param1_bf + 0.5*range2, dim2 );
   for( i = 1; i <= dim1; i++ ) {
      for( j = 1; j <= dim2; j++ ) {
         p(1) = vals1(i);
         p(2) = vals2(j);
         Pargrid_arr(i,j) = xfit_chi2( p ) - Chi2min;
      }
   }
   window,win;
   dispc,Pargrid_arr,xax=vals1,yax=vals2,levels=[2.28,4.6,9.21],over=1, \
        title=esc_underscore(Plottitle),xtitle="Const",ytitle="Param1";
   oplot,[Const_bf],[Param1_bf],ps=12,thick=5,color="white",symsize=1.2;
}

/* Function xfit_chi2_1d_1 */

func xfit_chi2_1d_1( x )
{
// ynclude = xfit_package.externs_chi2_1d_1
  extern  Chi2min,  Level,    Pcur;
// yxclude =

   // x is p(1)

   Pcur(1) = x;
   return xfit_chi2( Pcur ) - Chi2min - Level;

}

/* Function xfit_chi2_1d_2 */

func xfit_chi2_1d_2( x )
{
// ynclude = xfit_package.externs_chi2_1d_2
  extern  Chi2min,  Level,    Pcur;
// yxclude =

   // x is p(2)

   Pcur(2) = x;
   return xfit_chi2( Pcur ) - Chi2min - Level;

}

/* Function xfit_chi2_1d_angle */

func xfit_chi2_1d_angle( xi )
{
// ynclude = xfit_package.externs_chi2_1d_angle
  extern  Angle,         Const_bf,      Delta_param1,  Param1_bf,     Pcur, \
          Chi2min,       Delta_const,   Level;
// yxclude =

   // x is p(2)

   Pcur(1) = Const_bf + Delta_const * xi * cos(Angle);
   Pcur(2) = Param1_bf + Delta_param1 * xi * sin(Angle);

   return xfit_chi2( Pcur ) - Chi2min - Level;

}

/* Function xfit_anamin */

func xfit_anamin( astep= )
/* DOCUMENT xfit_anamin[, astep=]

     Scans the const vs. param1 space for 99% confidence interval.

     Keyword 'astep' is angular step (in radians, defaults to 0.1*pi).
*/
{
// ynclude = xfit_package.externs_anamin
  extern  Angle,         Delta_const,   Logfilename,   Nh_bf,         Pcur, \
          Chi2red,       Delta_param1,  Logflag,       Param1_bf,     Specfile, \
          Const_bf,      Level,         Nh;
// yxclude =

   if( is_void(astep) ) astep = 0.1*pi;

  /*
   *  Locate the 99% confidence limits for Pcur(1) == Const
   *  corresponding to chi2 = Chi2min + 9.21
   */

   Pcur = [Const_bf, Param1_bf, Nh_bf*1.e-22];
   Level = 9.21;
   //  Search to the right
   tol = 1.e-5;
   ax = bx = Const_bf;
   do {
      bx *= 1.01;
      fb = xfit_chi2_1d_1(bx);
   } while ( fb <= 0. );
   const_max = zbrent( xfit_chi2_1d_1, ax, bx, tol );

   //  Search to the left
   ax = bx = Const_bf;
   do {
      bx *= 0.99;
      fb = xfit_chi2_1d_1(bx);
   } while ( fb <= 0. );
   const_min = zbrent( xfit_chi2_1d_1, ax, bx, tol );

   Delta_const = const_max - const_min;
   write,format="99%% confid. interval for Const: %.4f - %.4f (range %.4f)\n", \
                                      const_min, const_max, Delta_const;
   write,format="     for Param1 = %.4f and Nh/1e22 = %.4f\n", Param1_bf, Nh_bf*1.e-22;

  /*
   *  Locate the 99% confidence limits for Pcur(2) == Param1
   *  corresponding to chi2 = Chi2min + 9.21
   */

   Pcur = [Const_bf, Param1_bf, Nh_bf*1.e-22];
   //  Search to the right
   tol = 1.e-5;
   ax = bx = Param1_bf;
   do {
      bx *= 1.01;
      fb = xfit_chi2_1d_2(bx);
   } while ( fb <= 0. );
   param1_max = zbrent( xfit_chi2_1d_2, ax, bx, tol );

   //  Search to the left
   ax = bx = Param1_bf;
   do {
      bx *= 0.99;
      fb = xfit_chi2_1d_2(bx);
   } while ( fb <= 0. );
   param1_min = zbrent( xfit_chi2_1d_2, ax, bx, tol );

   Delta_param1 = param1_max - param1_min;
   write,format="99%% confid. interval for Param1: %.4f - %.4f (range %.4f)\n", \
                                      param1_min, param1_max, Delta_param1;
   write,format="     for Const = %.4f and Nh/1e22 = %.4f\n", Const_bf, Nh_bf*1.e-22;

   // Search various angles

   for( Angle = pi*0.2; Angle < 2*pi; Angle += astep ) {
      xi = 0.;
      do {
         xi += 0.1;
         fb = xfit_chi2_1d_angle( xi );
      } while( fb <= 0.0 );
      ximin = zbrent( xfit_chi2_1d_angle, 0., xi, tol );
      c = Const_bf + Delta_const * ximin * cos(Angle);
      if( c > const_max ) const_max = c;
      if( c < const_min ) const_min = c;
      c = Param1_bf + Delta_param1 * ximin * sin(Angle);
      if( c > param1_max ) param1_max = c;
      if( c < param1_min ) param1_min = c;
   }
   Delta_const = const_max-const_min;
   Delta_param1 = param1_max-param1_min;
   write,format="99%% confid. interval for Const: %.4f - %.4f (range %.4f)\n", \
                                      const_min, const_max, const_max-const_min;
   write,format="99%% confid. interval for Param1: %.4f - %.4f (range %.4f)\n", \
                                      param1_min, param1_max, param1_max-param1_min;

   if( Logflag ) {
      flog = open(Logfilename,"a");
      write,flog,format="// called xfit_anamin ...%s","\n";
      s = structof(Specfile) == string ? Specfile : "from \"xfit_fakeit\"";
      write,flog,format=" %12.3e %12.3e %.4f %.4f %.4f %.4f %.4f %s\n", Const_bf, 0.5*Delta_const, \
               Param1_bf, 0.5*Delta_param1, Nh*1.e-22, 0., Chi2red, s;
      close, flog;
   }
}

/* Function xfit_read */

func xfit_read( rmffile, arffile )
/* DOCUMENT xfit_read, rmffile, arffile

   Load the Matrix, Elo, Ehi, Eline, E_min, E_max for the
   relevant instrument.

   2011-09-07/NJW cloned from xfit_nustar_init.i

*/
{

// ynclude = xfit_package.externs_read
  extern  Arf,     E_max,   E_min,   Ehi,     Eline,   Elo,     Matrix, \
          E_min_orig, E_max_orig, Matrix_orig;
// yxclude =

   local elo, ehi, emin, emax;

   //   Get the RMF data

   Matrix_orig = Matrix = read_ogip_rmf( rmffile, elo, ehi, emin, emax );

   E_min_orig = E_min = emin;
   E_max_orig = E_max = emax;

   Elo = elo;
   Ehi = ehi;
   Eline = sqrt(Elo*Ehi);

   //    Get the ARF

   Arf = rdfitscol(arffile+"+1","SPECRESP");
   elo_Arf = rdfitscol(arffile+"+1","ENERG_LO");
   //+ ehi_Arf = rdfitscol(arffile+"+1","ENERG_HI");
   //  --- NB temporary fix for LOFT WFM data
   ehi_Arf = rdfitscol(arffile+"+1","ENERGY_HI");
   e_Arf = 0.5*(elo_Arf + ehi_Arf);
   Arf = interp( Arf, e_Arf, Eline);

   write,"Elo, Ehi, Matrix, Arf, E_min, and E_max have been loaded ...";
}

/* Function xfit_fakeit */

func xfit_fakeit( bkgdol, fbkg=, openfrac=, sc=, cst=, p1=, nh=, expo=, ia= )
/* DOCUMENT xfit_fakeit, bkgdol, fbkg=, openfrac=, sc=, cst=, p1=, nh=, expo=, ia=

    Simulate an observation using the ARF and RMF previously loaded by
    xfit_read.

    Giving the DOL of a background will include it in the simulation and fitting.
    The background table is assumed to be number of counts per detector channel
    in the time given by the EXPOSURE keyword on the entire detector.

    The keyword 'openfrac' will attenuate the background actually used with this
    factor (applies for a coded mask instrument).

    It is assumed that the open fraction for the source is covered by the Arf.

    The keyword 'fbkg' will distinguish between the two cases:
       1) The background is determined in the same observation as the source
          so it is determined with a statistical error with a possibility
          to 'overobserve' with a factor, namely fbkg. (fbkg > 0, usually 1,
          but can be 3 as for a 0.25 coded mask).
       2) The background is determined in a long observation so that
          a perfect subtraction can be done (fbkg is not set)
       This is inspired by the discussions around 2011-09-04 with Soren Brandt and
       Jerome Chenevez.

    keywords:
        sc:    Spectral code, "pl", "tb", "bb", or "df"
       cst:    Normalization
        p1:    Spectral parameter
        nh:    Column density in units of 1.e22 cm-2
      expo:    Exposure time in seconds
        ia:    Sets interactive mode

    2011-09-07/NJW cloned from xfit_nustar_fakeit
*/
{

   //   Define the externals

// ynclude = xfit_package.externs_fakeit
  extern  Arf,          Const,        Eline,        Nh,           Spectrcode, \
          Bkgexposure,  Countspec,    Elo,          Param1,       Stat_err, \
          Bkgspec,      Bkgrate, Ebase,        Matrix,       Rate,         Use_bkg, \
          Bkgspec_err,  Ehi,  Photonspec, Emin_std, Emax_std, N_freedom,  \
          Parfilename, Exposure, Fbkg, Logflag, Logfilename, Rate_orig, Stat_err_orig, \
          Matrix_orig;
// yxclude =

   if( is_void(openfrac) ) openfrac = 1.0;
   if( is_void(Ebase) ) Ebase = 1.; // [keV] pivot point for spectra
   if( is_void(bkgdol) ) {
      Use_bkg = 0;
   } else {
      local bkgfile, bkgext;
      get_exten_no, bkgdol, bkgfile, bkgext;

      if( !file_test(bkgfile) ) error,"Bkg file was not found";
      hdr = headfits( bkgdol );
      // reduce the background counts with the open fraction
      Bkgspec = openfrac*rdfitscol( bkgdol, "COUNTS" );
      Bkgspec_err = sqrt(Bkgspec);
      Bkgexposure = fxpar( hdr, "exposure" );
      Use_bkg = 1;
   }

   p = array(double,3);

   if( ia ) {
      Spectrcode = "";
      read,prompt="Enter spectrcode : ... ",format="%s", Spectrcode;
      Spectrcode = strupcase(Spectrcode);
      Const = 1.0; Param1 = 1.0; nhcol = 1.0;
      read,prompt="Enter constant : ... ",format="%f", Const;
      read,prompt="Enter param1   : ... ",format="%f", Param1;
      read,prompt="Enter NH/1.e22 : ... ",format="%f", nhcol;
      Exposure = 1.0;
      read,prompt="Enter exposure : ... ",format="%f", Exposure;
   } else {
      Const = numberof(cst) ? double(cst) : get_par( Parfilename, "const" );
      Spectrcode =  numberof(sc) ? strupcase(sc) : get_par( Parfilename, "spectrcode" );
      Param1 = numberof(p1) ? double(p1) : get_par( Parfilename, "param1" );
      nhcol = numberof(nh) ? double(nh) : get_par( Parfilename, "nh" ); // in units of 1.e22
      Exposure = numberof(expo) ? double(expo) : get_par( Parfilename, "exposure" );
   }
   set_par, Parfilename, "spectrcode", Spectrcode;
   set_par, Parfilename, "const", Const;
   set_par, Parfilename, "param1", Param1;
   set_par, Parfilename, "nh", nhcol;
   set_par, Parfilename, "exposure", Exposure;

   p(1) = Const;
   p(2) = Param1;
   p(3) = nhcol;
   Nh = p(3) * 1.e22;

   //   Generate the input photon spectrum

   Photonspec = xfit_photspec(p);
   write,format="Sflux %.0f-%.0f keV = %12.3e erg/cm2/s\n", \
              Emin_std, Emax_std, sflux(Emin_std,Emax_std,Eline, Photonspec);

   if( Logflag ) {
      fh = open( Logfilename, "a" );
      write,fh,format="// Call xfit_fakeit with ...%s","\n";
      write,fh,format="// Spectrcode = %s\n", Spectrcode;
      write,fh,format="// Const = %10.4f\n", Const;
      write,fh,format="// Param1 = %10.4f\n", Param1;
      write,fh,format="// Nh = %13.2e\n", nhcol*1.e22;
      write,fh,format="// Exposure = %13.2e\n", Exposure;
      write,fh,format="// Sflux %.0f-%.0f keV = %12.3e erg/cm2/s\n", \
              Emin_std, Emax_std, sflux(Emin_std,Emax_std,Eline, Photonspec);
      if( Use_bkg ) {
         write,fh,format="// dol_bkg = %s\n", bkgdol;
         if( fbkg ) {
            write,fh,format="// fbkg = %10.2f\n", fbkg;
         } else write, fh, format="// inf bkg determination%s","\n";
         write,fh,format="// openfraction = %10.5f\n", openfrac;
      } else write,fh,format="// no bkg used%s","\n";
      close, fh;
   }


   line_counts = Photonspec * (Ehi - Elo) * Arf;
   Countspec = (Matrix_orig(,+)*line_counts(+))*Exposure; // expected count spectrum
   //+ Countspec += random_n(numberof(Countspec))*countspec_err;

   // Note the difference between 'Countspec' that is the observed (or
   // simulated) number of counts, whereas 'Rate_model' is the result of
   // the current spectral parameter values.

   //  Add counting statistics for realistic simulation
   Countspec = poisson(Countspec);

   // Add background if supplied

   if( Use_bkg ) {
      Bkgspec *= (Exposure/Bkgexposure); // rescale to observation
      Countspec += poisson(Bkgspec);
      Fbkg = fbkg;
      if( fbkg ) Bkgspec = poisson(fbkg*Bkgspec)/fbkg;
      Bkgrate = Bkgspec / Exposure;
   }
   countspec_err = sqrt(Countspec); // usual expression
   Rate = Countspec / Exposure;
   if( Use_bkg ) Rate -= Bkgrate;
   Stat_err = countspec_err / Exposure;
   Rate_orig = Rate;
   Stat_err_orig = Stat_err;

   N_freedom = numberof(Rate) - 3; // to update the external for e.g. xfit_plot

   write,"Rate(_orig) and Stat_err(_orig) are now prepared for e.g. fitting and plotting.";
   if( Use_bkg ) write,"Bkgspec and Bkgrate have been loaded as well.";

}
%FILE% xray.i
extern xraydoc;
/* DOCUMENT **********************************
    A collection of useful functions in connection
    with X-ray astronomy

     2007-06-14/NJW
     2010-12-01/NJW updated with spec_info and spec2phaii from jemx.i

        absorp          Interstellar absorption coefficient
        add_peak_1d     Add gaussian peak to spectrum
        add_phaii_spectra   Add the PHAII format spectra from given X-ray source
        add_p2spectra   Alias for add_phaii_spectra
        cross_sect      Interstellar absorption cross section
        mk_photflux     Produce FITS file with photon flux (ph/cm2/s/keV)
        predict_cr      Predict countrate given an ARF and Eline + Flux
        rd_arf          Read an ARF, PHAI or PHAII
        rd_photflux     Read the output file from 'mk_photflux' to create Eline + Flux
        read_effa       Read energy and eff. area columns
        plot_effa       Plot effective area
        plot_2effas     Plot two effective area curves and their ratio
        sflux           Photon flux integration
        spec_info       Report from PHAII spectral file
        spec2phaii      Write spectra to PHAII format file
        specbinning     Binning an energy array into a spectrum
        specrebinning   Rebinning of a spectrum
        specrebinninga  Rebinning of a spectrum to a given fraction drate/rate
        specrebinningb  Rebinning of a spectrum to a given number of counts

******************************************************/

extern presetdoc;
/* DOCUMENT
     Extit    "Energy [keV]"
     Fytit    "Flux [ph cm^-2^s^-1^keV^-1^]"
*/
Extit = "Energy [keV]";
Fytit = "Flux [ph cm^-2^s^-1^keV^-1^]";

/* Function absorp */

func absorp( nh, earr )
/* DOCUMENT res = absorp( nh, earr )

  Returns the interstellar cold absorption
  given the column density value, nh.

     NJW, some time in the past ~1998
*/
{

   if( is_void(earr) ) {
      write,"Syntax: res = absorp( nh, earr)";
      return [];
   }

   n = numberof(earr);
   res = array(double,n);
   for( i = 1; i <= n; i++) res(i) = exp(-nh*cross_sect(earr(i)));
   return res;
}

/* Function cross_sect */

func cross_sect( energy )
/* DOCUMENT res = cross_sect( energy )

 Morrison && McCammon interstellar matter cross sections
 ApJ 270 (1983) 119

 The energy is in keV && returned cross section in cm-2

  ~1998/NJW
*/
{
   ebound=[ 0.100,0.284,0.400,0.532,0.707, \
          0.867,1.303,1.840,2.471,3.210,4.038, \
          7.111,8.331,10.00];
   coeff = array(double,3,14);
   coeff(,1) = [ 17.3,  608.1, -2150.0 ];
   coeff(,2) = [ 34.6,  267.9,  -476.1 ];
   coeff(,3) = [ 78.1,   18.8,     4.3 ];
   coeff(,4) = [ 71.4,   66.8,   -51.4 ];
   coeff(,5) = [   95.5,  145.8,   -61.1 ];
   coeff(,6) = [ 308.9, -380.6,   294.0 ];
   coeff(,7) = [  120.6,  169.3,   -47.7 ];
   coeff(,8) = [ 141.3,  146.8,   -31.5 ];
   coeff(,9) = [  202.7,  104.7,   -17.0 ];
   coeff(,10) = [ 342.7,   18.7,     0.0 ];
   coeff(,11) = [ 352.2,   18.7,     0.0 ];
   coeff(,12) = [ 433.9,   -2.4,    0.75 ];
   coeff(,13) = [  629.0,   30.9,     0.0 ];
   coeff(,14) = [ 701.2,   25.2,     0.0];
   i = 1;
   while( energy  >=  ebound(i) && i  <  14 ) i++;
   csect = coeff(1,i) + energy * (coeff(2,i) + energy * coeff(3,i));
   return 1.e-24 * csect / (energy^3);
}

/* Function sflux */

func sflux( e1, e2, earr, spectrum, kev= )
/* DOCUMENT sx = sflux( e1, e2, earr, spectrum, kev= )

  Calculate source strength (S) in erg cm-2 s-1
  from e1 to e2 of "spectrum" where "earr" is the
  energy scale

  Keyword  kev : When set the conversion to erg is skipped

*/
{
   if( is_void(spectrum) ) {
      write,"SFLUX syntax: sx = sflux( e1, e2, energy_array, spectrum )";
      return [];
   }
   n = numberof(earr);
   if( n  !=  numberof(spectrum) ) {
     write,"Arrays do not match";
     return [];
   }
   delta_e = earr - shift(earr, -1);
   delta_e(1) = delta_e(2);
   index = where( (e1  <  earr) & (e2  >=  earr) );

   res_kev = sum(delta_e(index)*earr(index)*spectrum(index));
   return kev ? res_kev : res_kev * 1.6e-9;

}

/* Function specrebinning */

func specrebinning( eb1, eb2, rate, rate_err, rebin, &ob1, &ob2, &orate, &orate_err )
/* DOCUMENT specrebinning, eb1, eb2, rate, rate_err, rebin, >ob1, >ob2, >orate, >orate_err

   Combine an integer number of input spectral bins to an output spectral bin
   by addition (errors are added quadratically) i.e. 'rate' is NOT per keV but
   per bin.

   eb1, eb2 are the input bin boundaries, rate and rate_err the spectrum.
   rebin is an array (integer) where each element is the number of input
   bins to combine into the next output bin.

   Negative values in 'rebin(i)' means skipping -rebin(i) values in the original spectrum.

   The resulting bin boundaries are ob1 and ob2 and the resulting spectrum
   is given by orate and orate_err.

   SEE ALSO: specrebinninga, specrebinningb

   2008-01-01(?)/NJW
*/
{
   nreb = numberof(rebin);
   nrate = numberof(rate);
   if( sum(abs(rebin)) < nrate ) {
      write,"Insufficient rebinning information";
      return;
   }

   ob1 = [];
   ob2 = [];
   orate = [];
   orate_err = [];

   k = 1;
   for( i = 1; i <= nreb; i++ ) {
      if( k > nrate ) break;
      if( rebin(i) < 0 ) {
         k += -rebin(i);
      } else {
         rsum = 0.0;
         errsum = 0.0;
         grow, ob1, eb1(k);
         for( j = 1; j <= rebin(i); j++ ) {
            if( k > nrate ) break;
            rsum += rate(k);
            errsum += rate_err(k)^2;
            k++;
         }
         grow, orate, rsum;
         grow, orate_err, sqrt(errsum);
         grow, ob2, eb2(k-1);
      }
   }
}


/* Function specrebinninga */

func specrebinninga( eb1, eb2, rate, rate_err, frac, &ob1, &ob2, &orate, &orate_err )
/* DOCUMENT specrebinninga, eb1, eb2, rate, rate_err, frac, >ob1, >ob2, >orate, >orate_err
            rebinarr = specrebinninga( eb1, eb2, rate, rate_err, frac, >ob1, >ob2, >orate, >orate_err )

   Combine an integer number of input spectral bins to an output spectral bin
   in such a way that orate_err/orate < frac if at all possible.
   Bin values are added (errors are added quadratically) i.e. 'rate' is NOT per keV but
   per bin.

   eb1, eb2 are the input bin boundaries, rate and rate_err the spectrum.

   The resulting bin boundaries are ob1 and ob2 and the resulting spectrum
   is given by orate and orate_err.

   The function returns rebinarr which is an array (integer) where each element
   is the number of input bins to combine into the next output bin such as
   required for 'specrebinning'.

   2010-11-23/NJW
*/
{
   ob1 = [];
   ob2 = [];
   orate = [];
   orate_err = [];
   ob1 = eb1;
   ob2 = eb2;

   n_in = numberof(rate);
   rebinarr = array(1,n_in);
   k_in = 1;
   k_out = 1;

   while( k_in <= n_in ) {
      ob1(k_out) = eb1(k_in);
      rate_out = rate(k_in);
      rate_out_err2 = rate_err(k_in)^2;
      rate_out_err = sqrt(rate_out_err2);
      test_frac = rate_out <= 0.0 ? frac + 1. : rate_out_err/rate_out;
      while( test_frac > frac ) {
         rebinarr(k_out)++;
         k_in++;
         if( k_in > n_in ) {
            k_in = n_in;
            break;
         }
         rate_out += rate(k_in);
         rate_out_err2 += rate_err(k_in)^2;
         rate_out_err = sqrt(rate_out_err2);
         test_frac = rate_out <= 0.0 ? frac + 1. : rate_out_err/rate_out;
      }
      ob2(k_out) = eb2(k_in);
      grow, orate, rate_out;
      grow, orate_err, rate_out_err;
      k_out++;
      k_in++;
   }
   // see if last value passes the test
   test_frac = orate(0) <= 0.0 ? frac + 1. : orate_err(0)/orate(0);
   n_out = numberof(orate);
   if( n_out > 1 && test_frac > frac ) {
      n_out--;
      orate = orate(1:-1);
      orate_err = orate_err(1:-1);
   }
   ob1 = ob1(1:n_out);
   ob2 = ob2(1:n_out);

   rebinarr = rebinarr(1:n_out);
   if( rebinarr(sum) < n_in ) grow, rebinarr, rebinarr(sum) - n_in - 1;
                  // A negative value will skip the rest

   return rebinarr;
}


/* Function specrebinningb */

func specrebinningb( eb1, eb2, rate, rate_err, exposure, mincts, &ob1, &ob2, &orate, &orate_err )
/* DOCUMENT specrebinningb, eb1, eb2, rate, rate_err, exposure, mincts, >ob1, >ob2, >orate, >orate_err
            rebinarr = specrebinningb( eb1, eb2, rate, rate_err, exposure, mincts, >ob1, >ob2, >orate, >orate_err )

   Combine an integer number of input spectral bins to an output spectral bin
   in such a way that the number of counts equal or exceed 'mincts' if at all possible.
   Bin values are added (errors are added quadratically) i.e. 'rate' is NOT per keV but
   per bin.

   eb1, eb2 are the input bin boundaries, rate and rate_err the spectrum.

   The resulting bin boundaries are ob1 and ob2 and the resulting spectrum
   is given by orate and orate_err.

   The function returns rebinarr which is an array (integer) where each element
   is the number of input bins to combine into the next output bin such as
   required for 'specrebinning'.

   SEE ALSO:  specrebinning, specrebinninga

   2012-03-29/NJW, based on specrebinninga
*/
{
   ob1 = [];
   ob2 = [];
   orate = [];
   orate_err = [];
   ob1 = eb1;
   ob2 = eb2;

   n_in = numberof(rate);
   rebinarr = array(1,n_in);
   k_in = 1;
   k_out = 1;

   while( k_in <= n_in ) {
      ob1(k_out) = eb1(k_in);
      rate_out = rate(k_in);

      rate_out_err2 = rate_err(k_in)^2;

      while( rate_out*exposure < mincts ) {
         rebinarr(k_out)++;
         k_in++;
         if( k_in > n_in ) {
            k_in = n_in;
            break;
         }
         rate_out += rate(k_in);
         rate_out_err2 += rate_err(k_in)^2;
      }
      ob2(k_out) = eb2(k_in);
      grow, orate, rate_out;
      grow, orate_err, sqrt(rate_out_err2);
      k_out++;
      k_in++;
   }
   // see if last value passes the test
   n_out = numberof(orate);
   if( n_out > 1 && orate(n_out)*exposure < mincts ) {
      n_out--;
      orate = orate(1:-1);
      orate_err = orate_err(1:-1);
   }
   ob1 = ob1(1:n_out);
   ob2 = ob2(1:n_out);

   rebinarr = rebinarr(1:n_out);
   if( rebinarr(sum) < n_in ) grow, rebinarr, rebinarr(sum) - n_in - 1;
                  // A negative value will skip the rest

   return rebinarr;
}


/* Function specbinning */

func specbinning( e_evts, eb1, eb2, &rate, &rate_err, exposure=, perkev=, silent= )
/* DOCUMENT specbinning, e_evts, eb1, eb2, >rate, >rate_err, exposure=, perkev=, silent=

   Produce an energy spectrum from an array of event energies

   Calls:
      e_evts   :  array of energies
      eb1 and eb2: Energy bin boundaries (they need not be contiguous but no overlap
                         is accepted).
   Returns:
      rate     : number of counts per bin
      rate_err : statistical error (Poisson)
   Keywords:
      exposure : Time interval; if given then rate and rate_err will be divided
                     with this value
      perkev   : If set, then rate and rate_err will be per energy unit (i.s.o. per bin)
      silent   : To suppress screen messages

   2009-03-06/NJW
*/
{

   nevs = numberof( e_evts );
   nbins = numberof(eb1);
   if( nbins != numberof(eb2) ) error,"SPECBINNING Error ##1## mismatching numbers of boundaries";
   d = eb2(1:nbins-1) - eb1(2:nbins);
   if( anyof( d < 0.0 ) ) error,"SPECBINNING Error ##2## overlapping energy boundaries";
   wb = eb2 - eb1;
   if( anyof(wb <= 0.0) ) error,"SPECBINNING Error ##3## zero size energy bins";

// populate the energy bins

   rate = rate_err = array(double, nbins);
   ntot = 0;
   for( i = 1; i <= nbins; i++ ) {
      w = where( e_evts >= eb1(i) & e_evts < eb2(i) );
      nw = numberof(w);
      rate(i) = double(nw);
      ntot += nw;
   }
   rate_err = sqrt(rate);
   if( !is_void(exposure) ) {
      if(!silent)write,"SPECBINNING exposure corrected";
      rate /= exposure;
      rate_err /= exposure;
   }
   if( perkev ) {
      if(!silent)write,"SPECBINNING spectrum per energy unit";
      rate /= wb;
      rate_err /= wb;
   }

}

/* Function add_peak_1d */

func add_peak_1d( ener, flux, eline, sigma, ampl, rel= )
/* DOCUMENT new_flux = add_peak_1d( ener, flux, eline, sigma, ampl, rel= )

   Add a Gaussian peak to a 1D array - return the new flux.

   2009-03-06/NJW cloned from IDL version 'add_peak_1d.pro'
*/
{

   if( rel ) {
      fluxline = flux * ampl*exp(-0.5*(((ener-eline)/sigma)^2));
   } else {
      fluxline = ampl*exp(-0.5*(((ener-eline)/sigma)^2));
   }
   orig_flux_at_line = interp( flux, ener, eline );
   equi_width = sum(fluxline(zcen)*ener(dif)) / orig_flux_at_line;
   write,format="Equivalent width = %10.3e keV\n", equi_width;
   return flux + fluxline;

}

/* Function mk_photflux */

func mk_photflux(sc=,nh=,norm=,p1=,e1=,e2=,nchan=,nof=,outfile=,mem=,silent=)
/* DOCUMENT mk_photflux,sc=,nh=,norm=,p1=,e1=,e2=,nchan=,nof=,outfile=,mem=,silent=

   Takes no argument, just keywords. It will ask for the
   missing parameters ('nh' in /cm2).
   A mk_photflux.par file is used as (suggestive) input.
   If it does not exist it is created in the current directory.

   External variables defined: Eline, Flux, and Sx_photflux

   Keyword 'nof' will prevent file writing
   Keyword 'mem' will save the result to memory using 'mem_save'
                 from package 'mem_storage.i' with 'outfile' plus
                 column name as identifier.
                 If 'mem' is 1 then the ENERG_LO and ENERG_HI will be saved
                 with these identifiers else the 'outfile' will be used for
                 the 'Flux' array.

   2010-04-16/NJW Updated, 2013-01-24/NJW updated with memory option
*/
{
   extern Elo, Ehi, Eline, Spectrcode;
   extern Const, Param1, Nh;
   extern Flux, Sx_photflux;
   extern Ebase;

   if( !file_test("mk_photflux.par") ) {
      fh = open("mk_photflux.par","w");
      write,fh,format="// Spectrcode = %s\n","PL";
      write,fh,format="// Const = %f\n",10.;
      write,fh,format="// Param1 = %f\n",1.5;
      write,fh,format="// Nh = %e\n",1.5e22;
      write,fh,format="// Energy_start = %f\n",5.;
      write,fh,format="// Energy_stop = %f\n",80.;
      write,fh,format="// NumChans = %i\n",80;
      close, fh;
   }

   if( is_void(sc) ) {
      Spectrcode = strupcase(get_spars("mk_photflux.par","Spectrcode"));
   } else {
      if( typeof(sc) != "string" ) error,"sc must be a string";
      sc = strupcase(sc);
      if( noneof(sc == ["PL","BB","TB","DF"]) ) error,"sc must be PL, BB, TB, or DF";
      Spectrcode = sc;
   }
   if( is_void(norm) ) {
      Const = get_spar("mk_photflux.par","Const");
   } else Const = double(norm);
   if( is_void(p1) ) {
      Param1 = get_spar("mk_photflux.par","Param1");
   } else Param1 = double(p1);
   if( is_void(nh) ) {
      Nh = get_spar("mk_photflux.par","Nh");
   } else Nh = double(nh);
   if( is_void(e1) ) {
      Energy_start = get_spar("mk_photflux.par","Energy_start");
   } else Energy_start =  double(e1);
   if( is_void(e2) ) {
      Energy_stop = get_spar("mk_photflux.par","Energy_stop");
   } else Energy_stop =  double(e2);
   if( is_void(nchan) ) {
      NumChans = get_spar("mk_photflux.par","NumChans",lng=1);
   } else NumChans = long(nchan);

   b = spanl(Energy_start, Energy_stop, NumChans+1);
   Elo = energ_lo = b(1:-1);
   Ehi = energ_hi = b(2:0);
   Eline = sqrt(energ_lo*energ_hi);

   Flux = xfit_photspec( [Const, Param1, Nh/1.e22] );

   Sx_photflux = sflux(Energy_start,Energy_stop, Eline, Flux);

   if( mem ) { // save result to memory
      if( mem == 1 ) { // save the energy boundaries
         mem_save,"ENERG_LO", energ_lo;
         mem_save,"ENERG_HI", energ_hi;
      }
      savname = is_void(outfile) ? "flux" : outfile;
      mem_save,savname,Flux;
   }

   if( !nof ) {
      kwds_init;
      kwds_set,"EXTNAME","PHOTON_FLUX","Name of extension";
      kwds_set,"DATE",ndate(3),"Date and time of creation";
      kwds_set,"ORIGIN","mk_photflux.i","Software used";
      kwds_set,"CODE",Spectrcode,"Spectral type";
      kwds_set,"EBASE",Ebase,"Pivot energy for spectrum";
      kwds_set,"CONST",Const,"Normalization constant";
      kwds_set,"PARAM1",Param1,"Parameter 1 photindex or kT";
      kwds_set,"NH",Nh,"[/cm2] Column density";
      kwds_set,"E_MIN",Energy_start,"[keV] Lower energy limit";
      kwds_set,"E_MAX",Energy_stop,"[keV] Upper energy limit";
      kwds_set,"SX",Sx_photflux,"[erg/cm2/s] Integrated flux from E_MIN to E_MAX";

      if( is_void(outfile) ) {
         outfile = get_next_filename("photflux_????.fits");
         if(!silent) write,format="Has defined new output filename: %s\n", outfile;
      } else {
         if( !silent ) write,format="Keeps the keyword output filename: %s\n", outfile;
      }
      wrmfitscols, outfile, "ENERG_LO", energ_lo, "ENERG_HI", energ_hi, \
                "PHOTFLUX", Flux, clobber=1;
      if( !silent) write,format="Has written file: %s\n", outfile;
   }
   if( !silent ) {
      write,format="Sx (%4.1f-%4.1f keV) = %9.2e erg/cm2/s\n", Energy_start, Energy_stop, Sx_photflux;
      if( !is_void(Exposure) ) {
         write,format="Photon density: %.2f /mm2\n", sum(Flux*(Ehi-Elo))*1.e-2*Exposure;
         write,format="      with an Exposure of %.1f s\n", Exposure;
      }
   }
 
}

/* Function rd_arf */

func rd_arf( filename, &e_arf, &arf, num= )
/* DOCUMENT rd_arf, filename, >e_arf, >arf, num=

   Returns an energy  and arf array from extension "SPECRESP"
   in the FITS file: filename. The columns ENERG_LO, ENERG_HI,
   and SPECRESP must exist.

   For PHAII format 'num' may be given (defaults to 1 (one)).

   SEE ALSO: read_arf (rmf_funcs.i)

*/
{
   dol = filename+"[SPECRESP]";
   arf = rdfitscol(dol,"SPECRESP");
   elo = rdfitscol(dol,"ENERG_LO");
   ehi = rdfitscol(dol,"ENERG_HI");

   // Reformatting is required for PHAII ARF

   dms = dimsof( arf );
   if( dms(1) > 1 ) {
      if( is_void(num) ) num = 1;
      arf = arf(,num);
      elo = elo(,num);
      ehi = ehi(,num);
   }

   e_arf = 0.5*(elo + ehi);
}

/* Function predict_cr */

func predict_cr( file_with_arf, emin=, emax= )
/* DOCUMENT cr = predict_cr( file_with_arf, emin=, emax= )

   Returns the predicted count rate of a source with flux
   as produced by 'mk_photflux' and stored in the external
   variables: Eline and Flux.

   The energy min/max of 'Eline' defines the energy interval

   It reads the energy and arf array from extension "SPECRESP"
   in the FITS file: file_with_arf. The columns ENERG_LO, ENERG_HI,
   and SPECRESP must exist.

   SEE ALSO: rd_arf
*/
{
   if( is_void(emin) ) emin = Eline(1);
   if( is_void(emax) ) emax = Eline(0);

   local e_arf, arf;
   rd_arf, file_with_arf, e_arf, arf;

   // Check consistency
   if( emin < e_arf(1) ) {
      write,"Warning: Requested emin ("+ftoa(emin,ndec=2)+" keV) < Earf,min ("+ftoa(e_arf(1),ndec=2)+" keV)";
   }
   if( emin < Eline(1) ) {
      write,"Warning: Requested emin ("+ftoa(emin,ndec=2)+" keV) < Eline,min ("+ftoa(Eline(1),ndec=2)+" keV)";
   }
   if( emax > e_arf(0) ) {
      write,"Warning: Requested emax ("+ftoa(emax,ndec=2)+" keV) > Earf,max ("+ftoa(e_arf(0),ndec=2)+" keV)";
   }
   if( emax > Eline(0) ) {
      write,"Warning: Requested emax ("+ftoa(emax,ndec=2)+" keV) > Eline,max ("+ftoa(Eline(0),ndec=2)+" keV)";
   }

   is = where( emin <= Eline & emax >= Eline );

   if( !numberof(is) ) error,"No Eline elements in interval";

   qarf = interp(arf, e_arf, Eline(is));
   return sum(qarf(zcen)*(Flux(is))(zcen)*(Eline(is))(dif));

}

/* Function rd_photflux */

func rd_photflux( filename, chat= )
/* DOCUMENT rd_photflux, filename, chat=

    Defines external variables 'Eline' and 'Flux'
    from the contents of the photon flux file
    given in the first extension of 'filename'.

    Keyword 'chat' will trigger the display of the
    FITS header information.
*/
{
   extern Eline, Flux, Sx_photflux;

   dol = filename+"+1";
   elo = rdfitscol( dol, "ENERG_LO" );
   ehi = rdfitscol( dol, "ENERG_HI" );
   Flux = rdfitscol( dol, "PHOTFLUX" );
   Eline = sqrt(elo*ehi);
   Sx_photflux = sflux(elo(1),ehi(0),Eline,Flux);

   write,"Externals 'Eline', 'Flux', and 'Sx_photflux' have now been defined.";

   if( chat ) {
      hdr = headfits(dol);
      const = fxpar(hdr,"const");
      code = fxpar(hdr,"code");
      param1 = fxpar(hdr,"param1");
      nh = fxpar(hdr,"nh");
      e_min = fxpar(hdr,"e_min");
      e_max = fxpar(hdr,"e_max");
      sx = fxpar(hdr,"sx");
      nchans = fxpar(hdr,"naxis2");
      write,format="%s : const = %9.2e, par = %5.2f, NH = %9.2e\n", \
                code, const, param1, nh;
      write,format="  between %.2f and %.2f keV in %i channels\n", \
                e_min, e_max, nchans;
      write,format="  and Sx = %9.2e erg/cm2/s in that interval\n", sx;
   }
}

/* Function add_phaii_spectra */

/*************************************************

 Add two or more PHAII spectra with exposure as
 weighting factor

  add_p2spectra alias add_phaii_spectra
*************************************************/

func add_phaii_spectra( list, outfile, sourceid=, name=, rdr= )
/* DOCUMENT add_phaii_spectra, list_of_filenames, outfilename, \
        sourceid=, name=, rdr=

   Assumes extension #1

  Keywords (only one of these can be given):
     sourceid     SOURCE_ID  requires exact match
     name         NAME       requires matching lowercase, no spaces
     rdr          3-element array [RA, dec, radius] all in degrees

*/
{
   local ancrfile, ndum;

   sel = 0;
   if( !is_void(sourceid) ) sel += 1;
   if( !is_void(name) ) sel += 2;
   if( !is_void(rdr) ) sel += 4;
   if( sel != 1 && sel != 2 && sel != 4 ) error,"Bad keywords";

   kwds_init;
   if( sel == 1 ) {
      sourceid = strtrim(sourceid);
      if( strtolower(sourceid)  ==  "crab" ) sourceid = "J053432.0+220052";
      kwds_set,"COMMENT","Selecting SOURCE_ID == "+sourceid;
   }
   if( sel == 2 ) {
      name = strlowcase(strcompress(name,all=1));
      kwds_set,"COMMENT","Selecting source NAME == "+name;
   }
   if( sel == 4 ) kwds_set,"COMMENT","Selecting source at "+\
              swrite(format="RA=%7.3f dec=%7.3f rad=%5.3f",rdr(1),rdr(2),rdr(3));
   kwds_set,"COMMENT","Including these files:";
   n = numberof(list);

   rate_sum = [];
   rate_sum_err2 = [];
   expo_sum = 0.0;
   arf_sum = [];
   for( i = 1; i <= n; i++ ) {
      write,"Extracting spectrum from "+list(i)+" ...";
      if( !file_test(list(i)) ) {
         write,"Did not find "+list(i)+", skip and continue ...";
         continue;
      }
      dol = list(i)+"+1";
      hdr = headfits( dol );
      exposure = fxpar( hdr, "exposure" );
      if( is_void(exposure) ) exposure = 1.0;
      write,"           with EXPOSURE = ",exposure;

      rate = rdfitscol( dol, "rate" );
      rate_err = rdfitscol( dol, "stat_err" );
      ancrfiles = rdfitscol( dol, "ancrfile" );
      respfile = fxpar( hdr, "respfile" );
      if( sel == 1 ) {
         source_id = strtrim(rdfitscol( dol, "source_id" ));
         w = where( source_id == sourceid );
         if( numberof(w) == 0 ) {
            write,"Source "+sourceid+" not found in "+dol;
            continue;
         }
      } else if( sel == 2 ) {
         names = strlowcase(strcompress(rdfitscol( dol, "name" ),all=1));
         w = where( names == name );
         if( numberof(w) == 0 ) {
            write,"Source "+name+" not found in "+dol;
            continue;
         }
      } else {
         ra = rdfitscol( dol, "ra_obj" );
         dec = rdfitscol( dol, "dec_obj");
         r = arcdist( ra, dec, rdr(1), rdr(2) );
         rmin = min(r);
         if( rmin > rdr(3) ) {
            write,"No sources close to selection";
            continue;
         }
         w = where( r == rmin );
      }
      src_num = w(1);
      rate = rate(,src_num);
      rate_err = rate_err(,src_num);
      // remove the {1} on the ancrfile name
      get_exten_no, ancrfiles(src_num), ancrfile, ndum, tub=1;

      if( !file_test(ancrfile) ) {
         write,"Did not find "+ancrfile+", skip and continue ...";
         continue;
      }

      if( !file_test(respfile) ) {
         write,"Did not find response file: "+respfile;
         return;
      }

      kwds_set,"COMMENT",list(i);
      arf = rdfitscol( ancrfile+"[SPECRESP]","specresp");
      elo = rdfitscol( ancrfile+"[SPECRESP]","energ_lo");
      ehi = rdfitscol( ancrfile+"[SPECRESP]","energ_hi");
      arf = arf(,src_num);
      elo = elo(,src_num);
      ehi = ehi(,src_num);
      if( is_void(arf_sum) ) {
         arf_sum = arf*exposure;
      } else {
         arf_sum += arf*exposure;
      }
      expo_sum += exposure;
      if( is_void(rate_sum) ) {
         rate_sum = rate;
         rate_sum_err2 = rate_err^2;
      } else {
         rate_sum += rate;
         rate_sum_err2 += rate_err^2;
      }

      //+ e_min = rdfitscol( respfile+"[EBOUNDS]", "e_min" );
      //+ e_max = rdfitscol( respfile+"[EBOUNDS]", "e_max" );

   }

   arf = arf_sum / expo_sum;
   ancrfile = strpart(outfile,1:-5)+"_ancr.fits";
   wrmfitscols,ancrfile,"ARF_NUM", [1], "ENERG_LO", elo(,-), "ENERG_HI", ehi(,-), \
               "SPECRESP", arf(,-), extname="SPECRESP",clobber=1;

   spec2phaii, outfile, rate_sum, sqrt(rate_sum_err2), exposure=expo_sum, \
               ancrfile=ancrfile, respfile=respfile,telescop=telescop, \
               instrume=instrume, no_kwds_init=1;

}
add_p2spectra = add_phaii_spectra;

/* Function spec2phaii */

func spec2phaii( filename, rate, stat_err, type=, name=, rowid=, ra_obj=, dec_obj=, exposure=, \
                 ancrfile=, respfile=, backfile=, telescop=, instrume=, no_kwds_init= )
/* DOCUMENT spec2phaii, filename, rate, stat_err

     Writes spectrum or spectra in counts/s to PHA II format with clobber=1
     Dimension of rate and stat_err:    nbins x nrows

     Keywords:
        The following keywords must have as many elements as there are
        spectra (rows):
             ra_obj    [deg]
             dec_obj   [deg]
             exposure  [s]
             name      (string)  synonymous with 'rowid'
             rowid     (string)  synonymous with 'name'
             ancrfile  (string)  file containing pertinent ARF
             backfile  (string)  file with background spectrum with same number of spectra
                                 as in 'rate'

        These keywords are single valued (becomes part of FITS header)

             type      (string)  One of: "net" (default), "total", or "bkg"
             respfile  (string)  name of response (RMF) file
             telescop  (string)  Name of the mission or telescope
             instrume  (string)  Name of the instrument

        Keyword to cancel keyword initialization (kwds_init):  no_kwds_init

    2009-06-29/NJW
*/
{
   if( numberof(stat_err) != numberof(rate) ) error,"Argument size incompatibility";

   dms = dimsof(rate);
   if( anyof(dms-dimsof(stat_err)) ) error,"Argument dimension incompatibility";
   if( dms(1) == 2 ) {
      nrows = dms(3);
      nbins = dms(2);
   } else if( dms(1) == 1 ) {
      nrows = 1;
      nbins = dms(2);
      rate = reform(rate,nbins,nrows);
      stat_err = reform(stat_err,nbins,nrows);
   } else error,"Does not handle single value spectrum";

   if( is_void(type) ) {
      type = "net";
   } else { // check of legality
      if( typeof(type) != "string" ) error,"Keyword 'type' is not a string";
      type = strtrim(strlowcase(type));
      if( type != "net" && type != "total" && type != "bkg" ) error,"Illegal keyword 'type': "+type;
   }

   if( !is_void(ra_obj) ) {
      if( numberof(ra_obj) != nrows ) {
         write,"Wrong number of values in keyword ra_obj - forget";
         ra_obj = [];
      }
      ra_obj = reform(ra_obj,nrows);
   }

   if( !is_void(dec_obj) ) {
      if( numberof(dec_obj) != nrows ) {
         write,"Wrong number of values in keyword dec_obj - forget";
         dec_obj = [];
      }
      dec_obj = reform(dec_obj,nrows);
   }

   if( !is_void(exposure) ) {
      if( numberof(exposure) != nrows ) {
         write,"Wrong number of values in keyword exposure - expand first value";
         exposure = array(double(exposure(1)),nrows);
      }
      exposure = reform(exposure,nrows);
   } else {  // set default exposure of 1.0 s
      exposure = array( 1.0, nrows );
   }

   if( !is_void(rowid) ) name = rowid;
   if( !is_void(name) ) {
      if( numberof(name) != nrows ) {
         write,"Wrong number of values in keyword name (rowid) - forget";
         name = [];
      }
      name = reform(name,nrows);
   }

   if( !is_void(ancrfile) ) {
      if( numberof(ancrfile) != nrows ) {
         write,"Wrong number of values in keyword ancrfile - forget";
         ancrfile = [];
      }
      ancrfile = reform(ancrfile,nrows);
   }

   if( !is_void(respfile) ) {
      if( numberof(respfile) != 1 ) {
         write,"Wrong number of elements in keyword respfile - forget";
         respfile = [];
      }
      respfile = respfile(1);
   } else respfile = "unknown";

   ttype1 = "spec_num";
   data1 = short(indgen(nrows));
   ttype2 = "rowid";
   if( is_void(name) ) {
      data2 = array(strpadd(" ",32," "),nrows);
   } else {
      data2 = array(string,nrows);
      for(i=1;i<=nrows;i++) data2(i) = strpadd(name(i),32," ",truncate=1);
   }
   ttype3 = "ra_obj";
   data3 = is_void(ra_obj) ? array(float(-99.),nrows) : float(ra_obj);
   ttype4 = "dec_obj";
   data4 = is_void(dec_obj) ? array(float(-99.),nrows) : float(dec_obj);
   ttype5 = "channel";
   data5 = short(indgen(nbins))(,-:1:nrows);
   ttype6 = "rate";
   data6 = float(rate);
   ttype7 = "stat_err";
   data7 = float(stat_err);
   ttype8 = "sys_err";
   data8 = float(stat_err*0);
   ttype9 = "quality";
   data9 = array(short,nbins,nrows);
   ttype10 = "backfile";
   if( is_void(backfile) ) {
      data10 = array(strpadd(" ",160," "),nrows);
   } else {
      data10 = array(string,nrows);
      for(i=1;i<=nrows;i++) data10(i) = strpadd(backfile(i)+"{"+itoa(i)+"}",160," ",truncate=1);
   }
   ttype11 = "backscal";
   data11 = array(1.0,nrows);
   ttype12 = "ancrfile";
   if( is_void(ancrfile) ) {
      data12 = array(strpadd(" ",160," "),nrows);
   } else {
      data12 = array(string,nrows);
      for(i=1;i<=nrows;i++) data12(i) = strpadd(ancrfile(i)+"{"+itoa(i)+"}",160," ",truncate=1);
   }
   ttype13 = "exposure";
   data13 = exposure;
   ttype14 = "telapse";
   data14 = array(1.0,nrows);
   ttype15 = "ontime";
   data15 = array(1.0,nrows);
   ttype16 = "deadc";
   data16 = array(1.0,nrows);
   ttype17 = "tfirst";
   data17 = array(1.0,nrows);
   ttype18 = "tlast";
   data18 = array(1.0,nrows);
   ttype19 = "evt_type";
   data19 = array(short,nrows);

   if( !no_kwds_init ) kwds_init;

   kwds_set,"extname","SPECTRA","Extension name";
   if( !is_void(telescop) ) kwds_set,"telescop",telescop,"Mission name";
   if( !is_void(instrume) ) kwds_set,"instrume",instrume,"Instrument";
   kwds_set,"date",ndate(3),"CET Central European time";
   kwds_set,"detchans", nbins,"Total number of detector channels";
   kwds_set,"hduclass","OGIP","Format conforms mostly to OGIP standards";
   kwds_set,"hduclas1","SPECTRUM","Dataset contains a spectrum";
   if( type == "net" ) commt = "Background subtracted spectra";
   if( type == "total" ) commt = "Total spectra";
   if( type == "bkg" ) commt = "Background spectra";
   kwds_set,"hduclas2",strupcase(type),commt;
   kwds_set,"hduclas3","RATE","Data is stored in counts/s";
   kwds_set,"hduclas4","TYPE:II","Format is PHAII";
   kwds_set,"hduvers","1.2.0","Version of format";
   kwds_set,"grouping",0,"No channel grouping";
   kwds_set,"poisserr","False","Poisson error not appropriate (use STAT_ERR)";
   kwds_set,"corrscal",1.0,"Correction scaling factor";
   kwds_set,"areascal",1.0,"Nominal effective area";
   kwds_set,"respfile",respfile,"Pertaining RESPFILE";
   kwds_set,"tunit3","deg","Unit of column RA_OBJ";
   kwds_set,"tunit4","deg","Unit of column DEC_OBJ";
   kwds_set,"tlmin",1,"Minimum legal value of column CHANNEL";
   kwds_set,"tlmax",nbins,"Maximum legal value of column CHANNEL";
   kwds_set,"tunit6","counts/s","Unit of column RATE";
   kwds_set,"tunit7","counts/s","Unit of column STAT_ERR";
   kwds_set,"tunit8"," ","Unit of column SYS_ERR";
   kwds_set,"tunit13","s","Unit of column EXPOSURE";
   kwds_set,"tunit14","s","Unit of column TELAPSE";
   kwds_set,"tunit15","s","Unit of column ONTIME";
   kwds_set,"tunit17","s","Unit of column TFIRST";
   kwds_set,"tunit18","s","Unit of column TLAST";

   wrmfitscols,filename, ttype1, data1, ttype2, data2, ttype3, data3, \
                         ttype4, data4, ttype5, data5, ttype6, data6, \
                         ttype7, data7, ttype8, data8, ttype9, data9, \
                         ttype10, data10, ttype11, data11, ttype12, data12, \
                         ttype13, data13, ttype14, data14, ttype15, data15, \
                         ttype16, data16, ttype17, data17, ttype18, data18, \
                         ttype19, data19, clobber=1;

}

/* Function spec_info */

func spec_info( specfile )
/* DOCUMENT spec_info, specfile

*/
{
   if( !file_test(specfile) ) {
      write,"File not found";
      return;
   }
   fh = headfits( specfile+"+1");
   rate = rdfitscol(specfile+"+1","rate");
   dms = dimsof(rate);
   if( dms(1) == 2 ) {
      if( dms(3) == 1 ) {
         write,format="PHAII format with a single spectrum%s\n", "";
      } else {
         write,format="PHAII format with %i spectra", dms(3);
      }
      ancrfile = rdfitscol(specfile+"+1","ancrfile");
      write,format="First ANCRFILE: %s\n", strtrim(ancrfile(1));
   } else {
      write,"PHAI format";
      write,format="ANCRFILE: %s\n",fxpar(fh,"ancrfile");
   }
   write,format="%i energy bins\n", dms(2);
   write,format="RESPFILE = %s\n", fxpar(fh,"RESPFILE");

}

struct ea_S{
        pointer ener;
        pointer area;
}

/* Function read_effa */

func read_effa( filename )
/* DOCUMENT effa = read_effa( filename )

    Returns a struct with pointers to energy array and 
    effective area array provided
      1) the file is a binary FITS extension containing
         the columns "ENERGY" and "EFF_AREA".
    or
      2) the file is a text table conforming to .scm format
         with columns "energy" and "eff_area"

    e_arr = *effa.ener
    effa_arr = *effa.area
*/
{
   s = ea_S();
   if( fits_check_file(filename) ) {
      s.ener = &rdfitscol(filename+"+1","energy");
      //+ s.area = &(0.01*rdfitscol(filename+"+1","eff_area"));
      s.area = &rdfitscol(filename+"+1","eff_area");
   } else {
      s.ener = &rscol(filename, "energy", nomem=1,silent=1);
      s.area = &rscol(filename, "eff_area", nomem=1,silent=1);
   }
   return s;
}

/* Function plot_effa */

func plot_effa( filename, color=, itype=, li=, ps=, xr=, yr=, \
                thick=, title=, xtitle=, ytitle=, pane= )
/* DOCUMENT plot_effa, filename, color=, itype=, li=, ps=, xr=, yr=,
                thick=, title=, xtitle=, ytitle=, pane=

      'filename' is either a genuine filename or a struct (ea_S) as
      returned by 'read_effa'.
*/
{
   if( structof(filename) == string ) {
      effa = read_effa( filename );
   } else effa = filename;

   if( !is_void(pane) ) window,pane;

   if( is_void(xtitle) ) xtitle = "Energy [keV]";
   if( is_void(ytitle) ) ytitle = "Effective Area [cm^2^]";

   plot,*effa.ener, *effa.area, color=color, itype=itype, \
         li=li, ps=ps, thick=thick, xr=xr, yr=yr, title=title, \
         xtitle="Energy [keV]", ytitle="Eff. Area [cm^2^]";
}

/* Function oplot_effa */

func oplot_effa( filename, color=, li=, thick=, ps= )
/* DOCUMENT oplot_effa, filename, color=, li=, ps=, thick=

      'filename' is either a genuine filename or a struct (ea_S) as
      returned by 'read_effa'.
*/
{
   if( structof(filename) == string ) {
      effa = read_effa( filename );
   } else effa = filename;

   oplot,*effa.ener, *effa.area, color=color, \
         li=li, ps=ps, thick=thick;
}

/* Function plot_2effas */

func plot_2effas( filename1, filename2, color=, itype=, li=, ps=, xr=, yr=, \
                  thick=, title=, xtitle=, ytitle=, frsize=, ndcymin=, pane= )
/* DOCUMENT plot_2effas, filename1, filename2, color=, itype=, li=, ps=, xr=, yr=,
                thick=, title=, xtitle=, ytitle=, frsize=, ndcymin=, pane=

    Filenames may also be structs (ea_S) as returned by 'read_effa'.

    Keyword color may be an array with two elements.

    Keyword
     frsize    Relative frame size will be frsize:1 (default 3:1)
     ndcymin   Lower edge of plot frame in NDC (default 0.1)
*/
{
   if( structof(filename1) == string ) {
      effa1 = read_effa( filename1 );
   } else effa1 = filename1;

   if( structof(filename2) == string ) {
      effa2 = read_effa( filename2 );
   } else effa2 = filename2;

   if( !is_void(color) ) {
      if( numberof(color) == 1 ) color = [color,color];
   }
   if( is_void(xtitle) ) xtitle = "Energy [keV]";
   if( is_void(ytitle) ) ytitle = "Effective Area [cm^2^]";
   if( is_void(frsize) ) frsize = 3.;
   if( is_void(ndcymin) ) ndcymin = 0.1;

   mplot_setup, 21, spacing=0.001, hideticklabels=1, vrelsize=[frsize,1], \
              vport=[0.1,0.7,ndcymin,0.95], pane=pane;

   c = is_void(color) ? [] : color(1);
   plot,*effa1.ener, *effa1.area, color=c, itype=itype, \
         li=li, ps=ps, thick=thick, xr=xr, yr=yr, mpl=1;
   c = is_void(color) ? [] : color(2);
   oplot,*effa2.ener, *effa2.area, color=c, \
         li=li, ps=ps, thick=thick;

   // determine overlap in energy ranges
   e1 = *effa1.ener;
   e2 = *effa2.ener;
   a1 = *effa1.area;
   a2 = *effa2.area;
   emin = max(min(e1),min(e2));
   emax = min(max(e1),max(e2));
   if( emin < emax ) {
      w1 = where( e1 >= emin & e1 <= emax );
      //+ w2 = where( e2 >= emin & e2 <= emax );
      a2_adj = interp( a2, e2, e1(w1) );
      w = where(a2_adj > 0. );
      r = a1(w1(w))/a2_adj(w);
      rmax = r(max);
      rmin = 2. - rmax;
      rmn = r(min);
      if( rmn < rmin ) {
         rmin = rmn;
         rmax = 2. - rmin;
      }
      dr = (rmax - rmin)*0.07;
      plot, [e1(1),e1(0)], [1,1], li=2, xr=xr, yr=[rmin-dr,rmax+dr], mpl=2;
      oplot, e1(w1(w)), r;
   }

   dy = (0.95 - ndcymin)/(2*(frsize+1));
   ypos = dy * (frsize + 2) + ndcymin;
   devicetitles,title, [0.4,0.97],xtitle,[0.4,ndcymin-0.05],ytitle,[0.05,ypos];
   ypos = dy + ndcymin;
   devicetitles,,,,,"Ratio",[0.05,ypos];
}

%FILE% xtel_bend2mdeform.i
func xtel_bend2mdeform( bend, cube1a=, cube3a=, mlength= )
/* DOCUMENT xtel_bend2mdeform, bend, cube1a=, cube3a=, mlength=

    Make mirror deformation from circular bending of an X-ray telescope
    horizontally suspended in a gravitational field giving largest deviation
    in the middle.

    deform = -delta_r = -(bend/mlength^2) * (z + mlength) * (z - mlength)

    for mirror parts above the axis and with reversed sign below the axis.
    Sign reversal is taken care of by the sine function in azimuth.

        For 1-alpha   z c [ 0., mlength]
        For 3-alpha   z c [-mlength, 0.]

    The 'bend' parameter is the distance (same unit as 'mlength', often mm)
    between the cord and the circular arc where it is at a maximum,
    i.e. right between the 1alpha and 3alpha mirror sections.

    Use dimensions from already existing deformation cubes with keywords
    cube1a and cube3a (either a string with DOL or the actual data cube).

    The mirror length can be set with keyword 'mlength' (defaults to 225. mm)

    Output in 'bend1a.fits' and 'bend3a.fits'

    2012-01-27/NJW

*/
{
   local filename1a, filename3a, extno;

   filename1a = "From direct input";
   filename3a = "From direct input";

   if( is_void(mlength) ) mlength = 225.; // mm - mirror length

   if( numberof(cube1a) ) {
      if( structof(cube1a) == string ) {
         get_exten_no, cube1a, filename1a, extno;
         cube1a = readfits(cube1a);
      } else filename1a = "from direct input";
      dms = dimsof(cube1a);
      if( dms(1) != 3 ) error,"cube1a is not a data cube";
      nlayers1 = dms(4);
      nz1 = dms(3);
      naz1 = dms(2);
   } else {
      filename1a = "no update, pure bending";
      nlayers1 = 133;
      nz1 = 100;
      naz1 = 100;
   }
   if( numberof(cube3a) ) {
      if( structof(cube3a) == string ) {
         get_exten_no, cube3a, filename3a, extno;
         cube3a = readfits(cube3a);
      } else filename3a = "from direct input";
      if( structof(cube3a) == string ) cube3a = readfits(cube3a);
      dms = dimsof(cube3a);
      if( dms(1) != 3 ) error,"cube3a is not a data cube";
      nlayers3 = dms(4);
      nz3 = dms(3);
      naz3 = dms(2);
   } else {
      filename3a = "no update, pure bending";
      nlayers3 = 133;
      nz3 = 100;
      naz3 = 100;
   }

   // Ensure that the largest deviation is found for low indices
   // for the 1-alpha section

   z = span(0.,mlength,nz1);
   yz = -bend * (z + mlength) * (z - mlength) / mlength^2;

   a = span(0.,2*pi,naz1);
   ya = sin(a);

   mdef_arr = ((ya(,-:1:nz1)) * (yz(-:1:naz1,)))(,,-:1:nlayers1);

   if( !is_void(cube1a) ) mdef_arr += cube1a;

   kwds_init;
   kwds_set,"DATE",ndate(3),"Date and time of production";
   kwds_set,"UPDATE", filename1a, "Updated with this file";
   kwds_set,"BEND", bend, "[mm] Bending parameter";
   kwds_set,"MLENGTH", mlength, "[mm] Mirror length";
   kwds_set,"RESPONSI", "Niels J. Westergaard", "Responsible";
   kwds_set,"AFFILIAT", "DTU Space", "Affiliation";
   kwds_set,"ORIGIN", "xtel_bend2mdeform", "Software";
   kwds_set,"OPTMODUL", "Upper or 1-alpha", "Optical module";
   kwds_set,"COMMENT","A mirror deformation cube matching MT_RAYOR requirements";

   writefits,"bend1a.fits", float(mdef_arr), clobber=1;

   // Ensure that the largest deviation is found for high indices
   // for the 3-alpha section

   z = span(-mlength,0.,nz3);
   yz = -bend * (z + mlength) * (z - mlength) / mlength^2;

   a = span(0.,2*pi,naz3);
   ya = sin(a);

   mdef_arr = ((ya(,-:1:nz3)) * (yz(-:1:naz3,)))(,,-:1:nlayers3);

   if( !is_void(cube3a) ) mdef_arr += cube3a;

   kwds_set,"UPDATE", filename3a, "Updated with this file";
   kwds_set,"OPTMODUL", "Lower or 3-alpha", "Optical module";
   writefits,"bend3a.fits", float(mdef_arr), clobber=1;

}

xtb = xtel_bend2mdeform;
write,"Has defined xtb =  xtel_bend2mdeform ...";