LOCAL INCLUDE 'MASKS.INC'
      INCLUDE 'INCS:PCLN.INC'
      HOLLERITH XNAMEI(3), XCLASI(2), XNAMEO(3), XCLASO(2), XBXFIL(12)
      REAL      XDISKI, XSEQI, XDISKO, XSEQO, DOBLNK, DONUMB
      COMMON /INPARM/ XNAMEI, XCLASI, XSEQI, XDISKI, XNAMEO, XCLASO,
     *   XSEQO, XDISKO, XBXFIL, DOBLNK, DONUMB
C
      INTEGER   SEQIN, DISKIN, CNOIN, CNOOU,  SEQOU, DISKOU, SCRTCH(256)
      CHARACTER BOXFIL*48, NAMEIN*12, CLASIN*6, NAMEOU*12, CLASOU*6
      COMMON /SETFCP/ SEQIN, DISKIN, CNOIN, SEQOU, DISKOU, CNOOU
      COMMON /SETFCC/ BOXFIL, NAMEIN, CLASIN, NAMEOU, CLASOU
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
LOCAL END
      PROGRAM MASKS
C-----------------------------------------------------------------------
C! read a BOXFILE to make images of the Clean boxes
C# Imaging
C-----------------------------------------------------------------------
C;  Copyright (C) 2020
C;  Associated Universities, Inc. Washington DC, USA.
C;
C;  This program is free software; you can redistribute it and/or
C;  modify it under the terms of the GNU General Public License as
C;  published by the Free Software Foundation; either version 2 of
C;  the License, or (at your option) any later version.
C;
C;  This program is distributed in the hope that it will be useful,
C;  but WITHOUT ANY WARRANTY; without even the implied warranty of
C;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C;  GNU General Public License for more details.
C;
C;  You should have received a copy of the GNU General Public
C;  License along with this program; if not, write to the Free
C;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   MASKS makes images from an input BOXFILE of Clean boxes
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME       XNAMEI/NAMEIN    Name of input UV data.
C      INSEQ        SEQ/SEQIN        Seq. of input UV data.
C      INDISK       DISKIN/IDISK     Disk number of input UV data.
C      BOXFILE      XBXFIL/BOXFIL    BOXFILE output file name.
C      CELLSIZE     CELSIZ           pixel size in image.
C      IMSIZE       XSIZE/IMSIZE     image size, also field size.
C-----------------------------------------------------------------------
      INCLUDE 'INCS:PCLN.INC'
      INCLUDE 'MASKS.INC'
      INTEGER   IRET, NFIELD, NBOXES(MAXFLD), WIN(4,MXNBFL)
C-----------------------------------------------------------------------
C                                       init and read BOXFILE
      CALL MASKIN (NFIELD, NBOXES, WIN, IRET)
C                                       make images
      IF (IRET.EQ.0) CALL MASKDO (NFIELD, NBOXES, WIN, IRET)
C
      CALL DIE (IRET, SCRTCH)
C
 999  STOP
      END
      SUBROUTINE MASKIN (NFIELD, NBOXES, WIN, IRET)
C-----------------------------------------------------------------------
C   Input routine - reads BOXFILE returning parameters
C   Output:
C      NFIELD   I        1
C      NBOXES   I(*)     Max box number in field
C      WIN      I(4,*)   Box pixel numbers
C-----------------------------------------------------------------------
      INTEGER   NFIELD, NBOXES(*), WIN(4,*), IRET
C
      INTEGER   NPARMS, IERR, CATOLD(256), IMSIZE(2)
      REAL      S
      CHARACTER PNAM*6, MTYPE*2, BLANK*6, STAT*4
      INCLUDE 'MASKS.INC'
      DATA PNAM /'MASKS'/
      DATA BLANK /' '/
C-----------------------------------------------------------------------
C                                       initialize
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
C                                       Initialize HITAB
      CALL HIINIT (3)
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
C                                       get the input parameters
      NPARMS = 28
      CALL GTPARM (PNAM, NPARMS, RQUICK, XNAMEI, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         IRET = 1
         RQUICK = .FALSE.
         IF (IERR.EQ.1) THEN
            MSGTXT = 'CANNOT FIND INITIATOR IN GTPARM'
            CALL MSGWRT (1)
            GO TO 999
         ELSE
            MSGTXT= 'DISK PROBLEMS IN GTPARM'
            CALL MSGWRT (6)
            GO TO 999
            END IF
         END IF
      IRET = 0
      IF (RQUICK) CALL RELPOP (IRET, SCRTCH, IERR)
C                                       set parameters
      CALL H2CHR (48, 1, XBXFIL, BOXFIL)
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (12, 1, XNAMEO, NAMEOU)
      CALL H2CHR (6, 1, XCLASI, CLASIN)
      CALL H2CHR (6, 1, XCLASO, CLASOU)
      SEQIN = XSEQI + 0.5
      DISKIN = XDISKI + 0.5
      SEQOU = XSEQO + 0.5
      DISKOU = XDISKO + 0.5
C                                       Create new file.
C                                       Get CATBLK from old file.
      CNOIN = 1
      MTYPE = 'MA'
      CALL CATDIR ('SRCH', DISKIN, CNOIN, NAMEIN, CLASIN, SEQIN, MTYPE,
     *   NLUSER, STAT, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1030) IRET, NAMEIN, CLASIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
C                                       Read CATBLK and mark 'READ'.
      CALL CATIO ('READ', DISKIN, CNOIN, CATOLD, 'READ', SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING IMAGE HEADER'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = CNOIN
      FRW(NCFILE) = 0
C                                       Copy old CATBLK to new.
      CALL COPY (256, CATOLD, CATBLK)
C                                       Put new values in CATBLK.
      CALL MAKOUT (NAMEIN, CLASIN, SEQIN, BLANK, NAMEOU, CLASOU, SEQOU)
      CALL CHR2H (12, NAMEOU, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLASOU, KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQOU
C                                       General header parms
      CATR(KRDMN) = 0.0
      CATR(KRDMX) = 2.0
      IF (DONUMB.GT.0.0) CATR(KRDMX) = 3.0
      IF (DONUMB.LT.-1.0) CATR(KRDMX) = 1.0
      S = FBLANK
      IF (DOBLNK.LE.0.0) S = 0.0
      CATR(KRBLK) = S
C                                       Create output file.
      CNOOU = 1
      CALL MCREAT (DISKOU, CNOOU, SCRTCH, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'CREATING OUTPUT IMAGE'
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKOU
      FCNO(NCFILE) = CNOOU
      FRW(NCFILE) = 2
      IRET = 0
      SEQOU = CATBLK(KIIMS)
C                                       read boxfile for Clean windows
      NFIELD = 1
      IMSIZE(1) = CATBLK(KINAX)
      IMSIZE(2) = CATBLK(KINAX+1)
      CALL WINDF (WIN, NBOXES, NFIELD, IMSIZE, BOXFIL, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READING BOXFILE'
         GO TO 990
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MASKIN ERROR',I5,' ON ',A)
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I3,' DISK=',
     *   I3,' USID=',I5)
      END
      SUBROUTINE MASKDO (NFIELD, NBOXES, WIN, IRET)
C-----------------------------------------------------------------------
C   Makes images
C   Input:
C      NFIELD   I        Max field number
C      NBOXES   I(*)     Max box number in field
C      WIN      I(4,*)   Box pixel numbers
C   Output:
C      IRET     I        Error code
C-----------------------------------------------------------------------
      INTEGER   NFIELD, NBOXES(*), WIN(4,NFIELD,*), IRET
C
      INCLUDE 'INCS:PMAD.INC'
      INTEGER   NX, NY, IY, IFIELD, I, LUN, FIND, IWIN(4), NBY, IBLKOF,
     *   POS, J, JO, HLUN, HBUF(256), DATE(3), TIME(3), NC, IXC, IYC, LF
      CHARACTER OBJ*8, OBS*8, MTYPE*2, CDATE*12, CTIME*8, HILINE*72,
     *   BUN*8, TEL*8, FLDC*4
      REAL      BUFF(MABFSS), X, S, EDGE
      INCLUDE 'MASKS.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA OBJ, OBS, BUN, TEL /'TESTFACE','MASKS','JY/BEAM','AIPS'/
      DATA LUN, IBLKOF, HLUN /16, 1, 17/
C-----------------------------------------------------------------------
      EDGE = 2.0
      IF (DONUMB.LT.-1.0) EDGE = 1.0
      NBY = 2 * MABFSS
      FLDC = '1'
      NC = 1
C                                       General header parms
      S = FBLANK
      IF (DOBLNK.LE.0.0) S = 0.0
      LF = 0
      IF (DONUMB.GT.0) LF = 1
      NX = CATBLK(KINAX)
      NY = CATBLK(KINAX+1)
C                                       loop over fields (images)
      DO 100 IFIELD = 1,NFIELD
C                                       Open new file.
         MTYPE = 'MA'
         CALL MAPOPN ('INIT', DISKOU, NAMEOU, CLASOU, SEQOU, MTYPE,
     *      NLUSER, LUN, FIND, CNOOU, CATBLK, SCRTCH, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPEN', IFIELD
            GO TO 990
            END IF
C                                       Window for output file
         IWIN(1) = 1
         IWIN(2) = 1
         IWIN(3) = NX
         IWIN(4) = NY
         CALL MINIT ('WRIT', LUN, FIND, NX, NY, IWIN, BUFF, NBY,
     *      IBLKOF, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'INITIALIZ', IFIELD
            GO TO 990
            END IF
         DO 50 IY = 1,NY
C                                       "write" before data
            CALL MDISK ('WRIT', LUN, FIND, BUFF, POS, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'WRIT', IFIELD
               GO TO 980
               END IF
            CALL RFILL (NX, S, BUFF(POS))
            DO 30 I = 1,NBOXES(IFIELD)
C                                       rectangles
               IF (WIN(1,IFIELD,I).GT.0) THEN
                  IF ((IY.GE.WIN(2,IFIELD,I)) .AND.
     *               (IY.LE.WIN(4,IFIELD,I))) THEN
                     JO = WIN(1,IFIELD,I)
                     J = WIN(3,IFIELD,I) - JO + 1
                     IYC = (WIN(2,IFIELD,I) + WIN(4,IFIELD,I)) / 2
                     IXC = (WIN(1,IFIELD,I) + WIN(3,IFIELD,I)) / 2
                  ELSE
                     J = 0
                     END IF
C                                       circles
               ELSE
                  J = ABS(IY-WIN(4,IFIELD,I))
                  IF (J.LE.WIN(2,IFIELD,I)) THEN
                     X = SQRT (REAL(WIN(2,IFIELD,I))**2 - J*J)
                     IXC = WIN(3,IFIELD,I)
                     IYC = WIN(4,IFIELD,I)
                     J = IXC + X
                     JO = 2 * IXC - J
                     J = J - JO + 1
                  ELSE
                     J = 0
                     END IF
                  END IF
               IF (J.GT.0) THEN
                  JO = JO  + POS - 1
                  CALL RFILL (J, 1.0, BUFF(JO))
                  BUFF(JO) = EDGE
                  BUFF(JO+J-1) = EDGE
                  IF ((WIN(1,IFIELD,I).GT.0) .AND.
     *               ((IY.EQ.WIN(2,IFIELD,I)) .OR.
     *               (IY.EQ.WIN(4,IFIELD,I))))
     *               CALL RFILL (J, EDGE, BUFF(JO))
                  IF (DONUMB.GT.0.0) THEN
                     IF ((ABS(IY-IYC)/LF.LE.3) .AND. (J.GE.7*NC*LF)
     *                  .AND. (JO-POS+1.LE.IXC-(7*NC*LF)/2)) THEN
                        JO = IXC - (7*NC*LF)/2 + POS - 1
                        J = (IY - IYC + 4*LF + 1) / LF
                        CALL CHKCHR (FLDC, NC, LF, J, BUFF(JO))
                     ELSE IF ((ABS(IY-IYC).LE.3) .AND. (J.GE.7*NC)
     *                  .AND. (JO-POS+1.LE.IXC-(7*NC)/2)) THEN
                        JO = IXC - (7*NC)/2 + POS - 1
                        J = (IY - IYC + 4 + 1)
                        CALL CHKCHR (FLDC, NC, 1, J, BUFF(JO))
                        END IF
                     END IF
                  END IF
 30            CONTINUE
 50         CONTINUE
C                                       write last of data
         CALL MDISK ('FINI', LUN, FIND, BUFF, POS, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'FINISH', IFIELD
            GO TO 980
            END IF
C                                       Fake up history
         CALL HICREA (HLUN, DISKOU, CNOOU, CATBLK, HBUF, IRET)
C                                       Write time and date on new file
         IF (IRET.EQ.0) THEN
            CALL ZDATE (DATE)
            CALL ZTIME (TIME)
            CALL TIMDAT (TIME, DATE, CTIME, CDATE)
            WRITE (HILINE,1050) TSKNAM, RLSNAM, CDATE, CTIME
            CALL HIADD (HLUN, HILINE, HBUF, IRET)
            END IF
         IF (IRET.EQ.0) CALL HENCOO (TSKNAM, NAMEOU, CLASOU, SEQOU,
     *      DISKOU, HLUN, HBUF, IRET)
         IF (IRET.EQ.0) THEN
            WRITE (HILINE,1055) TSKNAM, IFIELD, BOXFIL(:47)
            CALL HIADD (HLUN, HILINE, HBUF, IRET)
            END IF
         CALL HICLOS (HLUN, .TRUE., HBUF, IRET)
         IRET = 0
C                                       Close image
         CALL MAPCLS ('INIT', DISKOU, CNOOU, LUN, FIND, CATBLK, .TRUE.,
     *      BUFF, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'CLOS', IFIELD
            GO TO 990
            END IF
 100     CONTINUE
      NCFILE = NCFILE - 1
      GO TO 999
C
 980  CALL ZCLOSE (LUN, FIND, I)
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('ERROR',I6,1X,A,'ING IMAGE',I4)
 1050 FORMAT (A6,'RELEASE =''',A7,' ''  /********* Start ',A12,2X,A8)
 1055 FORMAT (A6,'FIELD=',I4,' BOXFILE=',A)
      END
      SUBROUTINE CHKCHR (STR, NC, LF, IY, BUFF)
C-----------------------------------------------------------------------
C   CHKCHR inserts characters into the data buffer 1 pixel row at a
C   time
C   Inputs:
C      STR    C*(*)   Character string
C      NC     I       Number of characters in STR
C      LF     I       Repetition factor
C      IY     I       Pixel number vertically within character string
C   Output:
C      BUFF   R(*)    Data buffer
C-----------------------------------------------------------------------
      CHARACTER STR*(*)
      INTEGER   NC, LF, IY
      REAL      BUFF(*)
C
      INTEGER   I, JT, LT, KT, BITS(15), SCRTCH(20), IDX, II, JJ,
     *   MASK, ZAND, TABLE(5,97), TAB2(5,17), TAB3(5,16), TAB4(5,16),
     *   TAB5(5,16), TAB6(5,16), TAB7(5,16), IT, IC, J
      INCLUDE 'INCS:DDCH.INC'
      EQUIVALENCE  (TABLE(1, 1), TAB2),  (TABLE(1,18), TAB3),
     *             (TABLE(1,34), TAB4),  (TABLE(1,50), TAB5),
     *             (TABLE(1,66), TAB6),  (TABLE(1,82), TAB7)
C                                        control chars all ?
C                                        blank !"#$%&'()*+,-./
      DATA TAB2/  32,  64,  69,  72,  48,
     *             0,   0,   0,   0,   0,
     *             0,   0, 121,   0,   0,
     *             0, 112,   0, 112,   0,
     *            20,  62,  20,  62,  20,
     *            18,  42, 127,  42,  36,
     *             2,  36,   8,  18,  32,
     *            54,  73,  85,  34,   5,
     *             0,   0, 112,   0,   0,
     *             0,  28,  34,  65,   0,
     *             0,  65,  34,  28,   0,
     *            20,   8,  62,   8,  20,
     *             8,   8,  62,   8,   8,
     *             0,   1,   6,   0,   0,
     *             0,   8,   8,   8,   0,
     *             0,   0,   1,   0,   0,
     *             2,   4,   8,  16,  32/
C                                        0123456789:;<=>?
      DATA TAB3/  62,  69,  73,  81,  62,
     *             0,  33, 127,   1,   0,
     *            35,  69,  73,  73,  49,
     *            66,  65,  73,  89, 102,
     *            12,  20,  36, 127,   4,
     *           114,  81,  81,  81,  78,
     *            30,  41,  73,  73,  70,
     *            64,  71,  72,  80,  96,
     *            54,  73,  73,  73,  54,
     *            49,  73,  73,  74,  60,
     *             0,   0,  18,   0,   0,
     *             0,   1,  22,   0,   0,
     *             8,  20,  34,  65,   0,
     *            20,  20,  20,  20,   0,
     *            65,  34,  20,   8,   0,
     *            32,  64,  69,  72,  48/
C
C                                       ABCDEFGHIJKLMNO
      DATA TAB4/  18,  37,  37,  37,  30,
     *            31,  36,  68,  36,  31,
     *           127,  73,  73,  73,  34,
     *            62,  65,  65,  65,  34,
     *            65, 127,  65,  65,  62,
     *           127,  73,  73,  73,  65,
     *           127,  72,  72,  64,  64,
     *            62,  65,  65,  69,  39,
     *           127,   8,   8,   8, 127,
     *             0,  65, 127,  65,   0,
     *             2,   1,   1,   1, 126,
     *           127,   8,  20,  34,  65,
     *           127,   1,   1,   1,   1,
     *           127,  32,  24,  32, 127,
     *           127,  16,   8,   4, 127,
     *            62,  65,  65,  65,  62/
C                                        PQRSTUVWXYZ[\]^_
      DATA TAB5/ 127,  72,  72,  72,  48,
     *            62,  65,  69,  66,  61,
     *           127,  72,  76,  74,  49,
     *            50,  73,  73,  73,  38,
     *            64,  64, 127,  64,  64,
     *           126,   1,   1,   1, 126,
     *           112,  12,   3,  12, 112,
     *           126,   1,  14,   1, 126,
     *            99,  20,   8,  20,  99,
     *            96,  16,  15,  16,  96,
     *            67,  69,  73,  81,  97,
     *             0,   0, 127,  65,   0,
     *            32,  16,   8,   4,   2,
     *             0,  65, 127,   0,   0,
     *            16,  32,  64,  32,  16,
     *             1,   1,   1,   1,   1/
C                                        `abcdefghijklmno
      DATA TAB6/   0,  64,  32,  16,  0,
     *            31,  36,  68,  36,  31,
     *           127,  73,  73,  73,  34,
     *            62,  65,  65,  65,  34,
     *            65, 127,  65,  65,  62,
     *           127,  73,  73,  73,  65,
     *           127,  72,  72,  64,  64,
     *            62,  65,  65,  69,  39,
     *           127,   8,   8,   8, 127,
     *            65,  65, 127,  65,  65,
     *             2,   1,   1,   1, 126,
     *           127,   8,  20,  34,  65,
     *           127,   1,   1,   1,   1,
     *           127,  32,  24,  32, 127,
     *           127,  16,   8,   4, 127,
     *            62,  65,  65,  65,  62/
C                                        pqrstuvwxyz{ }~?
      DATA TAB7/ 127,  72,  72,  72,  48,
     *            62,  65,  69,  66,  61,
     *           127,  72,  76,  74,  49,
     *            50,  73,  73,  73,  38,
     *            64,  64, 127,  64,  64,
     *           126,   1,   1,   1, 126,
     *           112,  12,   3,  12, 112,
     *           126,   1,  14,   1, 126,
     *            99,  20,   8,  20,  99,
     *            96,  16,  15,  16,  96,
     *            67,  69,  73,  81,  97,
     *             0,   8,  54,  65,   0,
     *             0,   0, 127,   0,   0,
     *             0,  65,  54,   8,   0,
     *             4,   8,   4,   2,   4,
     *            32,  64,  69,  72,  48/
C-----------------------------------------------------------------------
      IDX = 1
      DO 20 I = 1,NC
C                                       get standard ASCII char
C                                       in highly machine independent
         JT = NBITWD / 8
         CALL ZCLC8 (1, STR(I:I), JT, LT)
         CALL ZI32IL (1, 1, LT, KT)
         IT = NBITWD - (JT-1)*8
         CALL ZGTBIT (IT, KT, BITS)
         CALL ZPTBIT (8, IC, BITS(IT-7))
C                                       all CTRL characters to 1
         IC = MAX (1, IC-30)
         CALL COPY (5, TABLE(1,IC), SCRTCH(IDX))
         IDX = IDX + 5
 20      CONTINUE
C                                       just the selected row
      MASK = 2 ** (IY-1)
      JJ = 1
      IDX = 1
C                                        if mask bit on in char value
C                                        then set to -1 else to 0
      DO 40 J = 1,NC
         IDX = IDX + LF
         DO 35 II = 1,5
            IC = ZAND (MASK, SCRTCH(JJ))
            DO 30 I = 1,LF
               IF ((IC.NE.0) .AND. (BUFF(IDX).NE.FBLANK)) BUFF(IDX) =
     *            3.0 * BUFF(IDX)
               IDX = IDX + 1
 30            CONTINUE
            JJ = JJ + 1
 35         CONTINUE
         IDX = IDX + LF
 40      CONTINUE
C
 999  RETURN
      END

