$ Y2KLOAD.001
$---------------------------------------------------------------
$! RUN file to prepare to test performance of AIPS tasks on data
$# Run POPS
$-----------------------------------------------------------------------
$;  Copyright (C) 2000, 2003-2004, 2008, 2010-2012, 2019
$;  Associated Universities, Inc. Washington DC, USA.
$;
$;  This program is free software; you can redistribute it/or
$;  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.
$;
$;  You should have received a copy of the GNU General Public
$;  License along with this program; if not, write to the Free
$;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
$;  MA 02139, USA.
$;
$;  Correspondence concerning AIPS should be addressed as
$;  follows:
$;         Internet email: aipsmail@nrao.edu.
$;         Postal address: AIPS Project Office
$;                         National Radio Astronomy Observatory
$;                         520 Edgemont Road
$;                         Charlottesville, VA 22903-2475 USA
$-----------------------------------------------------------------------
*
* Y2KLOAD.001 by Eric Greisen, based on earlier DDT test:
* DDTLOAD.001 by Don Wells & Bill Cotton, NRAO-CV, Dec84-Feb85
*    Modified by Eric Greisen Nov85 to offer 3 sizes of problem
* It compiles the POPS code and leaves it in SAVE/GET files.
* The file Y2KEXEC.001 executes the files.
* See Y2K.HLP for documentation (HELP Y2K, EXPLAIN Y2K).
*
*    Version for the 31DEC10 release of AIPS
* ==============================================================
* Remember prior state to permit restoration at end:
* Declare variables needed by Y2K
PROCEDURE DCLY2K
   SCALAR IOTAPE, TMASK, TDISK, MDISK, DDISK, TERSE
   FINISH
* Make default output short
TERSE=1; TDISK=1; MDISK=1; DDISK=1; EDGSKP=4
IOTAPE=1; TMASK=63; DOTV=-1
STORE 1
RESTORE 0
CORE
* ==============================================================
* Declare variables for the procedures:
PROCEDURE DCLRVR
   STRING*50 BMBTXT, SPACER, MSGTXT
   STRING*16 Y2KFILE
   STRING*12 PRCSV1, ZAPSV2, NCLSV2, PHDSV1, PHDSV3, CHKSV2
   STRING*8  TNAME, TNAMF, Y2KSIZE, Y2KDISK
   STRING*6  ZAPSV1, ZAPSV3, ZIGSV1, NCLSV1, NCLSV3, CHKSV1
   STRING*6  ZIGSV2, ZIGSV3, PHDSV2, PHDSV4, TPLCLS
   STRING*6  UVCLAS, CRCLAS, CRCLS2, BEAMCL
   STRING*5  ZIGTSK, TPLTSK
   STRING*4  TCODE
   STRING*1  TMODE, SMODE, TMODES
   SCALAR    TMASK, ERATIO, IGWSV1, IOTAPE, TERSE
   SCALAR    UCHSV1, PRCSV2, PHDSV5, PHDSV6, ZAPSV4, TSTSCALE
   SCALAR    CHKSV3, TINY99, NCLSV4, DDISK, MDISK, TDISK
   SCALAR    XTRSV1, XTRSV2, JJCNT, NITSAVE, FLUSAVE, ROTSAVE
   SCALAR    IMSAVE, CELSAVE, IN3OLD, IN4OLD, UCLEV, TCODES
   ARRAY     MAXDIF(3), MPDIFS(5,20)
   RETURN
FINISH
SPACER='##################################################'
MSGTXT=SPACER; SUBSTR(MSGTXT,17,34)='----- ------------'
* ==============================================================
* Procedure to print fatal error message:
PROCEDURE Y2KBOMB(BMBTXT)
   TYPE 'FATAL ERROR:', BMBTXT
   I = 1; I = I / 0; RETURN
FINISH
* ==============================================================
* Procedure to list current catalog:
PROCEDURE PRTCAT
   PRCSV1 = INNAME; INNAME = '*' !! TNAMF; INCLASS = ''
   INSEQ = 0; CATALOG
   IF INDISK <> OUTDISK THEN PRCSV2 = INDISK; INDISK = OUTDISK
       INSEQ = 0; CATALOG; INDISK = PRCSV2; END
   INNAME = PRCSV1; RETURN
FINISH
* ==============================================================
* Procedure to print header of a file:
*               (inname, inclass)
PROCEDURE PRTHED (PHDSV1, PHDSV2, PHDSV6); PHDSV3 = INNAME
   INNAME = PHDSV1; PHDSV4 = INCLASS; INCLASS = PHDSV2
   PHDSV5 = INDISK; INDISK = PHDSV6; IMHEADER
   INNAME = PHDSV3; INCLASS = PHDSV4; INDISK = PHDSV5; RETURN
FINISH
* ==============================================================
* Procedure to execute a task:
PROCEDURE IGW (INCLASS, TASK)
   IF (TERSE<=0) THEN INPUTS; END
   IGWSV1 = DOWAIT; DOWAIT = TRUE
   GO; DOWAIT = IGWSV1; RETURN
FINISH
* ==============================================================
* Procedure to "ZAP" output files of specified class:
*                (class), assumes OUTNAME
PROCEDURE OUTZAP (ZAPSV1); ZAPSV2 = INNAME; INNAME = OUTNAME
   ZAPSV3 = INCLASS; INCLASS = ZAPSV1; ZAPSV4 = INDISK
   INDISK = 0; DOCONF=-2; ALLDEST; INDISK = ZAPSV4
   INNAME = ZAPSV2; INCLASS = ZAPSV3; RETURN
FINISH
* ==============================================================
* Procedure to "ZAP" prior output files, then execute:
*              (inclass, task, outclass)
PROCEDURE ZIGW (ZIGSV1, ZIGTSK, ZIGSV2)
   OUTZAP(ZIGSV2); ZIGSV3 = OUTCLASS; OUTCLASS = ZIGSV2
   IGW(ZIGSV1, ZIGTSK); OUTCLASS = ZIGSV3; RETURN
FINISH
* ==============================================================
* Procedure to list header of tape file and read it:
PROCEDURE TPLOD(TPLTSK)
   DOCONCAT = -1; IF (TERSE <= 0) THEN TPHEAD; END;
   IGW('', TPLTSK); RETURN
FINISH
* ==============================================================
* Procedure to compare test image against master:
*               (inclass), assumes OUTNAME
PROCEDURE CHECK (JJCNT, CHKSV1); CHKSV2 = INNAME
   IN2DISK = MDISK; APARM = 1,-1; INNAME = OUTNAME
   IN2NAME = 'M' !! TNAMF; IN2CLASS = CHKSV1
   IF (TERSE <= 3) THEN PRTHED(IN2NAME, IN2CLASS, IN2DISK); END
   CHKSV3=INDISK; INDISK=OUTDISK; OPCODE='SUM'; PIXSTD=0
   IN3OLD=IN3SEQ; IN4OLD=IN4SEQ; IN3SEQ=0; IN4SEQ=0
   ZIGW (CHKSV1, 'COMB', 'DIFF'); IN3SEQ=IN3OLD; IN4SEQ=IN4OLD
   SUBSTR(MSGTXT,23,28)=CHKSV1; TYPE SPACER,MSGTXT,SPACER
   INCLASS='DIFF'; KEYW='DATAMAX'; GETHEAD; TINY99=KEYVAL(1)
   KEYW='DATAMIN'; GETHEAD; TINY99=TINY99-KEYV(1); ERATIO=0.
   IF (TINY99 > 1.E-10) THEN
      BLC=EDGSKP+1,EDGSKP+1,0; KEYWORD='NAXIS1'; GETHEAD;
      TINY99=KEYV(1); KEYWORD='NAXIS2'; GETHEAD;
      TRC = TINY99-EDGSKP,KEYVAL(1)-EDGSKP,0; IMSTAT
      ERATIO = MAX(ABS(PIXVAL),ABS(PIX2VAL)); END
   INCLASS=IN2CLASS; INDISK=IN2DISK; INNAME=IN2NAME
   KEYWORD='DATAMAX'; GETHEAD; ERATIO=ERATIO/KEYVALUE(1)
   TYPE 'Relative to abs(maximum):', ERATIO
   TINY99 = 1.5768E-20 * 1E-10
   IF ERATIO<TINY99 THEN ERATIO = TINY99 END
   MPDIFS(1,JJCNT) = -3.3219 * LOG (ERATIO)
   TYPE 'Number correct bits max: ', MPDIFS(1,JJCNT)
   ERATIO = PIXSTD / KEYVALUE(1)
   IF ERATIO<TINY99 THEN ERATIO = TINY99 END
   MPDIFS(2,JJCNT) = -3.3219 * LOG (ERATIO)
   TYPE 'Number correct bits rms: ', MPDIFS(2,JJCNT)
   BMBTXT = INNAME
   SUBSTR(BMBTXT,19,24)='IMSTAT'; TYPE SPACER,BMBTXT; IMSTAT
   SUBSTR(BMBTXT,19,24)='MAXFIT'; TYPE SPACER,BMBTXT; MAXFIT
   MAXDIF = PIXXY(1), PIXXY(2), PIXVAL
   INNAME = OUTNAME; INDISK = OUTDISK; BMBTXT = INNAME
   SUBSTR(BMBTXT,19,24)='MAXFIT'; TYPE SPACER,BMBTXT; MAXFIT
   BLC = 0; TRC = 0
   MAXDIF=MAXDIF(1)-PIXXY(1),MAXDIF(2)-PIXXY(2),MAXDIF(3)-PIXVAL
   TYPE SPACER, '**** DIFFERENCE IN X, Y, VAL: ****', MAXDIF
   MPDIFS(3,JJCNT)=MAXDIF(1); MPDIFS(4,JJCNT)=MAXDIF(2)
   MPDIFS(5,JJCNT)=MAXDIF(3)
   TYPE SPACER, SPACER; INNAME = CHKSV2; INDISK = CHKSV3; RETURN
FINISH
* ==============================================================
* Procedure to compare test uv file against master:
*               (inclass), assumes OUTNAME
PROCEDURE UCHECK (UCLEV,CHKSV1); CHKSV2 = INNAME;
   APARM=UCLEV,1000,.1; INNAME = OUTNAME; CHKSV3 = INDISK;
   INDISK = OUTDISK; IN2NAME = 'M' !! TNAMF; IN2DISK = MDISK;
   IN2CLASS = CHKSV1
   IF (TERSE <= 3) THEN PRTHED(IN2NAME, IN2CLASS, IN2DISK); END
   SUBSTR(MSGTXT,23,28)=CHKSV1; TYPE SPACER,MSGTXT,SPACER
   UCHSV1 = NITER; NITER = 45; DOCRT = -1
   OPCODE = ''; IGW (CHKSV1, 'UVDIF'); INNAME = CHKSV2
   NITER = UCHSV1; INDISK = CHKSV3; TYPE SPACER; RETURN
FINISH
* ==============================================================
* Procedure to rename a file:
*                  (inclass, outclass), assumes OUTNAME
PROCEDURE NEWCLASS (NCLSV1, OUTCLASS); NCLSV2 = INNAME
   INNAME = OUTNAME; NCLSV3 = INCLASS; INCLASS = NCLSV1
   NCLSV4 = INDISK; INDISK = OUTDISK; RENAME
   INNAME = NCLSV2; INCLASS = NCLSV3; INDISK = NCLSV4; RETURN
FINISH
* ==============================================================
* procedure to build name
PROCEDURE FILENAME; I = LENGTH(Y2KDISK); Y2KFILE=Y2KDISK
   IF (I) THEN; SUBSTR(Y2KFILE,I+1,16)= ':'!!TNAME!!SMODE
   END; RETURN
FINISH
* ==============================================================
* Dummy procedure in case ALLDEST not executed:
PROCEDURE YES; RETURN
FINISH
* ==============================================================
* Set default variable values:
TNAME = 'Y2K'; TASK = TNAME; TMASK = 63; TMODE = 'T'
Y2KSIZE = 'SMALL' ; TNAMF = TNAME !! SUBSTR (Y2KSIZE,1,1)
INNAME = TMODE !! TNAMF; INCLASS  = ''; INSEQ  = 0
OUTNAME = 'T' !! TNAMF; OUTCLASS = ''; OUTSEQ = 0
CLR2NAME; CLR3NAME; DOTWO = FALSE; FORMAT = 3; BLOCKING = 10
PRIORITY=5; DOCAL=-1; DOTV=-1; NCOUNT=1; OPTYP=''
* Save current POPS image to allow restore after each step:
CORE
SAVE Y2K000
* ==============================================================
* Check variables:
GET Y2K000
PROCEDURE Y2KPROC; TASK=TNAME; TGET; SMODE = SUBSTR(Y2KSIZE,1,1)
   I = (SMODE='S')!(SMODE='M')!(SMODE='L')!(SMODE='H')
   IF (I) THEN TNAMF = TNAME !! SMODE
   ELSE Y2KBOMB('Y2KSIZE MUST BE SMALL, MEDIUM, LARGE, OR HUGE')
      END
   IN2DISK = MDISK; INDISK = MDISK; OUTDISK = MDISK
   IF (TCODE='INIT') THEN INNAME='M'!!TNAMF; OUTNAME=INNAME
   ELSE IF ((TCODE = 'TEST')!(TCODE='WRIT')) THEN
      INNAME = TMODE !! TNAMF; OUTNAME = 'T' !! TNAMF
      OUTDISK = TDISK
      IF TMODE='T' THEN INDISK=TDISK; END
   ELSE IF (TCODE = 'READ') THEN OUTNAME = 'M' !! TNAMF; END
      END END
   I=(TCODE='INIT')!(TCODE='TEST')!(TCODE='WRIT')!(TCODE='READ')
   IF (I) THEN
      ELSE Y2KBOMB('TCODE MUST BE INIT,TEST,WRIT, OR READ!')
      END
   IF ((TMASK<1)!(TMASK>63)) THEN
      Y2KBOMB('MUST HAVE 0<TMASK<64 !'); END
   IF ((TCODE='TEST')!(TCODE='WRIT')) THEN
      IF (TMODE='') THEN TMODE='M'; END
      IF ((TMODE='T')!(TMODE='M')) THEN ;
        ELSE Y2KBOMB('TMODE MUST BE T OR M IF TCODE=TEST/WRIT!')
         END END
   I = (IOTAPE<1)!(DDISK<1)!(MDISK<1)!(TDISK<1)
   IF (I) THEN
      Y2KBOMB('NEED IOTAPE, DDISK, MDISK & TDISK >0 !')
      END
   UVTAP = 0; INTAPE = IOTAPE; OUTTAPE = IOTAPE
   IF EDGSKP < 0 THEN EDGSKP=4; END; SCALR2=10
* set mapping parameters for problems
   TYPE '# SET MAPPING PARAMETERS #'; ; MINPATCH = 51;
   IF SMODE = 'S' THEN   ROTAT=-5; SHIFT=6,-6; CELLSIZE=1.15
      IMSIZE=512; NITER=5000; FLUX=5.5; MAXPIXEL=10000
      NBOXES=1;CLBOX=138,178,353,352; SCALR1 =18.4; SCALR3=0
      NOISE=0.0015,0; SCALR2=25; NPIECE=1; ROBUST=0; DOUVCOMP=0
      END
   IF SMODE = 'M' THEN   ROTAT=30; SHIFT=-0.049,+0.026
      CELLSIZE=0.1; IMSIZE=1024; NITER=15000; MAXPIXEL=20050
      NBOXES=1; CLBOX=340,390,630,630; SCALR1 = 13.1;FLUX=0.79
      ZEROSP=FLUX,0,0,0,15.0; NOISE=0.00005,0; NPIECE=1;
      SCALR2=20; ROBUST = -1; SCALR3=FLUX; DOUVCOMP=0
      END
   IF SMODE = 'L' THEN   ROTAT=23; SHIFT=0,0; NPIECE=4
      CELLSIZE=0.2; IMSIZE=2048; NITER=25000; MAXPIXEL=38000
      NBOXES=2; CLBOX= 711,730,1061,1053, 1017,1016,1367,1333
      SCALR1 = 34.6; FLUX=180; ZEROSP=FLUX,0,0,0,15.0;
      NOISE=0.0024,0; SCALR2=25; ROBUST=-1; SCALR3=FLUX;
      DOUVCOMP=1;
      END
   IF SMODE = 'H' THEN   ROTAT=23; SHIFT=0,0; NPIECE=10
      CELLSIZE=0.05; IMSIZE=4096; NITER=35000; MAXPIXEL=80000
      FLUX=180; ZEROSP=FLUX,0,0,0,15.0; ROBUST=-1;
      NBOXES=3; CLBOX= 996,1041,1928,1955
      CLBOX(1,2)~2230,2203,3282,3202, 1840,1850,2331,2298
      SCALR1 = 23.5/1.7; NOISE=0.00027,0; SCALR2=70;
      SCALR3=FLUX; DOUVCOMP=1;
      END
   QUANTIZE=0.0
   MPDIFS = -100; NCOMP = 0; FILENAME
   TYPE 'TERSE=',TERSE; TYPE 'EDGSKP=',EDGSKP
   TYPE 'TMASK=',TMASK; TYPE 'BADDISK=',BADDISK;
   TASK = TNAME !! 'SAVE'; INPUTS; TPUT; RETURN
FINISH
CORE
SAVE Y2KINIT
* ==============================================================
* Read/Write the input visibility dataset:
GET Y2K000
PROCEDURE Y2KPROC; TASK = TNAME !! 'SAVE'; TGET
   SMODE = SUBSTR (TNAMF, 4, 4) ; NFILES=0; CRCLAS = 'UVDATA'
   IF SMODE='M' THEN NFILES=10; END
   IF SMODE='L' THEN NFILES=20; END
   IF SMODE='H' THEN NFILES=39; END
   I = LENGTH (Y2KFILE)
   IF (TCODE = 'WRIT') THEN
      XTRSV1=INDISK; INDISK=DDISK;
      PRTCAT; INNAME = 'D' !! TNAMF; DOEOT=FALSE; DONEWTAB=TRUE
      IF (I) THEN; DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
      ELSE; DATAOUT = ''; REWIND; AVFILE; NFILES = 0; END
      IGW(CRCLAS, 'FITAB'); INDISK=XTRSV1
   ELSE IF (TCODE = 'READ') THEN
      INCLASS = CRCLAS;  SOURCE = ''; DOCONF=-2
      INNAME = 'D' !! TNAMF; INDISK=0; ALLDEST; INDISK=DDISK
      OUTNAME = 'D' !! TNAMF; FREESPAC; OUTDISK = DDISK
      IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
      ELSE; DATAIN = ''; REWIND; AVFILE; END;
      NFILES=0; TPLOD('FITLD'); PRTCAT
      END; END
   RETURN
FINISH
CORE
SAVE Y2K000RW
* ==============================================================
* Sort the visibility data:
GET Y2K000
PROCEDURE Y2KPROC; TASK = TNAME !! 'SAVE'; TGET
   CRCLAS='UVSRT'; J = 1; I = LENGTH (Y2KFILE)
   TCODES = (TCODE='INIT') ! (TCODE='TEST')
   IF ((TCODES) & (MOD(TMASK,2*J)>=J)) THEN
      INNAME = 'D' !! TNAMF; XTRSV1 = INDISK; INDISK = DDISK
      IF (TERSE<=3) THEN PRTHED(INNAME, 'UVDATA',INDISK); END
      ROTSAVE=ROTATE; ROTATE = 0
      SORT = 'XY'; ZIGW ('UVDATA','UVSRT',CRCLAS)
      IF (TERSE<=3) THEN PRTHED (OUTNAME,CRCLAS,OUTDISK); END
      IF TCODE='TEST' THEN UCHECK(0.05, CRCLAS); END
      IF (TERSE<=2) THEN PRTCAT; END; ROTATE=ROTSAVE
   ELSE IF (TCODE = 'WRIT') THEN
      IF (I) THEN; IF (MOD(TMASK,2*J)>=J) THEN
         DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS
         IGW(CRCLAS, 'FITAB'); END
      ELSE; DATAOUT = ''; IGW(CRCLAS, 'FITAB') END;
   ELSE IF (TCODE = 'READ') THEN
      IF (MOD(TMASK,2*J)>=J) THEN; INCLAS=CRCLAS; DOCONF=-2
         INNAME = 'M' !! TNAMF; INDISK=0;ALLDEST;INDISK=MDISK
         IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
         ELSE; DATAIN = ''; END;  TPLOD('FITLD'); PRTCAT
      ELSE IF (^I) THEN;NFILE=1; AVFIL; NFILE=0; END; END
      END END END
FINISH
CORE
SAVE Y2K001
* ==============================================================
* Compute the dirty map:
GET Y2K000
PROCEDURE Y2KPROC; STRING*6 BEAMCL; TASK = TNAME !! 'SAVE'; TGET
   J = 2; BEAMCL = 'IBM001'; CRCLAS='IMAGE'; CRCLS2='IMBEAM'
   I = LENGTH (Y2KFILE);  SMODE = SUBSTR (TNAMF, 4, 4) ;
   TCODES = (TCODE='INIT') ! (TCODE='TEST')
   IF ((TCODES) & (MOD(TMASK,2*J)>=J)) THEN
      OUTZAP('IIM001'); OUTZAP(BEAMCL); OUTZAP(CRCLS2)
      IMSAVE=IMSIZE(1); CELSAVE=CELLS(1);
      NITSAVE=NITER; NITER=0;
      RASHIFT=SHIFT(1),0; DECSHIFT=SHIFT(2),0
      FLUSAV = FLUX; FLUX=0;
      IF (SMODE = 'H') THEN; UVBOX=0; UVTAPER=0; END
      ZIGW('UVSRT', 'IMAGR', CRCLAS)
      NITER=NITSAVE; FLUX=FLUSAV
      IMSIZE = IMSAVE,IMSAVE; CELLSI = CELSAV,CELSAV
      NEWCLASS('IIM001',CRCLAS); NEWCLASS(BEAMCL,CRCLS2)
      IF (TERSE <= 3) THEN PRTHED(OUTNAME, CRCLAS, OUTDISK)
         PRTHED(OUTNAME, CRCLS2, OUTDISK); END
      IF (TCODE='TEST') THEN CHECK(1,CRCLAS)
         CHECK(2,CRCLS2); END
      IF (TERSE <= 2) THEN PRTCAT; END
   ELSE IF (TCODE = 'WRIT') THEN
      IF (I) THEN; IF (MOD(TMASK,2*J)>=J) THEN
         DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
         IGW(CRCLAS, 'FITAB')
         DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
         IGW(CRCLS2, 'FITAB'); END
      ELSE; DATAOUT = ''; IGW(CRCLAS, 'FITAB')
         IGW(CRCLS2, 'FITAB'); END
   ELSE IF (TCODE = 'READ') THEN
      IF (MOD(TMASK,2*J)>=J) THEN INCLAS=CRCLAS; DOCONF=-2
         INNAME = 'M' !! TNAMF; INDISK = 0; ALLDEST
         INCLAS=CRCLS2; ALLDEST; INDISK=MDISK
         IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
         ELSE; DATAIN = ''; END;  TPLOD('FITLD')
         IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
         ELSE; DATAIN = ''; END;  TPLOD('FITLD'); PRTCAT
      ELSE IF (^I) THEN; NFILE=2; AVFIL; NFILE=0; END; END
      END END END;
   TASK = TNAME !! 'SAVE'; TPUT; RETURN
FINISH
CORE
SAVE Y2K002
* ==============================================================
* Clean the dirty map:
GET Y2K000
PROCEDURE Y2KPROC; TASK = TNAME !! 'SAVE'; TGET
   J = 4; I=LENGTH(Y2KFILE); SMODE = SUBSTR (TNAMF, 4, 4) ;
   TCODES = (TCODE='INIT') ! (TCODE='TEST')
   IF SMODE='H' THEN
      CRCLAS='IMR001'; CRCLS2='IMR002'
      IF ((TCODES) & (MOD(TMASK,2*J)>=J)) THEN
         OUTZAP('IBM00?'); OUTZAP('ICL00?');
         IN2NAME = ''; IN2CLASS = ''; IN2DISK = OUTDISK
         STOKES= 'I'; NFIELD = 1; FLUSAVE = FLUX; FLUX = 0
         RASHIFT=SHIFT(1),0; DECSHIFT=SHIFT(2),0; BMAJ = -1;
         OVERLAP=2; NGAUSS=4; WGAUS=0,0.7,2.1,6.3; DO3D=1
         FGAUS=0, 0.013, 0.070, 0.250; UVBOX=0; UVTAP=0
         IMAGRP=0; IMAGRP(11)~0.52,0,0.1,0.3,0.1,80; FACTOR=0
         ZIGW('UVSRT', 'IMAGR', 'IMR00?')
         OUTZAP('IBM00?'); NEWCLASS('ICL001', CRCLAS);
         NEWCLASS('ICL002','IMR002')
         NEWCLASS('ICL003','IMR003')
         NEWCLASS('ICL004','IMR004'); FLUX = FLUSAVE
         IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLAS,OUTDISK); END
         IF (TCODE='TEST') THEN CHECK(3,CRCLAS) END;
         IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLS2,OUTDISK); END
         IF (TCODE='TEST') THEN CHECK(4,CRCLS2) END;
         IF (TERSE<=3) THEN PRTHED(OUTNAME,'IMR003',OUTDISK);END
         IF (TCODE='TEST') THEN CHECK(5,'IMR003') END;
         IF (TERSE<=3) THEN PRTHED(OUTNAME,'IMR004',OUTDISK);END
         IF (TCODE='TEST') THEN CHECK(6,'IMR004') END;
         IF (TERSE <= 2) THEN PRTCAT; END
      ELSE IF (TCODE = 'WRIT') THEN
         IF (I) THEN; IF (MOD(TMASK,2*J)>=J) THEN
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
            IGW(CRCLAS, 'FITAB')
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            IGW(CRCLS2, 'FITAB'); CRCLS2='IMR003'
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            IGW(CRCLS2, 'FITAB'); CRCLS2='IMR004';
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            IGW(CRCLS2, 'FITAB'); END
         ELSE; DATAOUT = ''; IGW(CRCLAS, 'FITAB')
            IGW(CRCLS2, 'FITAB'); CRCLS2='IMR003'
            IGW(CRCLS2, 'FITAB'); CRCLS2='IMR004'
            IGW(CRCLS2, 'FITAB'); END
      ELSE IF (TCODE = 'READ') THEN
         IF (MOD(TMASK,2*J)>=J) THEN INCLAS='IMR00?'; DOCONF=-2
            INNAME = 'M' !! TNAMF; INDISK = 0; ALLDEST
            INCLAS=CRCLAS; INDISK=MDISK
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
            ELSE; DATAIN = ''; END;  TPLOD('FITLD')
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            ELSE; DATAIN='';END; TPLOD('FITLD'); CRCLS2='IMR003'
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            ELSE; DATAIN='';END; TPLOD('FITLD'); CRCLS2='IMR004'
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            ELSE; DATAIN = ''; END;  TPLOD('FITLD'); PRTCAT
         ELSE IF (^I) THEN; NFILE=4; AVFIL; NFILE=0; END; END
         END END END
   ELSE
      CRCLAS='APCLN'; CRCLS2 = 'APRES';
      IF ((TCODES) & (MOD(TMASK,2*J)>=J)) THEN
         IN2NAME = INNAME; IN2CLASS = 'IMBEAM'
         FLUSAVE = FLUX; FLUX = 0
         XTRSV1 = IN2DISK; IN2DISK = INDISK;
         ZIGW('IMAGE', 'APCLN', CRCLAS); IN2DISK = XTRSV1
         IF (TERSE<=3) THEN PRTHED(OUTNAME, CRCLAS, OUTDISK) END
         IF (TCODE = 'TEST') THEN CHECK(3,CRCLAS) END
         ZIGW('APCLN', 'SUBIM', CRCLS2)
         BMAJ = -1; BITER = NITER; OUTCLASS = CRCLS2; OUTSEQ = 1
         IN2NAME = INNAME; IN2CLASS = 'IMBEAM'; IN2DISK = INDISK
         INVERS=1; IGW('IMAGE', 'APCLN')
         IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLS2,OUTDISK); END
         IN2DISK = XTRSV1; OUTS = 0
         IF (TCODE = 'TEST') THEN CHECK(4,CRCLS2) END;
         IF (TERSE <= 2) THEN PRTCAT; END;   FLUX = FLUSAVE
      ELSE IF (TCODE = 'WRIT') THEN
         IF (I) THEN; IF (MOD(TMASK,2*J)>=J) THEN
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
            IGW(CRCLAS, 'FITAB')
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            IGW(CRCLS2, 'FITAB'); END
         ELSE; DATAOUT = ''; IGW(CRCLAS, 'FITAB')
            IGW(CRCLS2, 'FITAB'); END
      ELSE IF (TCODE = 'READ') THEN
         IF (MOD(TMASK,2*J)>=J) THEN INCLAS=CRCLAS; DOCONF=-2
            INNAME = 'M' !! TNAMF; INDISK = 0; ALLDEST
            INCLAS=CRCLS2; ALLDEST; INDISK=MDISK
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
            ELSE; DATAIN = ''; END;  TPLOD('FITLD')
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            ELSE; DATAIN = ''; END;  TPLOD('FITLD'); PRTCAT
         ELSE IF (^I) THEN; NFILE=2; AVFIL; NFILE=0; END; END
      END END END END;
   TASK = TNAME !! 'SAVE'; TPUT; RETURN
FINISH
CORE
SAVE Y2K004
* ==============================================================
* Compute revised gain & phase solution by self-calibration:
GET Y2K000
PROCEDURE Y2KPROC; TASK = TNAME !! 'SAVE'; TGET; J=8
   CRCLAS='CALIB'; I=LENGTH(Y2KFILE); SMODE=SUBSTR(TNAMF,4,4);
   TCODES = (TCODE='INIT') ! (TCODE='TEST')
   IF ((TCODES) & (MOD(TMASK,2*J)>=J)) THEN
      XTRSV1 = INDISK; XTRSV2 = IN2DISK; IN2DISK = INDISK
      IN2NAME = INNAME;
      IF (SMODE='H') THEN
         IN2CLASS='IMR001'; NMAPS=4; SOLMOD='A&P'; CPARM=0;
         WEIGHTIT=1
      ELSE
         IN2CLASS='APCLN'; NMAPS=1; SOLMOD='P'; CPARM=0,1
*     Merge deltas to avoid CALIB times dominating the result
         OUTVERS = 2; IGW('APCLN', 'CCMRG')
         END
      INDISK = DDISK; INNAME = 'D' !! TNAMF; SOLTYP='';
      SOLCON=0; DOFIT=0; FLUSAVE = FLUX; FLUX=0.0
      APARM=3,0,0,0,0,0,4,28,1,0; NCOMP=0; SOLINT=2.
      IF (Y2KSIZE='LARGE') THEN ; SOLINT=1; END
      IF (Y2KSIZE='HUGE') THEN ; SOLINT=1; END
      ZIGW('UVDATA', 'CALIB', CRCLAS)
*                   Remove SN table
      INCLAS='UVDATA';INS=0;INEXT='SN';INVER=0;EXTDES
*                   Destroy merged CC file
      IF (SMODE <> 'H') THEN; INDISK = XTRSV1; INVERS = 2;
         INNAME = IN2NAME; INCLASS = IN2CLASS; INEXT = 'CC';
         EXTDEST; INVERS = 0; END
      IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLAS,OUTDISK); END
      IN2DISK = XTRSV2; FLUX=FLUSAVE
      IF ((SMODE='L') ! (SMODE='H')) THEN
         IF TCODE='TEST' THEN UCHECK(0.5,CRCLAS); END
      ELSE
         IF TCODE='TEST' THEN UCHECK(0.05,CRCLAS); END; END
      IF (TERSE <= 2) THEN PRTCAT; END
   ELSE IF (TCODE = 'WRIT') THEN
      IF (I) THEN; IF (MOD(TMASK,2*J)>=J) THEN
         DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS
         IGW(CRCLAS, 'FITAB'); END
      ELSE; DATAOUT = ''; IGW(CRCLAS, 'FITAB') END;
   ELSE IF (TCODE = 'READ') THEN
      IF (MOD(TMASK,2*J)>=J) THEN INCLAS=CRCLAS; DOCONF=-2
         INNAME = 'M' !! TNAMF; INDISK=0;ALLDEST;INDISK=MDISK
         IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
         ELSE; DATAIN = ''; END;  TPLOD('FITLD'); PRTCAT
      ELSE IF (^I) THEN; NFILE=1; AVFIL; NFILE=0; END; END
      END END END;
   RETURN
FINISH
CORE
SAVE Y2K008
* ==============================================================
* Make a new clean map with IMAGR:
GET Y2K000
PROCEDURE Y2KPROC; TASK = TNAME !! 'SAVE'; TGET; J=16
   CRCLAS='IMCLN'; I=LENGTH(Y2KFILE); SMODE=SUBSTR(TNAMF,4,4)
   TCODES = (TCODE='INIT') ! (TCODE='TEST')
   IF (SMODE='H') THEN
      IF ((TCODES) & (MOD(TMASK,2*J)>=J)) THEN
         OUTZAP('IBM00?'); OUTZAP('ICL00?'); NITSAVE = NITER
         IN2NAME = ''; IN2CLASS = ''; IN2DISK = OUTDISK
         STOKES= 'I'; NFIELD = 1; FLUSAVE = FLUX; FLUX = 0
         RASHIFT=SHIFT(1),0; DECSHIFT=SHIFT(2),0;
         FACTOR=0; NITER=200000; OVERLAP=2; IM2PARM=0
         NGAUSS=4; WGAUS=0,0.7,2.1,6.3; DO3D=1; UVBOX=0
         FGAUS=0, 0.005, 0.025, 0.120; BMAJ=0; UVTAP=0
         IMAGRP=0; IMAGRP(11)~0.52,0,0.1,0.3,0.1,80
         ZIGW('CALIB', 'IMAGR', 'IMCLN?'); NITER=NITSAVE
         OUTZAP('IBM00?'); NEWCLASS('ICL001', CRCLAS)
         NEWCLASS('ICL002', 'IMCLN2');
         NEWCLASS('ICL003', 'IMCLN3');
         NEWCLASS('ICL004', 'IMCLN4');
         IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLAS,OUTDISK); END
         IF (TCODE='TEST') THEN CHECK(7,CRCLAS) END;
         CRCLS2='IMCLN2'
         IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLS2,OUTDISK); END
         IF (TCODE='TEST') THEN CHECK(8,CRCLS2) END;
         CRCLS2='IMCLN3'
         IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLS2,OUTDISK); END
         IF (TCODE='TEST') THEN CHECK(9,CRCLS2) END;
         CRCLS2='IMCLN4'
         IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLS2,OUTDISK); END
         IF (TCODE='TEST') THEN CHECK(10,CRCLS2) END;
         IF (TERSE <= 2) THEN PRTCAT; END; FLUX = FLUSAVE
      ELSE IF (TCODE = 'WRIT') THEN
         IF (I) THEN; IF (MOD(TMASK,2*J)>=J) THEN
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS
            IGW(CRCLAS, 'FITAB'); CRCLS2='IMCLN2'
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLS2
            IGW(CRCLS2, 'FITAB'); CRCLS2='IMCLN3'
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLS2
            IGW(CRCLS2, 'FITAB'); CRCLS2='IMCLN4'
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLS2
            IGW(CRCLS2, 'FITAB'); END
         ELSE; DATAOUT = '' ;IGW(CRCLAS, 'FITAB')
             CRCLS2='IMCLN2'; IGW(CRCLS2, 'FITAB')
             CRCLS2='IMCLN3'; IGW(CRCLS2, 'FITAB')
             CRCLS2='IMCLN4'; IGW(CRCLS2, 'FITAB'); END;
      ELSE IF (TCODE = 'READ') THEN
         IF (MOD(TMASK,2*J)>=J) THEN INCLAS='IMCLN?';INDISK=0
            INNAME = 'M' !! TNAMF;DOCONF=-2;ALLDEST;INDISK=MDISK
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
            ELSE; DATAIN = ''; END
            TPLOD('FITLD'); CRCLS2='IMCLN2'
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            ELSE; DATAIN = ''; END
            TPLOD('FITLD'); CRCLS2='IMCLN3'
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            ELSE; DATAIN = ''; END
            TPLOD('FITLD'); CRCLS2='IMCLN4'
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLS2;
            ELSE; DATAIN = ''; END; TPLOD('FITLD'); PRTCAT
         ELSE IF (^I) THEN; NFILE=4; AVFIL; NFILE=0; END; END
         END END END;
   ELSE
      IF ((TCODES) & (MOD(TMASK,2*J)>=J)) THEN
         OUTZAP('IBM00?'); OUTZAP('ICL00?'); NITSAVE = NITER
         IN2NAME = ''; IN2CLASS = ''; IN2DISK = OUTDISK
         STOKES= 'I'; NFIELD = 1; FLUSAVE = FLUX; FLUX = 0
         RASHIFT=SHIFT(1),0; DECSHIFT=SHIFT(2),0;
         FACTOR=0
         IF (SMODE='L') THEN ; NITER = 3 * NITER; END
         OUTZAP(CRCLAS); ZIGW('CALIB', 'IMAGR', 'ICL001')
         NITER=NITSAVE; OUTZAP('IBM00?');
         NEWCLASS('ICL001', CRCLAS);
         IF (TERSE<=3) THEN PRTHED(OUTNAME,CRCLAS,OUTDISK); END
         IF (TCODE='TEST') THEN CHECK(7,CRCLAS) END;
         IF (TERSE <= 2) THEN PRTCAT; END; FLUX = FLUSAVE
      ELSE IF (TCODE = 'WRIT') THEN
         IF (I) THEN; IF (MOD(TMASK,2*J)>=J) THEN
            DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS
            IGW(CRCLAS, 'FITAB'); END
         ELSE; DATAOUT = ''; IGW(CRCLAS, 'FITAB') END;
      ELSE IF (TCODE = 'READ') THEN
         IF (MOD(TMASK,2*J)>=J) THEN INCLAS=CRCLAS; INDISK=0
            INNAME = 'M' !! TNAMF;DOCONF=-2;ALLDEST;INDISK=MDISK
            IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I)!!CRCLAS;
            ELSE; DATAIN = ''; END;  TPLOD('FITLD'); PRTCAT
         ELSE IF (^I) THEN; NFILE=1; AVFIL; NFILE=0; END; END
         END END END END;
   TASK = TNAME !! 'SAVE'; TPUT; RETURN
FINISH
OUTSEQ=1
CORE
SAVE Y2K016
* ==============================================================
* Deconvolve the map using Maximum Entropy: 1

GET Y2K000
PROCEDURE Y2KPROC; TASK = TNAME !! 'SAVE'; TGET
   CRCLAS='VTESS'; CRCLS2='IMINVT'; J=32; I=LENGTH(Y2KFILE)
   SMODE=SUBSTR(TNAMF,4,4)
   TCODES = (TCODE='INIT') ! (TCODE='TEST')
   IF ((TCODES) & (MOD(TMASK,2*J)>=J)) THEN
*                                  make new dirty map/beam
      OUTZAP('IBM00?'); OUTZAP('ICL00?'); NITSAVE = NITER
      IN2NAME = ''; IN2CLASS = ''; IN2DISK = OUTDISK; NITER=0
      STOKES= 'I'; NFIELD = 1; FLUSAVE = FLUX; FLUX = 0
      RASHIFT=SHIFT(1),0; DECSHIFT=SHIFT(2),0;
      IF (SMODE='H') THEN; CELLS = 0.058; END
      ZIGW('CALIB', 'IMAGR', 'IIM001'); NITER=NITSAVE
      IN2NAME = INNAME; IN2CLASS = 'IBM001'; IN2DISK = INDISK
      IF (SMODE='H') THEN;
         APARM=0,0,0,0.050/CELLS(1)
         ZIGW('IMCLN','OGEOM','OGEOM'); PIXVAL=0;
         PHDSV3=INNAME; INNAME=OUTNAME
         ZIGW('OGEOM','REMAG',CRCLS2);
         OUTZAP('OGEOM'); INNAME=PHDSV3
      ELSE
         ZIGW('IMCLN','SUBIM',CRCLS2);
         END
      IN3CLAS = CRCLS2
      IN3NAME = OUTNAME; IN3DISK = OUTDISK; IN3SEQ = -1
      INCLAS = IN3CL; INNAME = IN3NA; INDISK = IN3DISK
      OFFSET = 0; FACTOR = 1/SCALR1; RESCALE; BMAJ=0
      NITSAVE = NITER; NITER = SCALR2; NMAPS = 1
      IN2NAM = INNAME; IN2DISK = INDISK;
      OUTZAP('VTESSC'); OUT2NAME=OUTNAME; OUT2CLAS='VTESSC';
      OUT2SEQ=0; OUT2DISK = OUTDISK; FLUX=SCALR3
      IF ((SMODE='L') ! (SMODE='H')) THEN; FLUX=-SCALR3/10; END
      ZIGW('IIM001', 'VTESS', CRCLAS); FLUX=FLUSAVE
      IF (TERSE<=3) THEN PRTHED(OUTNAME, CRCLAS, OUTDISK); END
      IF (TCODE = 'TEST') THEN CHECK(11,CRCLAS); END
      IF (TERSE<=3) THEN PRTHED(OUTNAME,'VTESSC',OUTDISK); END
      IF (TCODE = 'TEST') THEN CHECK(12,'VTESSC'); END
      OUTZAP (CRCLS2);   NITER = NITSAVE
      IF (TERSE <= 2) THEN PRTCAT; END
      OUTZAP('IBM001'); OUTZAP('IIM001')
   ELSE IF (TCODE = 'WRIT') THEN
      IF (I) THEN; IF (MOD(TMASK,2*J)>=J) THEN
         DATAOUT = SUBSTR(Y2KFILE,1,I) !! CRCLAS
         IGW(CRCLAS, 'FITAB');
         DATAOUT = SUBSTR(Y2KFILE,1,I) !! 'VTESSC'
         IGW('VTESSC', 'FITAB'); END
      ELSE; DATAOUT = ''; IGW(CRCLAS, 'FITAB');
         IGW('VTESSC', 'FITAB'); END
   ELSE IF (TCODE = 'READ') THEN
      IF (MOD(TMASK,2*J)>=J) THEN INCLAS=CRCLAS; DOCONF=-2
         INNAME = 'M' !! TNAMF; INDISK=0;ALLDEST;INDISK=MDISK
         IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! CRCLAS;
         ELSE; DATAIN = ''; END;  TPLOD('FITLD'); PRTCAT
         INCLAS='VTESSC'; INNAME='M'!!TNAMF; INDISK=0; ALLDEST
         INDISK=MDISK
         IF (I) THEN; DATAIN = SUBSTR(Y2KFILE,1,I) !! 'VTESSC'
         ELSE; DATAIN = ''; END;  TPLOD('FITLD'); PRTCAT
      ELSE IF (^I) THEN; NFILE=2; AVFIL; NFILE=0; END; END
   END; END; END
   TASK = TNAME !! 'SAVE'; TPUT; RETURN
FINISH
CORE
SAVE Y2K032
* ==============================================================
* Thats all, folks!
GET Y2K000
PROCEDURE Y2KPROC; TASK = TNAME !! 'SAVE'; TGET
STRING*6 DIFNAM(12)
   SMODE=SUBSTR(TNAMF,4,4); SMODE = SUBSTR (TNAMF, 4, 4) ;
   DIFNAM='IMAGE','IMBEAM','','','','','IMCLN';
   DIFNAM(11)~'VTESS', 'VTESSC'; I = LENGTH(Y2KFILE);
   IF SMODE='H' THEN
      DIFNAM(3)~'IMRES1','IMRES2','IMRES3','IMRES4'
      DIFNAM(8)~'IMCLN2','IMCLN3','IMCLN4'; OPTYPE = 'Y2KH'
   ELSE
      DIFNAM(3)~'APCLN','APRES';  OPTYPE = 'Y2K'
      END
   IF (TCODE = 'TEST') THEN PRTCAT;
      FOR I = 1:12; ERATIO = MPDIFS(1,I); JJCNT=MPDIFS(2,I);
         IF ((ERATIO > -90) & (DIFNAM(I)<>' ')) THEN
            PRINT DIFNAM(I), ERATIO, JJCNT;
         END; END
      FOR I = 1:12; ERATIO = MPDIFS(1,I)
         IF ((ERATIO > -90) & (DIFNAM(I)<>' ')) THEN
            PRINT DIFNAM(I), MPDIFS(3,I),MPDIFS(4,I),MPDIFS(5,I)
         END; END
      PRINT SPACER
      PRINT 'PRINTING MESSAGES SUGGESTIVE OF ERROR: PRIO > 5'
      PRIORITY=6; PRNUM=0; PRTASK=''
      IF (TERSE > 0) THEN DOCRT=1; ELSE DOCRT=-1; END; PRTMSG
      PRINT SPACER ; CPUTIME
      PRINT SPACER
      PRINT 'PRINTING ANSWERS, ERRORS, OTHER IMPORTANT MESSAGES'
      DOCRT=-1; PRIORITY=5; PRNUM=0; PRTASK=''; PRTMSG
   ELSE IF (TCODE = 'WRIT') THEN
      IF (I=0) THEN; NFILES = 0; IGW('', 'PRTTP'); REWIND; END
   ELSE IF (TCODE = 'READ') THEN
      IF (I=0) THEN; REWIND; END; PRTCAT
   END END END;
   DOWAIT -1; PRTIME=2; DOCRT=-1;
   IF (TCODE<>'TEST') THEN; OPTY=' '; END
   IF (TERSE <= 0) THEN IGW('','PRTAC'); END
   TYPE 'That"s all, Folks!'
   RETURN
FINISH
CORE
SAVE Y2K9999
* ==============================================================
* Restore to prior status:
RESTORE 1
CORE
SGDESTR Y2K000
SGINDEX