Write Matrix to File (Mellows)

/*   wriasc is a keyword written by Meinert Mellows
**   for public non-commercial use. Some improvements to
**   an earlier version derive from Alan G. Isaacs
**   wrilatex keyword.
**   There are no performance guarantees for this code.
**   Last update: 05/16/1995
**
**   Meinert Mellows
**   Mail:         Institut fuer Statistik und Oekonometrie,
**                   Universitaet Hamburg,
**                   Von-Melle-Park 5, 20146 Hamburg
**                   Germany
**   Internet:     mellows@econ.uni-hamburg.de
**
**
**    Documentation
**    -------------
**
**
**    Keyword: wriasc
**
**    Purpose: Writes a GAUSS Matrix to an ASCII File.
**
**     Format: wriasc x example.asc [append ow chas[(mask)] fm(fmt) see]
**
**      Input: x, (nxm)-matrix, the matrix to be written to an ASCII File.
**             example.asc, name of the ASCII File to which x will be
**             written.
**
**  Optional parameters:

**     append, append to existing file without prompting.
**         ow, overwrite existing file without prompting.
**       chas, print character matrix as string.
** chas(mask), mask is name of (1xm)-matrix of ones and
**             zeros, which determine wether the
**             corresponding column of x will be printed
**             as numeric or character.
**             (see 'printfmt' in GAUSS manual for details).
**    fm(fmt), fmt is name of (mx3)- or (1x3)-matrix,
**             which specifies the format for the
**             respective column of x.
**             (see 'printfm' in GAUSS manual)
**        see, show example.asc after print, using
**             file viewer specified in the global
**             variable: _viewprg.
**             Default: _viewprg = "edit.com";
**
**
**     Remarks:
**
**       - optional parameters need not be used in a particular order.
**
**       - note, that 'mask' and 'fmt' as used above have to be names
**         of matrices: chas(1~1~0~1) is NOT a legal option for wriasc.
**
**       - the options 'chas()' and 'fm()' work as shells for the GAUSS
**         function printfm (or printfmt). If 'printfm' terminates with
**         an error message such as 'illegal format string', you will
**         have to switch 'screen on' and 'output off' from the command
**         line. A second call to wriasc will not fix things in this
**         case, since wriasc tries to leave the state of your system
**         unchanged.
**
**
*/

declare string _viewprg ?= "edit.com";

keyword wriasc(str);
  local x,mat,f,rest,answer,opt,errmsg,oldwidth,oldstate,oldout,oldscr,typ;
  local append,ow,temp,maskstr,mask,fmtstr,fmt,done,c,see,retc;

  {mat,rest} = token(str);
  typ = typecv(mat);
  if typ /= 6 and typ /= 13 and typ /= 15;
   goto errout("There is no GAUSS matrix, string or string array called
 "$+mat$+".");
  endif;
  {f,opt} = token(rest);
  opt = upper(opt);

  clear append, ow, fmt, see;
  mask = 1;
  maskstr = ""; fmtstr = "";

  do while strlen(opt);
    {temp,opt} = token(opt);
    if strindx(temp,"APPEND",1);
      append = 1; continue;
    elseif strindx(temp,"OW",1);
      ow = 1; continue;
    elseif strindx(temp,"CHAS",1);
      if typ /= 6;
        goto errout("The option 'CHAS' makes no sense with string arrays or
 strings.");
      endif;
      mask = 0;
      if strindx(temp,"CHAS(",1);
        maskstr = strsect(temp,6,strlen(temp)-6);
        if typecv(maskstr) /= 6;
          goto errout("There is no GAUSS matrix called "$+maskstr$+".");
        endif;
        mask = varget(maskstr);
      endif; continue;
    elseif strindx(temp,"FM(",1);
      if typ /= 6;
        goto errout("The option fm() is not available with string arrays or
 strings.");
      endif;
      fmtstr = strsect(temp,4,strlen(temp)-4);
      if typecv(fmtstr) /= 6;
        goto errout("There is no GAUSS matrix called "$+fmtstr$+".");
      endif;
      fmt = varget(fmtstr); continue;
    elseif strindx(temp,"SEE",1);
      see = 1; continue;
    else;
      goto errout("Invalid option: '"$+temp$+"'.");
    endif;
  endo;

  if ow and append;
    goto errout("You can't append to AND overwrite the existing file!");
  endif;

  x = varget(mat);
  c = cols(x);
  if fmtstr $/= "";
   if ( rows(fmt) /= c and rows(fmt) /= 1 ) or cols(fmt) /= 3;
    goto errout("The matrix used as argument in fm() has the wrong shape.");
   endif;
  elseif maskstr $/= "";
   if rows(mask) /= 1  or ( cols(mask) /= 1 and cols(mask) /= c );
    goto errout("The matrix used as argument in chas() has the wrong shape.");
   endif;
  endif;

  if not (append or ow);
    answer="O";
    if cols(files(f,0))==2;
      answer="?";
      do until answer$=="O" or answer$=="A" or answer$=="Q";
        printdos "File '"$+f$+"' already exists:\l\r(o)verwrite, (a)ppend,
 (q)uit without writing? ";
        answer=upper(cons);
        "";
      endo;
    endif;
    if      answer $== "O";     ow = 1;
    elseif  answer $== "A"; append = 1;
    else;   goto errout("User abort; do not overwrite existing file.");
    endif;
  endif;

  {oldstate,oldout} = sysstate(18,1);

  if append;
    output file = ^f on;
  elseif ow;
    output file = ^f reset;
  endif;

  oldwidth = sysstate(11,256);
  oldscr = sysstate(15,0);

  if maskstr $/= "" or fmtstr $/= "";
    if fmtstr $/= "";
      done = printfm(x,mask,fmt);
    else;
      done = printfmt(x,mask);
    endif;
    if not done;
      gosub oldsys;
      goto errout("Print fails; may be out of disk space.");
    endif;
  else;
    if mask == 0; print ""$+x;
    else;         print x;
    endif;
  endif;

  gosub oldsys;

  if see; retc = exec(_viewprg,f);
   if retc == -1;
     goto errout("File '"$+_viewprg$+"' not found.");
   elseif retc == -2;
     goto errout("'"$+_viewprg$+"' is not an executable file.");
   elseif retc == -3;
     goto errout("unable to execute '"$+_viewprg$+"', not enough memory.");
   elseif retc == -4;
     goto errout("unable to execute '"$+_viewprg$+"', command line too long.");
   endif;
  endif;

  retp;

  oldsys:
    outwidth oldwidth;
    output file = ^oldout;
    if oldstate; output on; else; output off; endif;
    if oldscr; screen on; endif;
  return;

  errout:
    pop errmsg;
    print "\g";
    errorlog "Error: "$+errmsg;
endp;