LOCAL INCLUDE 'MARSP.INC'
      INCLUDE 'INCS:PMAD.INC'
      INTEGER   SEQ(2), DISK(2), OLDCNO(2), CATOLD(256), JBUFSZ,
     *   SCRTCH(256), NPARM, NBOXES, NPIX(3)
      LOGICAL   ISQU
      HOLLERITH XNAME1(3), XCLAS1(2), XNAME2(3), XCLAS2(2), XFUNC(1)
      CHARACTER NAMEIN(2)*12, CLAIN(2)*6
      REAL      XSEQ1, XDISK1, XSEQ2, XDISK2, BLC(7), TRC(7),
     *   CPARM(10), DOPLOT, XNBOX, XPIXR(2), XGRCH, XDOTV,
     *   BUFF1(MABFSS), HISTO(1801)
      COMMON /INPARM/ XNAME1, XCLAS1, XSEQ1, XDISK1, XNAME2, XCLAS2,
     *   XSEQ2, XDISK2, BLC, TRC, CPARM, DOPLOT, XNBOX, XPIXR, XGRCH,
     *   XFUNC, XDOTV
      COMMON /CHPARM/ NAMEIN, CLAIN
      COMMON /PARMS/ CATOLD, SEQ, DISK, OLDCNO, JBUFSZ, ISQU, NPARM,
     *   HISTO, NBOXES, NPIX
      COMMON /BUFRS/ BUFF1, SCRTCH
LOCAL END
      PROGRAM MARSP
C-----------------------------------------------------------------------
C! Measure MARS polarization
C# Map-util Utility
C-----------------------------------------------------------------------
C;  Copyright (C) 2012, 2021-2022, 2024-2025
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   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAMEIN        Name of input image. POLI or Q
C      INCLASS        CLAIN         Class of input image.
C      INSEQ          SEQIN         Seq. of input image.
C      INDISK         DISKIN        Disk number of input image.
C      IN2NAME        NAMOUT        Name of the input image POLA or U
C      IN2CLASS       CLAOUT        Class of the input image.
C      IN2SEQ         SEQIN2        Seq. number of input image.
C      IN2DISK        DISK2         Disk number of input image.
C      BLC(7)         BLC           Bottom left corner of subimage
C      TRC(7)         TRC           Top right corner of subimage.
C      CPARM(10)      CPARM         User specified array.
C      DOPLOT         DOPLOT        > Make histogram plot
C      FUNCTYPE       XFUNC         'LG'
C      DOTV           DOTV          > 0 on the TV, else plot file
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET, NWORDS
      REAL      POLI(2), POLA(2)
      LONGINT   PPOLI, PPOLA
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'MARSP.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'MARSP '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL MARSPI (PRGM, IRET)
C                                       dynamic memory
      IF (IRET.EQ.0) THEN
         NWORDS = (CATBLK(KINAX) * CATBLK(KINAX+1) - 1) / 1024 + 5
         CALL ZMEMRY ('GET ', TSKNAM, NWORDS, POLI, PPOLI, IRET)
         IF (IRET.EQ.0) CALL ZMEMRY ('GET ', TSKNAM, NWORDS, POLA,
     *      PPOLA, IRET)
         IF (IRET.NE.0) THEN
            MSGTXT = 'FAILED TO GET DYNAMIC MEMORY'
            CALL MSGWRT (8)
            END IF
         END IF
C                                       read images, analyze
      IF (IRET.EQ.0) CALL MARSPD (CATBLK(KINAX), CATBLK(KINAX+1),
     *      POLI(1+PPOLI), POLA(1+PPOLA), IRET)
      IF ((IRET.EQ.0) .AND. (DOPLOT.GT.0.0)) CALL MARSPL (IRET)
C                                       Close down files, etc.
      CALL DIE (IRET, SCRTCH)
C
 999  STOP
      END
      SUBROUTINE MARSPI (PRGN, IRET)
C-----------------------------------------------------------------------
C   MARSPI gets input parameters for MARSP and creates an output file.
C   Inputs:
C      PRGN    C*6  Program name
C   Output:
C      IRET    I    Error code: 0 => ok
C                               4 => user routine detected error.
C                               5 => catalog troubles
C                               8 => can't start
C   Commons: /INPARM/ all input adverbs in order given by INPUTS
C                     file
C            /MAPHDR/ output file catalog header
C-----------------------------------------------------------------------
      INTEGER   IRET
      CHARACTER PRGN*6
C
      CHARACTER STAT*4, MTYPE*2
      INTEGER   IERR, IROUND, I, IOFF
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'MARSP.INC'
      INCLUDE 'INCS:DCAT.INC'
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      JBUFSZ = 2 * MABFSS
      IRET = 0
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
C                                       Get input parameters.
      NPARM = 45
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAME1, SCRTCH, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         IRET = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (IRET, BUFF1, IERR)
      IF (IRET.NE.0) GO TO 999
      IRET = 5
C                                       Hollerith -> char.
      CALL H2CHR (12, 1, XNAME1, NAMEIN(1))
      CALL H2CHR (12, 1, XNAME2, NAMEIN(2))
      CALL H2CHR (6, 1, XCLAS1, CLAIN(1))
      CALL H2CHR (6, 1, XCLAS2, CLAIN(2))
C                                       Crunch input parameters.
      SEQ(1) = IROUND (XSEQ1)
      SEQ(2) = IROUND (XSEQ2)
      DISK(1) = IROUND (XDISK1)
      DISK(2) = IROUND (XDISK2)
      NBOXES = IROUND (XNBOX) + 1
      NBOXES = MAX (10, MIN (1801, NBOXES))
      XNBOX = NBOXES - 1
      IF (XPIXR(1).GE.XPIXR(2)) THEN
         XPIXR(1) = -90.
         XPIXR(2) = 90.
         END IF
      CALL FILL (3, 0, NPIX)
C                                       Create new file.
C                                       Get CATBLK from old file.
      DO 20 I = 1,2
         OLDCNO(I) = 1
         MTYPE = 'MA'
         CALL CATDIR ('SRCH', DISK(I), OLDCNO(I), NAMEIN(I), CLAIN(I),
     *      SEQ(I), MTYPE, NLUSER, STAT, SCRTCH, IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1030) IERR, NAMEIN(I), CLAIN(I), SEQ(I),
     *         DISK(I), NLUSER
            GO TO 990
            END IF
C                                       Read CATBLK and mark 'READ'.
         STAT = 'READ'
         IF ((I.EQ.1) .AND. (XDOTV.LE.0.0) .AND. (DOPLOT.GT.0.0))
     *      STAT = 'WRIT'
         CALL CATIO ('READ', DISK(I), OLDCNO(I), CATBLK, STAT, SCRTCH,
     *      IERR)
         IF (IERR.NE.0) THEN
            WRITE (MSGTXT,1040) IERR
            GO TO 990
            END IF
         NCFILE = NCFILE + 1
         FVOL(NCFILE) = DISK(I)
         FCNO(NCFILE) = OLDCNO(I)
         FRW(NCFILE) = 0
         IF (STAT.EQ.'WRIT') FRW(NCFILE) = 1
C                                       Copy old CATBLK to new.
         IF (I.EQ.1) CALL COPY (256, CATBLK, CATOLD)
 20      CONTINUE
C                                       is it Q and U
      CALL AXEFND (6, 'STOKES', CATBLK(KIDIM), CATH(KHCTP), IOFF, IERR)
      IF (IERR.EQ.0) THEN
         ISQU = ABS (CATD(KDCRV+IOFF)-3.0D0).LT.0.1
      ELSE
         MSGTXT = 'NO STOKES AXIS!  ASSUMING POLI AND POLA'
         CALL MSGWRT (8)
         END IF
      CALL WINDOW (CATBLK(KIDIM), CATBLK(KINAX), BLC, TRC, IERR)
      IF (IERR.EQ.0) IRET = 0
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MARSPI: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I3,' DISK=',
     *   I3,' USID=',I5)
 1040 FORMAT ('ERROR',I3,' COPYING CATBLK ')
      END
      SUBROUTINE MARSPD (NX, NY, POLI, POLA, IRET)
C-----------------------------------------------------------------------
C   MARSPD reads in 2 images and analyzes them
C   Input:
C      NX     I      X dimension (full)
C      NY     I      Y dimension
C   Output:
C      POLI   R(*)   POLI image
C      POLA   R(*)   POLA image
C      IRET   I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   NX, NY, IRET
      REAL      POLA(NX,*), POLI(NX,*)
C
      CHARACTER IFILE*48
      INTEGER   LUNI, WINI(4), I, IY, BOI, IPOS(7), BOTEMP, IBIND, INDI,
     *   IBLC(2), ITRC(2)
      REAL      OLD4(256)
      DOUBLE PRECISION OLD8(128)
      LOGICAL   T, F
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'MARSP.INC'
      INCLUDE 'INCS:DCAT.INC'
      EQUIVALENCE (CATOLD, OLD4, OLD8)
      DATA LUNI /16/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       read in two images
      DO 50 I = 1,2
C                                       Open and init for read
         CALL ZPHFIL ('MA', DISK(I), OLDCNO(I), 1, IFILE, IRET)
         CALL ZOPEN (LUNI, INDI, DISK(I), IFILE, T, F, T, IRET)
         IF (IRET.GT.0) THEN
            WRITE (MSGTXT,1000) IRET, 'OPEN INPUT FILE', I
            GO TO 990
            END IF
C                                       Setup for I/O
         WINI(1) = 1
         WINI(2) = 1
         WINI(3) = NX
         WINI(4) = NY
C                                       Loop
         IPOS(7) = BLC(7) + 0.1
         IPOS(6) = BLC(6) + 0.1
         IPOS(5) = BLC(5) + 0.1
         IPOS(4) = BLC(4) + 0.1
         IPOS(3) = BLC(3) + 0.1
C                                       Init. files, first input.
         CALL COMOFF (CATOLD(KIDIM), CATOLD(KINAX), IPOS(3), BOTEMP,
     *      IRET)
         BOI = BOTEMP + 1
         CALL MINIT ('READ', LUNI, INDI, NX, NY, WINI, BUFF1, JBUFSZ,
     *      BOI, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'INIT READ INPUT', I
            GO TO 990
            END IF
         DO 20 IY = 1,NY
C                                       Read.
            CALL MDISK ('READ', LUNI, INDI, BUFF1, IBIND, IRET)
            IF (IRET.NE.0) THEN
               WRITE (MSGTXT,1000) IRET, 'READ INPUT IMAGE', I
               GO TO 990
               END IF
C                                       save
            IF (I.EQ.1) THEN
               CALL RCOPY (NX, BUFF1(IBIND), POLI(1,IY))
            ELSE
               CALL RCOPY (NX, BUFF1(IBIND), POLA(1,IY))
               END IF
 20         CONTINUE
         CALL ZCLOSE (LUNI, INDI, IRET)
 50      CONTINUE
      IF (ISQU) THEN
         CALL POLFND (NX, NY, POLI, POLA, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1100) IRET, 'CONVERTING Q AND U'
            GO TO 990
            END IF
         END IF
C                                       window
      IBLC(1) = BLC(1) + 0.1
      IBLC(2) = BLC(2) + 0.1
      ITRC(1) = TRC(1) + 0.1
      ITRC(2) = TRC(2) + 0.1
C                                       default cutoff
      IF (CPARM(1).LE.0.0) THEN
         CALL FNDRMS (NX, NY, POLI, CPARM(1), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1100) IRET, 'FINDING RMS FOR CPARM(1)'
            GO TO 990
            END IF
         CPARM(1) = 3.0 * CPARM(1)
         END IF
      IF ((CPARM(2).LT.IBLC(1)) .OR. (CPARM(2).GT.ITRC(1)) .OR.
     *   (CPARM(3).LT.IBLC(2)) .OR. (CPARM(3).GT.ITRC(2))) THEN
         CALL FNDCEN (NX, NY, IBLC, ITRC, POLI, CPARM(2), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1100) IRET, 'FINDING CENTROID'
            GO TO 990
            END IF
         END IF
      CPARM(4) = MAX (0.0, CPARM(4))
      IF (CPARM(5).LE.CPARM(4)) CPARM(5) = 100000.

C                                       tell adverbs
      WRITE (MSGTXT,1110) CPARM(1), CPARM(2), CPARM(3), CPARM(4)
      CALL MSGWRT (5)
C                                       do it
      CALL FNDANS (NX, NY, IBLC, ITRC, POLI, POLA, CPARM, DOPLOT,
     *   NBOXES, XPIXR, HISTO, NPIX, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1100) IRET, 'FINDING ANSWER'
         GO TO 990
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MARSPD: ERROR',I3,' ON ',A,' FILE',I2)
 1100 FORMAT ('MARSPD: ERROR',I3,' ON ',A)
 1110 FORMAT ('Using CPARM=',F10.6,3F9.3)
      END
      SUBROUTINE POLFND (NX, NY, POLIQ, POLAU, IRET)
C-----------------------------------------------------------------------
C   Inputs
C      NX      I      X dimension
C      NY      I      Y dimension
C   In/out:
C      POLIQ   R(*)   Image: in Q out POLA
C      POLAU   R(*)   Image: in U out POLi
C   Outputs
C      IRET    I      > 0 if fails
C-----------------------------------------------------------------------
      INTEGER   NX, NY, IRET
      REAL      POLIQ(NX,*), POLAU(NX,*)
C
      INTEGER   IX, IY
      REAL      AMP
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      DO 30 IY = 1,NY
         DO 20 IX = 1,NX
            IF ((POLIQ(IX,IY).EQ.FBLANK) .OR. (POLAU(IX,IY).EQ.FBLANK))
     *         THEN
               POLIQ(IX,IY) = FBLANK
               POLAU(IX,IY) = FBLANK
            ELSE IF ((POLIQ(IX,IY).EQ.0.0) .AND. (POLAU(IX,IY).EQ.0.0))
     *         THEN
               POLIQ(IX,IY) = FBLANK
               POLAU(IX,IY) = FBLANK
            ELSE
               AMP = SQRT (POLIQ(IX,IY)**2 + POLAU(IX,IY)**2)
               POLAU(IX,IY) = ATAN2 (POLAU(IX,IY), POLIQ(IX,IY)) *
     *            RAD2DG / 2.0
               POLIQ(IX,IY) = AMP
               END IF
 20         CONTINUE
 30      CONTINUE
      IRET = 0
C
 999  RETURN
      END
      SUBROUTINE FNDRMS (NX, NY, IMAGE, RMS, IRET)
C-----------------------------------------------------------------------
C   Inputs
C      NX      I      X dimension
C      NY      I      Y dimension
C      IMAGE   R(*)   Image
C   Outputs
C      RMS     R      RMS
C      IRET    I      > 0 if fails
C-----------------------------------------------------------------------
      INTEGER   NX, NY, IRET
      REAL      IMAGE(NX,*), RMS
C
      INTEGER   IX, IY, NPASS, SN
      DOUBLE PRECISION RSP, RSM, SS, SQ, RM, RS, T
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      RSP = 1.D10
      RSM = -1.D10
      IRET = 0
      DO 50 NPASS = 1,7
         SS = 0.0D0
         SQ = 0.0D0
         SN = 0
         DO 20 IY = 1,NY
            DO 10 IX = 1,NX
               IF (IMAGE(IX,IY).NE.FBLANK) THEN
                  T = IMAGE(IX,IY)
                  IF ((T.LT.RSP) .AND. (T.GT.RSM)) THEN
                     SS = SS + T
                     SQ = SQ + T * T
                     SN = SN + 1
                     END IF
                  END IF
 10            CONTINUE
 20         CONTINUE
         IF (SN.LE.0) THEN
            RSP = RSP + 3.0D0 * RS
            RSM = RSM - 3.0D0 * RS
         ELSE
            RM = SS / SN
            SQ = SQ / SN
            RS = SQ - RM * RM
            RS = SQRT (MAX (0.0D0, RS))
            RS = MAX (RS, 0.001D0*RM)
            RSP = RM + 3.0D0 * RS
            RSM = RM - 3.0D0 * RS
            END IF
 50      CONTINUE
      IF (SN.LE.0) THEN
         IRET = 1
         RMS = 0.0
      ELSE
         IRET = 0
         RMS = RS
         END IF
C
 999  RETURN
      END
      SUBROUTINE FNDCEN (NX, NY, IBLC, ITRC, IMAGE, CENT, IRET)
C-----------------------------------------------------------------------
C   Inputs
C      NX      I      X dimension
C      NY      I      Y dimension
C      IBLC    I(2)   blc of computation
C      ITRC    I(2)   trc of computation
C      IMAGE   R(*)   Image
C   Outputs
C      CENT    R(2)   Centroid X,Y
C      IRET    I      > 0 if fails
C-----------------------------------------------------------------------
      INTEGER   NX, NY, IBLC(2), ITRC(2), IRET
      REAL      IMAGE(NX,*), CENT(2)
C
      INTEGER   IX, IY
      DOUBLE PRECISION XCEN, YCEN, TSUM, T
      INCLUDE 'INCS:DDCH.INC'
C-----------------------------------------------------------------------
      IRET = 0
      XCEN = 0.0D0
      YCEN = 0.0D0
      TSUM = 0.0D0
      DO 20 IY = IBLC(2),ITRC(2)
         DO 10 IX = IBLC(1),ITRC(1)
            IF (IMAGE(IX,IY).NE.FBLANK) THEN
               T = IMAGE(IX,IY)
               XCEN = XCEN + T * IX
               YCEN = YCEN + T * IY
               TSUM = TSUM + T
               END IF
 10         CONTINUE
 20      CONTINUE
C                                       answer
      IF (TSUM.LE.0.0D0) THEN
         IRET = 2
      ELSE
         CENT(1) = XCEN / TSUM
         CENT(2) = YCEN / TSUM
         END IF
C
 999  RETURN
      END
      SUBROUTINE FNDANS (NX, NY, IBLC, ITRC, POLI, POLA, CPARM, DOPLOT,
     *   NBOXES, XPIXR, HISTO, NPIX, IRET)
C-----------------------------------------------------------------------
C   Does computation, prints answer
C   Inputs:
C      NX       I      Number X pixels
C      NY       I      Number Y pixels
C      IBLC     I(2)   BLC to examine
C      ITRC     I(2)   TRC to examine
C      POLI     R(*)   Polarization intensity image
C      POLA     R(*)   Polarization angle image
C      CPARM    R(5)   (1) POLI cutoff, (2,3) X,Y center pixel
C                      (4,5) inner, outer radisu in pixels
C      DOPLOT   R      > 1.5 sum weights, else count
C      XPIXR    R(2)   plot range
C   Output
C      HISTO    R(*)   histogram (0.5 degree cells
C      CPARM    R(2)   (9,10) mean, rms
C      NPIX     i(3)   # below, #in, #above
C      IRET     I      error code: 0 okay
C-----------------------------------------------------------------------
      INTEGER   NX, NY, IBLC(2), ITRC(2), NBOXES, NPIX(3), IRET
      REAL      POLI(NX,*), POLA(NX,*), CPARM(10), DOPLOT, XPIXR(2),
     *   HISTO(*)
C
      INTEGER   IX, IY, SN, DROUND, IA
      DOUBLE PRECISION SS, SST, SQ, SQT, ST, T, X, Y, ANG, PA, DIF,
     *   AREA, RAD, OFFS, A, SCAL
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      CALL RFILL (1801, 0.0, HISTO)
      SS = 0.0D0
      SQ = 0.0D0
      ST = 0.0D0
      SST = 0.0D0
      SQT = 0.0D0
      SN = 0
      SCAL = (NBOXES-1.0) / (XPIXR(2) - XPIXR(1))
      OFFS = 0.0D0
      DO 100 IY = IBLC(2),ITRC(2)
         DO 90 IX = IBLC(1),ITRC(1)
            IF ((POLI(IX,IY).NE.FBLANK) .AND. (POLA(IX,IY).NE.FBLANK))
     *         THEN
               IF (POLI(IX,IY).GT.CPARM(1)) THEN
                  X = CPARM(2) - IX
                  Y = IY - CPARM(3)
                  RAD = SQRT (X*X + Y*Y)
                  IF ((RAD.GT.CPARM(4)) .AND. (RAD.LT.CPARM(5))) THEN
                     ANG = RAD2DG * ATAN2 (X, Y)
                     IF (ANG.LT.-180.0D0) ANG = ANG + 360.0D0
                     IF (ANG.GT.180.0D0) ANG = ANG - 360.0D0
                     IF (ANG.LT.-90.0D0) ANG = ANG + 180.0D0
                     IF (ANG.GT.90.0D0) ANG = ANG - 180.0D0
                     PA = POLA(IX,IY) + OFFS
                     DIF = PA - ANG
                     IF (DIF.GT.90.0) DIF = DIF - 180.0
                     IF (DIF.LT.-90.0) DIF = DIF + 180.0
                     A = (DIF -XPIXR(1)) * SCAL + 1.0D0
                     IA = DROUND (A)
                     IF (IA.LT.1) THEN
                        NPIX(1) = NPIX(1) + 1
                     ELSE IF (IA.GT.NBOXES) THEN
                        NPIX(3) = NPIX(3) + 1
                     ELSE IF (DOPLOT.GT.1.5) THEN
                        NPIX(2) = NPIX(2) + 1
                        HISTO(IA) = HISTO(IA) + T
                     ELSE
                        NPIX(2) = NPIX(2) + 1
                        HISTO(IA) = HISTO(IA) + 1.0
                        END IF
                     T = POLI(IX,IY)
                     SS = SS + DIF
                     SQ = SQ + DIF * DIF
                     SN = SN + 1
                     SST = SST + T * DIF
                     SQT = SQT + T * DIF * DIF
                     ST = ST + T
                     END IF
                  END IF
               END IF
 90         CONTINUE
 100     CONTINUE
C                                       answer
      IF (SN.LE.0) THEN
         MSGTXT = 'NO POINTS FOUND'
         CALL MSGWRT (8)
         IRET = 10
      ELSE
         IRET = 0
         SST = SST / ST
         SQT = SQT / ST - SST * SST
         SQT = SQRT (MAX (0.0D0, SQT))
         MSGTXT = 'Observed angle minus radial angle:'
         CALL MSGWRT (5)
         WRITE (MSGTXT,1100) 'Weighted', SST, SQT, SN
         CALL MSGWRT (5)
         AREA = 1.1331 * CATR(KRBMJ) * CATR(KRBMN) / (CATR(KRCIC) *
     *      CATR(KRCIC+1))
         AREA = SN / ABS (AREA)
         CPARM(10) = SQT
         SQT = SQT / SQRT (AREA)
         WRITE (MSGTXT,1110) 'Weighted', SST, SQT, AREA
         CALL MSGWRT (5)
         CPARM(9) = SST
         SS = SS / SN
         SQ = SQ / SN - SS * SS
         SQ = SQRT (MAX (0.0D0, SQ))
         WRITE (MSGTXT,1100) 'NoWeight', SS, SQ, SN
         CALL MSGWRT (5)
         SQ = SQ / SQRT (AREA)
         WRITE (MSGTXT,1110) 'NoWeight', SS, SQ, AREA
         CALL MSGWRT (5)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1100 FORMAT (A,' angl diff',F8.2,' +-',F8.2,' (rms ) deg',I9,
     *   ' pixels')
 1110 FORMAT (A,' mean diff',F8.2,' +-',F8.2,' (p.e.) deg',F9.2,
     *   ' beams')
      END
      SUBROUTINE MARSPL (IRET)
C-----------------------------------------------------------------------
C   Makes a histogram plot
C   Outputs
C     IRET   I   Error code: > 0 error
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'MARSP.INC'
      INTEGER   I, ILO, IHI, PVER, PLBUFF(256), TVCHN, GRCHN, TVCORN(2),
     *   PLUN, PIND, ID(3), IT(3), NCHAR, IDEPTH(5), LABEL, JTRIM, IC
      LOGICAL   DOTV
      CHARACTER FUNCTY*4, PNAME*48, CHT8*8, STRING*80, ADATE*12, NS*18,
     *   ATIME*8
      REAL      XRANGE(2), YRANGE(2), X, Y, DX, DY, CATOR(256), XSCALE,
     *   YSCALE, XBLC(2), XTRC(2), CH(4), XYRATO, IMAX
      DOUBLE PRECISION CATOD(128), XX
      HOLLERITH CATOH(256)
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DLOC.INC'
      INCLUDE 'INCS:DTVC.INC'
      EQUIVALENCE (CATOLD, CATOH, CATOR, CATOD)
      DATA TVCHN, TVCORN /3*0/
      DATA PLUN, IDEPTH, LABEL /23, 5*1, 3/
C-----------------------------------------------------------------------
      GRCHN = XGRCH
C                                       find range, values
      ILO = 0
      IHI = 0
      IMAX = 0
      DO 20 I = 1,1801
         IF (HISTO(I).GT.0.0) THEN
            IF (ILO.LE.0) ILO = I
            IHI = I
            IMAX = MAX (IMAX, HISTO(I))
            END IF
 20      CONTINUE
C                                       set ranges
      CALL H2CHR (4, 1, XFUNC, FUNCTY)
      IF (DOPLOT.GT.1.5) FUNCTY = ' '
      IF (FUNCTY.EQ.'LG') THEN
         YRANGE(1) = LOG10 (0.5)
         YRANGE(2) = LOG10 (IMAX+0.0)
      ELSE
         YRANGE(1) = 0.0
         YRANGE(2) = IMAX
         END IF
      ILO = MAX (1, ILO-1)
      IHI = MIN (NBOXES, IHI+1)
      IC = (NBOXES-1) / 2 + 1
      XRANGE(1) = (ILO-1) * (XPIXR(2)-XPIXR(1)) / (NBOXES-1.) + XPIXR(1)
      XRANGE(2) = (IHI-1) * (XPIXR(2)-XPIXR(1)) / (NBOXES-1.) + XPIXR(1)
      DOTV = XDOTV.GT.0.0
C                                       not doing METSCA
C     CALL GTICNT (3, YRANGE, I)
      I = LOG10 (YRANGE(2)) + 1.0
      CH(1) = I + 4.0
      CH(2) = 2.0 + 3 * 1.333
      CH(3) = 0.5
      CH(4) = 2.0 + 2 * 1.333
C                                       Add plot file to CATBLK
      PVER = 0
      IF (.NOT.DOTV) THEN
         CALL MADDEX ('PL', DISK(1), OLDCNO(1), CATOLD, PLBUFF, .TRUE.,
     *      'WRIT', PVER, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'CREATING PLOT FILE'
            GO TO 990
         END IF
      END IF
C                                       Open the plot file
      CALL ZPHFIL ('PL', DISK(1), OLDCNO(1), PVER, PNAME, IRET)
      CALL GINIT (DISK(1), OLDCNO(1), PNAME, 0, 79, NPARM, XNAME1, DOTV,
     *   TVCHN, GRCHN, TVCORN, CATOLD, PLBUFF, PLUN, PIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'INIT THE PLOT FILE'
         GO TO 990
         END IF
C                                       Set XBLC, XTRC, XYRATO.
      XBLC(1) = -1.0
      XBLC(2) = -1.0
      XTRC(1) = 102.0
      XTRC(2) = 102.0
C                                       Set coordinate common
      LOCNUM = 1
      RPVAL(1,LOCNUM) = XRANGE(1)
      RPVAL(2,LOCNUM) = YRANGE(1)
      RPLOC(1,LOCNUM) = 1.0
      RPLOC(2,LOCNUM) = 1.0
      AXINC(1,LOCNUM) = (XRANGE(2) - XRANGE(1)) / 99.0
      AXINC(2,LOCNUM) = (YRANGE(2) - YRANGE(1)) / 99.0
      ROT(LOCNUM) = 0.0
      NCHLAB(1,LOCNUM) = 0
      NCHLAB(2,LOCNUM) = 0
      LABTYP(LOCNUM) = 0
      CORTYP(LOCNUM) = 0
      AXTYP(LOCNUM) = 4
      AXFUNC(1,LOCNUM) = 0
      AXFUNC(2,LOCNUM) = 0
      NCHLAB(1,LOCNUM) = 0
      NCHLAB(2,LOCNUM) = 0
      CTYP(1,LOCNUM) = 'Degrees'
      IF (FUNCTY.EQ.'LG') THEN
         CTYP(2,LOCNUM) = 'LOG10 (counts)'
      ELSE IF (DOPLOT.GT.1.5) THEN
         CTYP(2,LOCNUM) = 'Sum brightness'
      ELSE
         CTYP(2,LOCNUM) = 'Counts'
         END IF
      CPREF(1,LOCNUM) = ' '
      CPREF(2,LOCNUM) = ' '
      IF (DOTV) THEN
         DX = WINDTV(3) - WINDTV(1) + 1 - CSIZTV(1) * (CH(1) + CH(3))
         DY = WINDTV(4) - WINDTV(2) + 1 - CSIZTV(2) * (CH(2) + CH(4))
         XYRATO = 1.0
         IF (DY.GT.0.0) XYRATO = DX / DY
      ELSE
         XYRATO = 1.0
         END IF
C                                       Initialize for line drawing
      CALL GINITL (XBLC, XTRC, XYRATO, CH, IDEPTH, PLBUFF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'INIT FOR LINE DRAWING'
         GO TO 990
         END IF
      CALL GLTYPE (1, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
C                                       Draw borders.
      CALL GPOS (XBLC(1), XBLC(2), PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL GVEC (XTRC(1), XBLC(2), PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL GVEC (XTRC(1), XTRC(2), PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL GVEC (XBLC(1), XTRC(2), PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL GVEC (XBLC(1), XBLC(2), PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
C                                       Calculate range and scales.
      XSCALE = 99.0 / (XRANGE(2) - XRANGE(1))
      YSCALE = 99.0 / (YRANGE(2) - YRANGE(1))
C                                       Labeling: source, freq, etc
      DX = 0.0
      DY = 0.5
      CALL H2CHR (8, 1, CATOH(KHOBJ), CHT8)
      XX = (CATOD(KDCRV+2) + CATOR(KRCIC+2) * (1.0 - CATOR(KRCRP+2)))
     *   / 1.0E6
      WRITE (STRING,1030) CHT8, XX
      NS = NAMEIN(1) // CLAIN(1)
      CALL NAMEST (NS, CATOLD(KIIMS), STRING(31:), I)
      CALL REFRMT (STRING, '_', NCHAR)
      CALL GPOS (XBLC(1), XTRC(2), PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL GCHAR (NCHAR, 0, DX, DY, STRING, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
C                                       Labeling: date
      CALL ZDATE (ID)
      CALL ZTIME (IT)
      CALL TIMDAT (IT, ID, ATIME, ADATE)
      WRITE (STRING,1031) PVER, ADATE, ATIME
      DY = DY + 1.333
      CALL REFRMT (STRING, '_', NCHAR)
      CALL GPOS (XBLC(1), XTRC(2), PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      CALL GCHAR (NCHAR, 0, DX, DY, STRING, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
C                                       what is plotted
      STRING = 'Observed position angle minus radial position angle'
      NCHAR = JTRIM (STRING)
      CALL GPOS (XBLC(1), XBLC(2), PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      DY = -1.5 - 2 * 1.333
      CALL GCHAR (NCHAR, 0, DX, DY, STRING, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      DY = DY - 1.333
      WRITE (STRING,1035) NPIX
      CALL REFRMT (STRING, '_', NCHAR)
      CALL GCHAR (NCHAR, 0, DX, DY, STRING, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
C                                       tick marks, labels, ...
      CALL CLAB1 (XBLC, XTRC, CH, LABEL, XYRATO, .FALSE., PLBUFF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'DRAWING TICK MARKS'
         GO TO 990
         END IF
C                                       Draw the fit
      CALL GLTYPE (3, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      X = (CPARM(9) - XRANGE(1)) * XSCALE
      Y = 0.0
      CALL GPOS (X, Y, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      Y = (YRANGE(2) - YRANGE(1)) * 0.1
      Y = Y * YSCALE
      CALL GVEC (X, Y, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      X = (CPARM(9) - CPARM(10) - XRANGE(1)) * XSCALE
      Y = 0.0
      CALL GPOS (X, Y, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      Y = (YRANGE(2) - YRANGE(1)) * 0.05
      Y = Y * YSCALE
      CALL GVEC (X, Y, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      X = (CPARM(9) + CPARM(10) - XRANGE(1)) * XSCALE
      Y = 0.0
      CALL GPOS (X, Y, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      Y = (YRANGE(2) - YRANGE(1)) * 0.05
      Y = Y * YSCALE
      CALL GVEC (X, Y, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
C                                       Draw the histogram
      CALL GLTYPE (2, PLBUFF, IRET)
      IF (IRET.NE.0) GO TO 980
      DO 40 I = ILO,IHI
         X = (I-1) * (XPIXR(2)-XPIXR(1)) / (NBOXES-1.) + XPIXR(1)
         X = (X - XRANGE(1)) * XSCALE
         IF (FUNCTY.EQ.'LG') THEN
            Y = HISTO (I)
            IF (Y.LE.0.0) THEN
               Y = LOG10 (0.5)
            ELSE
               Y = LOG10 (Y)
               END IF
         ELSE
            Y = HISTO(I)
            END IF
         Y = (Y - YRANGE(1)) * YSCALE
         IF (I.EQ.ILO) THEN
            CALL GPOS (X, Y, PLBUFF, IRET)
         ELSE
            CALL GVEC (X, Y, PLBUFF, IRET)
            END IF
         IF (IRET.NE.0) GO TO 980
 40      CONTINUE
      CALL GFINIS (PLBUFF, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'FINISHING THE PLOT'
         GO TO 990
         END IF
      WRITE (MSGTXT,1040) PVER
      IF (.NOT.DOTV) CALL MSGWRT (3)
      GO TO 999
C
 980  WRITE (MSGTXT,1000) IRET, 'PLOTTING LINES AND THE LIKE'
 990  CALL MSGWRT (8)
C                                       Destroy the PLot file on error.
      IF (PVER.GT.0) THEN
         WRITE (MSGTXT,1990) PVER
         CALL MSGWRT (8)
         CALL ZCLOSE (PLUN, PIND, I)
         CALL ZDESTR (DISK(1), PNAME, I)
         CALL DELEXT ('PL', DISK(1), OLDCNO(1), 'WRIT', CATOLD, SCRTCH,
     *      PVER, I)
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MARSPL ERROR:',I4,' ON ',A)
 1030 FORMAT (A8,1X,F10.3,' MHz')
 1031 FORMAT ('PLot file version',I4,'__created ',A12,A8)
 1035 FORMAT ('Pixels_below',I6,'_in_plot',I6,'_above',I6)
 1040 FORMAT ('Successful  plot version',I4,' created')
 1990 FORMAT ('DESTROY PLOT VERSION',I4,' DUE TO ERRORS')
      END
