LOCAL INCLUDE 'CMPLX.INC'
      INCLUDE 'INCS:PMAD.INC'
      INTEGER   CATI1(256), CATI2(256), CATI3(256), CATI4(256),
     *   CATB(256,4), CATIO(256,2)
      REAL      CATR1(256), CATR2(256), CATR3(256), CATR4(256)
      HOLLERITH CATH1(256), CATH2(256), CATH3(256), CATH4(256)
      DOUBLE PRECISION CATD1(128),  CATD2(128), CATD3(128), CATD4(128)
      REAL      IROW(MABFSS,4), FREQ1, FREQ2, LNFREQ, CPARM(10), XN(2),
     *   XX(2), CBMULT(4)
      CHARACTER NAMIN(4)*12, CLSIN(4)*6, NAMOUT(2)*12, CLSOUT(2)*6,
     *   ALGO*4
      LOGICAL   BFLAG, DOFILE(6), PLAIN
      INTEGER   IBLC(7,4), ITRC(7,4), NPI(7,4), NPO(7), FBL(2), ILUN(4),
     *   IIND(4), OLUN(2), OIND(2), ISSEQ(4), IDSEQ(2), NAX, NRDIM(4),
     *   CTYPE, IUSER, IPOINT, FCVOL(6), FCCNO(6), HISTDO, NAX2
      COMMON /CMPLCM/ CATB, CATIO, IROW, FREQ1, FREQ2, LNFREQ,
     *   CPARM, XN, XX, BFLAG, FBL, IBLC, ITRC,
     *   NPI, NPO, ILUN, IIND, OLUN, OIND, ISSEQ, IDSEQ, NAX, NRDIM,
     *   CTYPE, IUSER, IPOINT, DOFILE, PLAIN, FCVOL, FCCNO, HISTDO,
     *   CBMULT, NAX2
      COMMON /CMPLCH/ NAMIN, CLSIN, NAMOUT, CLSOUT, ALGO
      EQUIVALENCE (CATI1, CATR1, CATD1, CATH1, CATB(1,1))
      EQUIVALENCE (CATI2, CATR2, CATD2, CATH2, CATB(1,2))
      EQUIVALENCE (CATI3, CATR3, CATD3, CATH3, CATB(1,3))
      EQUIVALENCE (CATI4, CATR4, CATD4, CATH4, CATB(1,4))
      INCLUDE 'INCS:DCAT.INC'
LOCAL END
      PROGRAM CMPLX
C-----------------------------------------------------------------------
C! Combine two complex maps in various ways, producing an output map.
C# Map-util POLARIZATION ANALYSIS
C-----------------------------------------------------------------------
C;  Copyright (C) 2021-2022
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   CMPLX is a general program in which two complex input images are
C   combined on a pixel by pixel level to produce a third image.  It can
C   combine 2 n-dimensional images or one 2-dimensional image with each
C   plane of an n-dimensional image.
C   Inputs: (from AIPS)
C   INNAME......First image name.       Real/amplitude
C   INCLASS.....First image class.
C   INSEQ.......First image seq. #.     0 => highest.
C   INDISK......Disk drive # for the first image.  0 => any.
C   IN2NAME.....First image name.       Imag/phase
C   IN2CLASS....First image class.
C   IN2SEQ......First image seq. #.  0 => highest.
C   IN2DISK.....Disk drive # for the first image.  0 => any.
C   IN3NAME.....Second image name.       Real/amplitude
C   IN3CLASS....Second image class.
C   IN3SEQ......Second image seq. #.   0 => highest.
C   IN3DISK.....Disk # for second image.  0 => any.
C   IN4NAME.....Second image name.       Imag/phase
C   IN4CLASS....Second image class.
C   IN4SEQ......Second image seq. #.  0 => highest.
C   IN4DISK.....Disk # for noise image.  0 => any.
C   DOALIGN.....Controls how the four images are to be aligned (see HELP
C               DOALIGN).  True (>.1) means that the images must agree
C               in their coordinates, though not necessarily in the
C               reference pixel position.  Alignment is by coordinate
C               values (if DOALIGN > -0.1) or by offsets from the
C               reference pixel positions (if DOALIGN <= -0.1).  NOTE:
C               all real axes (>1 point) are aligned.  If DOALIGN = -2,
C               the headers are ignored and the images are aligned at
C               pixel (1,1,...).
C   OUTNAME.....Output image name.       Real/amplitude
C   OUTCLASS....Output image class.   Standard behavior with default =
C               either the output STOKES in string form or the OPCODE if
C               the output STOKES is the same as the first input image.
C   OUTSEQ......Output image seq. #.  0 => highest unique.
C   OUTDISK.....Output disk number. 0 => highest with space.
C   OUT2NAME....Output image name.       Imag/phase
C   OUT2CLAS....Output image class.   Standard behavior with default =
C               either the output STOKES in string form or the OPCODE if
C               the output STOKES is the same as the first input image.
C   OUT2SEQ.....Output image seq. #.  0 => highest unique.
C   OUT2DISK....Output disk number. 0 => highest with space.
C   BLC.........Bottom left corner of the 1st input image. The other
C               images are aligned by coordinates (see DOALIGN) on all
C               axes having > 1 point.  The other images may have fewer
C               real axes than the 1st.  The 4 windows must have the
C               same dimension on the first 2 axes, but the task will
C               select a smaller window than was specified if needed to
C               overlap the 4 images.
C   TRC.........Top right corner of input images. (See BLC.)
C   OPCODE......The combination algorithm specification: (A=APARM)
C   APARM.......Parameters needed for algorithm:
C      APARM(1), APARM(2), APARM(3), APARM(4) used as above.
C           APARM(1) = 0 => APARM(1) = 1.0
C           APARM(2) = 0 => APARM(2) = 1.0 (FOR 'SUM ')
C   DOHIST.....-2 => copy 1st HI only
C              -3 => no copy of HI
C-----------------------------------------------------------------------
      CHARACTER PRGNAM*6
      INTEGER   IRET, IERR, IWIN(4), ISWIN(4), NBY, NX, NY, IDEPTH(5),
     *   IBLKOF, NBYBUF, ISPOS(4), IDPOS(2), I3, I4, I5, I6, I7, I, IY
      INCLUDE 'CMPLX.INC'
      REAL      XBUFF(MABFSS,2)
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      DATA PRGNAM /'CMPLX'/
      DATA ISWIN /0,0,0,0/
C-----------------------------------------------------------------------
C                                        Initialize input maps
      IRET = 16
      CALL CMPLXI (PRGNAM, IERR)
      IF (IERR.NE.0) GO TO 995
      CALL CMPLXP (CTYPE, CPARM, IERR)
      IF (IERR.NE.0) GO TO 995
      CALL FILL (4, 1, ISPOS)
      CALL FILL (2, 1, IDPOS)
C                                        Do-loop limits: window
      NBY = 2
      NBYBUF = MABFSS * NBY
      NX = NPO(1)
      NY = NPO(2)
      DO 70 I7 = 1,NPO(7)
      DO 69 I6 = 1,NPO(6)
      DO 68 I5 = 1,NPO(5)
      DO 67 I4 = 1,NPO(4)
      DO 66 I3 = 1,NPO(3)
C                                        Initialize input maps
         DO 10 I = 1,4
            IF (DOFILE(I)) THEN
               CALL FILL (5, 1, IDEPTH(1))
               IF (NRDIM(I).GE.3) IDEPTH(1) = I3 - 1 + IBLC(3,I)
               IF (NRDIM(I).GE.4) IDEPTH(2) = I4 - 1 + IBLC(4,I)
               IF (NRDIM(I).GE.5) IDEPTH(3) = I5 - 1 + IBLC(5,I)
               IF (NRDIM(I).GE.6) IDEPTH(4) = I6 - 1 + IBLC(6,I)
               IF (NRDIM(I).GE.7) IDEPTH(5) = I7 - 1 + IBLC(7,I)
               CALL COMOFF (NAX, NPI(1,I), IDEPTH, IBLKOF, IERR)
               IF (IERR.NE.0) GO TO 995
               IBLKOF = IBLKOF + 1
               IWIN(1) = IBLC(1,I)
               IWIN(2) = IBLC(2,I)
               IWIN(3) = ITRC(1,I)
               IWIN(4) = ITRC(2,I)
               CALL MINIT ('READ', ILUN(I), IIND(I), NPI(1,I), NPI(2,I),
     *            IWIN, IROW(1,I), NBYBUF, IBLKOF, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1010) I, IERR
                  GO TO 980
                  END IF
               END IF
 10         CONTINUE
C                                        Initialize output file
         IDEPTH(1) = I3
         IDEPTH(2) = I4
         IDEPTH(3) = I5
         IDEPTH(4) = I6
         IDEPTH(5) = I7
         CALL COMOFF (NAX, NPO, IDEPTH, IBLKOF, IERR)
         IF (IERR.NE.0) GO TO 995
         IBLKOF = IBLKOF + 1
         ISWIN(1) = 1
         ISWIN(2) = 1
         ISWIN(3) = NPO(1)
         ISWIN(4) = NPO(2)
         DO 20 I = 1,2
            IF (DOFILE(I+4)) THEN
               CALL MINIT ('WRIT', OLUN(I), OIND(I), NX, NY, ISWIN,
     *            XBUFF(1,I), NBYBUF, IBLKOF, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1020) I, IERR
                  GO TO 980
                  END IF
               END IF
 20         CONTINUE
C                                        Loop over rows
         CALL FILL (4, 1, ISPOS)
         DO 50 IY = 1,NY
            DO 30 I = 1,4
               IF (DOFILE(I)) THEN
                  CALL MDISK ('READ', ILUN(I), IIND(I), IROW(1,I),
     *               ISPOS(I), IERR)
                  IF (IERR.NE.0) THEN
                     WRITE (MSGTXT,1030) IY, I, IERR
                     GO TO 980
                     END IF
                  END IF
 30            CONTINUE
            DO 40 I = 1,2
               IF (DOFILE(I+4)) THEN
                  CALL MDISK ('WRIT', OLUN(I), OIND(I), XBUFF(1,I),
     *               IDPOS(I), IERR)
                  IF (IERR.NE.0) THEN
                     WRITE (MSGTXT,1040) IY, I, IERR
                     GO TO 980
                     END IF
                  END IF
 40            CONTINUE
            CALL CMPLXN (NX, IROW(ISPOS(1),1), IROW(ISPOS(2),2),
     *         IROW(ISPOS(3),3), IROW(ISPOS(4),4), CTYPE, CPARM,
     *         XBUFF(IDPOS(1),1), XBUFF(IDPOS(2),2))
 50         CONTINUE
C                                        Write the last buffer
         DO 60 I = 1,2
            IF (DOFILE(I+4)) THEN
               CALL MDISK ('FINI', OLUN(I), OIND(I), XBUFF(1,I),
     *            IDPOS(I), IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1060) I, IERR
                  GO TO 980
                  END IF
               END IF
 60         CONTINUE
 66      CONTINUE
 67      CONTINUE
 68      CONTINUE
 69      CONTINUE
 70      CONTINUE
C                                        Create and write HI file
      CALL CMPLXH (IRET)
      GO TO 995
C                                        Error return
 980  CALL MSGWRT (7)
C
 995  CALL DIE (IRET, IROW)
C
 999  STOP
C-----------------------------------------------------------------------
 1010 FORMAT ('COULD NOT INITIALIZE INPUT FILE #',I2,'  IER=',I7)
 1020 FORMAT ('COULD NOT INITIALIZE OUTPUT FILE 3',I2,'  IER=',I7)
 1030 FORMAT ('COULD NOT READ LINE',I4,'  MAP #',I2,'  IER=',I7)
 1040 FORMAT ('COULD NOT WRITE LINE',I4,'  MAP #',I2,'  IER=',I7)
 1060 FORMAT ('COULD NOT WRITE LAST LINE, MAP #',I2,'.  IER=',I7)
      END
      SUBROUTINE CMPLXI (PRGNAM, IER)
C-----------------------------------------------------------------------
C   CMPLXI gets the inputs for CMPLX, opens and checks the input images,
C   creates the output image(s), and prepares parameters in common for
C   the later stages of CMPLX.
C   Inputs:
C      PRGNAM   C*6   Program name
C   Outputs:
C      IER      I     Error return: 0-->  Okay
C                        3-->  Cannot create and open output file
C                        2-->  Cannot open either input map
C                        1-->  Error in getting input parameters
C-----------------------------------------------------------------------
      CHARACTER PRGNAM*6
      INTEGER   IER
C
      CHARACTER IDCDEF*6, PHNAME*48, MTYPE*2, ALGOS(12)*4,
     *   STOKES*8, CHTMP*8, CHTMP1*8
      INTEGER   I, IERR, IRETCD, INPRMS, NB, NALGOS, INC, J, I1, IROUND,
     *   K
      LOGICAL   REDUCE, T
      REAL      EPS, X, AXV
      REAL      XSEQ1, XDSK1, XSEQ2, XDSK2, XSEQ3, XDSK3, XSEQ4, XDSK4,
     *   SEQOU1, DSKOU1, SEQOU2, DSKOU2, C(10), BLC(7), TRC(7), GRIDCR,
     *   DOHIST
      HOLLERITH XNAM1(3), XCLS1(2), XNAM2(3), XCLS2(2), XNAM3(3),
     *   XCLS3(2), XNAM4(3), XCLS4(2), XNAMO1(3), XCLSO1(2), XNAMO2(3),
     *   XCLSO2(2), XALGO
      DOUBLE PRECISION    DAXV
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'CMPLX.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DMSG.INC'
      COMMON /INPARM/ XNAM1, XCLS1, XSEQ1, XDSK1, XNAM2, XCLS2, XSEQ2,
     *   XDSK2, XNAM3, XCLS3, XSEQ3, XDSK3, XNAM4, XCLS4, XSEQ4, XDSK4,
     *   GRIDCR, XNAMO1, XCLSO1, SEQOU1, DSKOU1, XNAMO2, XCLSO2, SEQOU2,
     *   DSKOU2, BLC, TRC, XALGO, C, DOHIST
      DATA EPS /0.2/
      DATA T /.TRUE./
      DATA NALGOS, ALGOS /12, 'CONJ', 'SWAP', 'SUM', 'SUMC', 'SUMI',
     *   'ISUM' ,'DIV', 'DIVC', 'DIVI', 'MULT','MULC', 'MULI'/
      DATA STOKES /'STOKES  '/
C-----------------------------------------------------------------------
C                                        Initialize file and header I/O
      ILUN(1) = 17
      ILUN(2) = 18
      ILUN(3) = 19
      ILUN(4) = 20
      OLUN(1) = 21
      OLUN(2) = 22
C
      CALL ZDCHIN (T)
      CALL VHDRIN
      NSCR = 0
      NCFILE = 0
      IER = 0
C                                        Get inputs from AIPS
      INPRMS = 69
      CALL GTPARM (PRGNAM, INPRMS, RQUICK, XNAM1, IROW, IERR)
      IRETCD = IERR
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1010) IERR
         CALL MSGWRT (7)
         END IF
      IF (RQUICK) CALL RELPOP (IRETCD, IROW, IERR)
      IF (IRETCD.NE.0) GO TO 980
C                                       Change input OPCODE - char
      HISTDO = IROUND (DOHIST)
      CTYPE = 0
      CALL H2CHR (4, 1, XALGO, ALGO)
      DO 20 I = 1,NALGOS
         IF (ALGO.EQ.ALGOS(I)) CTYPE = I
 20      CONTINUE
      IF (CTYPE.LE.0) THEN
         WRITE (MSGTXT,1020) ALGO
         CALL MSGWRT (8)
         GO TO 980
         END IF
      CALL RCOPY (10, C, CPARM)
      IF (CTYPE.EQ.2) THEN
         IF (CPARM(8).GT.0.0) THEN
            CPARM(10) = -1.0
         ELSE
            CPARM(10) = 1.0
            END IF
         END IF
      DOFILE(1) = .TRUE.
      DOFILE(2) = .TRUE.
      DOFILE(3) = CTYPE.GT.2
      DOFILE(4) = CTYPE.GT.2
      DOFILE(5) = .TRUE.
      DOFILE(6) = .TRUE.
C                                        Transfer inputs into integer
C                                        variables
      FCVOL(1) = IROUND (XDSK1)
      FCVOL(2) = IROUND (XDSK2)
      FCVOL(3) = IROUND (XDSK3)
      FCVOL(4) = IROUND (XDSK4)
      ISSEQ(1) = IROUND (XSEQ1)
      ISSEQ(2) = IROUND (XSEQ2)
      ISSEQ(3) = IROUND (XSEQ3)
      ISSEQ(4) = IROUND (XSEQ4)
      FCVOL(5) = IROUND (DSKOU1)
      FCVOL(6) = IROUND (DSKOU1)
      IDSEQ(1) = IROUND (SEQOU1)
      IDSEQ(2) = IROUND (SEQOU2)
      IUSER = NLUSER
C                                       Hollerith -> Char.
      CALL H2CHR (12, 1, XNAM1(1), NAMIN(1))
      CALL H2CHR (6, 1, XCLS1(1), CLSIN(1))
      CALL H2CHR (12, 1, XNAM2(1), NAMIN(2))
      CALL H2CHR (6, 1, XCLS2(1), CLSIN(2))
      CALL H2CHR (12, 1, XNAM3(1), NAMIN(3))
      CALL H2CHR (6, 1, XCLS3(1), CLSIN(3))
      CALL H2CHR (12, 1, XNAM4(1), NAMIN(4))
      CALL H2CHR (6, 1, XCLS4(1), CLSIN(4))
      CALL H2CHR (12, 1, XNAMO1(1), NAMOUT(1))
      CALL H2CHR (6, 1, XCLSO1(1), CLSOUT(1))
      CALL H2CHR (12, 1, XNAMO2(1), NAMOUT(2))
      CALL H2CHR (6, 1, XCLSO2(1), CLSOUT(2))
C                                        Open both input maps
      MTYPE = 'MA'
      CALL RFILL (4, 0.0, CBMULT)
      DO 35 I = 1,4
         IF (DOFILE(I)) THEN
            CALL MAPOPN ('READ', FCVOL(I), NAMIN(I), CLSIN(I), ISSEQ(I),
     *         MTYPE, IUSER, ILUN(I), IIND(I), FCCNO(I), CATBLK,
     *         IROW(1,I), IERR)
            CALL COPY (256, CATBLK, CATB(1,I))
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1025) I,IERR
               CALL MSGWRT (7)
               GO TO 960
               END IF
            NCFILE = NCFILE + 1
            FRW(NCFILE) = 0
            FVOL(NCFILE) = FCVOL(I)
            FCNO(NCFILE) = FCCNO(I)
            NB = CATBLK(KIDIM)
            CALL FILL (KICTPN, 1, NPI(1,I))
            CALL COPY (NB, CATBLK(KINAX), NPI(1,I))
            NRDIM(I) = NB
            DO 30 J = 1,NB
               NPI(J,I) = MAX (1, NPI(J,I))
               IF (NPI(J,I).LE.1) NRDIM(I) = NRDIM(I) - 1
 30            CONTINUE
            CALL H2CHR (8, 1, CATH(KHBUN), CHTMP)
            CALL CHLTOU (8, CHTMP)
            IF (CHTMP.EQ.'JY/BEAM') CBMULT(I) = CATR(KRBMJ)*CATR(KRBMN)
            END IF
 35      CONTINUE
      IF (CBMULT(1).LE.0.0) THEN
         CALL RFILL (4, 1.0, CBMULT)
      ELSE
         DO 36 I = 2,4
            IF ((DOFILE(I)) .AND. (CBMULT(I).NE.1.0) .AND.
     *         (CBMULT(1).NE.1.0)) THEN
               CBMULT(I) = CBMULT(I) / CBMULT(1)
               IF (CBMULT(I).LE.0.0) CBMULT(I) = 1.0
               CBMULT(I) = 1.0 / CBMULT(I)
            ELSE
               CBMULT(I) = 1.0
               END IF
 36         CONTINUE
         CBMULT(1) = 1.0
         END IF
C                                        Set up some needed header vals
      REDUCE = .FALSE.
      NAX = CATI1(KIDIM)
      NAX2 = CATI2(KIDIM)
      CALL WINDOW (NAX, NPI(1,1), BLC, TRC, IERR)
      IF (IERR.NE.0) GO TO 960
      DO 40 I = 1,7
         IBLC(I,1) = BLC(I) + EPS
         ITRC(I,1) = TRC(I) + EPS
         NPO(I) = ITRC(I,1) - IBLC(I,1) + 1
 40      CONTINUE
C                                       Are input maps coincident?
C                                       Set 2nd map corners
      INC = 2
      DO 70 K = 2,4
         IF (DOFILE(K)) THEN
            CALL COPY (256, CATB(1,K), CATBLK)
            DO 65 I = 1,7
               J = I - 1
C                                       null axis
               IBLC(I,K) = 1
               ITRC(I,K) = 1
               IF (NPI(I,K).GT.1) THEN
                  AXV = CATR(KRCRP+J) - CATR1(KRCRP+J) + IBLC(I,1)
                  IF (GRIDCR.LT.-1.5) AXV = IBLC(I,1)
                  IF (GRIDCR.GT.-0.1) THEN
                     DAXV = CATD1(KDCRV+J) + (IBLC(I,1) -
     *                  CATR1(KRCRP+J)) * CATR1(KRCIC+J)
                     IF (CATR(KRCIC+J).EQ.0.0) GO TO 75
                     AXV = (DAXV - CATD(KDCRV+J)) / CATR(KRCIC+J) +
     *                  CATR(KRCRP+J)
                     END IF
                  IBLC(I,K) = IROUND (AXV)
                  IF ((GRIDCR.GE.0.1) .AND. (ABS(AXV-IBLC(I,K)).GT.EPS))
     *               GO TO 75
                  ITRC(I,K) = IBLC(I,K) + ITRC(I,1) - IBLC(I,1)
C                                       smaller subimage required?
                  IF (IBLC(I,K).LT.1) THEN
                     IBLC(I,1) = IBLC(I,1) + 1 - IBLC(I,K)
                     BLC(I) = IBLC(I,1)
                     IF (K.GT.2) IBLC(I,2) = IBLC(I,2) + 1 - IBLC(I,K)
                     IF (K.GT.3) IBLC(I,3) = IBLC(I,3) + 1 - IBLC(I,K)
                     REDUCE = .TRUE.
                     IBLC(I,K) = 1
                     END IF
                  IF (ITRC(I,K).GT.NPI(I,K)) THEN
                     ITRC(I,1) = ITRC(I,1) + NPI(I,K) - ITRC(I,K)
                     TRC(I) = ITRC(I,1)
                     IF (K.GT.2) ITRC(I,2) = ITRC(I,2) + NPI(I,K) -
     *                  ITRC(I,K)
                     IF (K.GT.3) ITRC(I,3) = ITRC(I,3) + NPI(I,K) -
     *                  ITRC(I,K)
                     REDUCE = .TRUE.
                     ITRC(I,K) = NPI(I,K)
                     END IF
                  IF (IBLC(I,1).GT.ITRC(I,1)) GO TO 75
                  NPO(I) = ITRC(I,1) - IBLC(I,1) + 1
C                                        Check coincidence
                  IF (GRIDCR.GE.0.1) THEN
                     IPOINT = KHCTP+J*INC
                     CALL H2CHR (8, 1, CATH(IPOINT), CHTMP)
                     CALL H2CHR (8, 1, CATH1(IPOINT), CHTMP1)
                     IF (CHTMP.NE.CHTMP1) GO TO 75
                     X = EPS * EPS * ABS(CATR1(KRCIC+J))
                     IF (ABS(CATR(KRCIC+J)-CATR1(KRCIC+J)).GT.X)
     *                  GO TO 75
                     IF (ABS(CATR(KRCRT+J)-CATR1(KRCRT+J)).GT.1.)
     *               GO TO 75
                     END IF
                  END IF
 65            CONTINUE
            END IF
 70      CONTINUE
      GO TO 80
C                                        Maps not coincident
 75   WRITE (MSGTXT,1075) I
      CALL MSGWRT (7)
      GO TO 960
C                                       Create output map
C                                       Get stokes value of input maps
C                                       Insert proper Stokes value
 80   MSGTXT = 'CMPLXI: input maps coincident on reduced subimage only'
      IF (REDUCE) CALL MSGWRT (6)
      XX(1) = -1.0E30
      XX(2) = -1.0E30
      XN(1) = 1.0E30
      XN(2) = 1.0E30
      BFLAG = .FALSE.
      CALL COPY (256, CATI1, CATBLK)
      INC = 2
C                                        Default out class
      IDCDEF = 'R ' // ALGO
      IF (CPARM(10).GT.0.0) IDCDEF = 'A ' // ALGO
      CALL MAKOUT (NAMIN(1), CLSIN(1), ISSEQ(1), IDCDEF, NAMOUT(1),
     *   CLSOUT(1), IDSEQ(1))
      CALL CHR2H (12, NAMOUT(1), KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLSOUT(1), KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = IDSEQ(1)
      CATBLK(KIIMU) = NLUSER
      CALL SUBHDR (BLC, TRC, 1.0, 1.0)
      CALL MCREAT (FCVOL(5), FCCNO(5), IROW, IERR)
      IDSEQ(1) = CATBLK(KIIMS)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1110) IERR
         CALL MSGWRT (8)
         GO TO 950
         END IF
      NCFILE = NCFILE + 1
      FRW(NCFILE) = 2
      FVOL(NCFILE) = FCVOL(5)
      FCNO(NCFILE) = FCCNO(5)
C                                       Copy header keywords from first
C                                       input.
      CALL KEYPCP (FCVOL(1), FCCNO(1), FCVOL(5), FCCNO(5), 0, ' ', IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1135) IERR
         CALL MSGWRT (7)
C                                       Let it slide.
         IERR = 0
         END IF
C                                        Open the output file
      CALL ZPHFIL ('MA', FCVOL(5), FCCNO(5), 1, PHNAME, IERR)
      CALL ZOPEN (OLUN(1), OIND(1), FCVOL(5), PHNAME, T, T, T, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1136) IERR
         CALL MSGWRT (7)
         GO TO 950
         END IF
      CALL COPY (256, CATBLK, CATIO(1,1))
C                                       imaginary/phase
      IDCDEF = 'I ' // ALGO
      IF (CPARM(10).GT.0.0) IDCDEF = 'P ' // ALGO
      CALL MAKOUT (NAMIN(2), CLSIN(2), ISSEQ(2), IDCDEF, NAMOUT(2),
     *   CLSOUT(2), IDSEQ(2))
      CALL CHR2H (12, NAMOUT(2), KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLSOUT(2), KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = IDSEQ(2)
      CATBLK(KIIMU) = NLUSER
      IF (CPARM(10).GT.0.0) CALL CHR2H (8, 'Degrees ', 1, CATH(KHBUN))
      CALL MCREAT (FCVOL(6), FCCNO(6), IROW, IERR)
      IDSEQ(2) = CATBLK(KIIMS)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1110) IERR
         CALL MSGWRT (8)
         GO TO 950
         END IF
      NCFILE = NCFILE + 1
      FRW(NCFILE) = 2
      FVOL(NCFILE) = FCVOL(6)
      FCNO(NCFILE) = FCCNO(6)
C                                       Copy header keywords from first
C                                       input.
      CALL KEYPCP (FCVOL(1), FCCNO(1), FCVOL(6), FCCNO(6), 0, ' ', IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1135) IERR
         CALL MSGWRT (7)
C                                       Let it slide.
         IERR = 0
         END IF
C                                        Open the output file
      CALL ZPHFIL ('MA', FCVOL(6), FCCNO(6), 1, PHNAME, IERR)
      CALL ZOPEN (OLUN(2), OIND(2), FCVOL(6), PHNAME, T, T, T, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1136) IERR
         CALL MSGWRT (7)
         GO TO 950
         END IF
      CALL COPY (256, CATBLK, CATIO(1,2))
      GO TO 999
C-----------------------------------------------------------------------
C                                        Error returns
C                                        Failed to create output file
 950  IER = IER + 1
C                                        Error in MAPOPN
 960  IER = IER + 1
C                                        Error in getting parameters
 980  IER = IER + 1
C
 999  RETURN
C-----------------------------------------------------------------------
 1010 FORMAT ('CMPLXI: COULD NOT GET PARMS.  IER=',I7)
 1020 FORMAT ('DO NOT RECOGNIZE OPCODE = ',A4)
 1025 FORMAT ('CMPLXI: COULD NOT OPEN MAP # ',I1,'  IER=',I7)
 1075 FORMAT ('CMPLXI: INPUT MAPS ARE NOT COINCIDENT ON AXIS',I2)
 1110 FORMAT ('CMPLXI: COULD NOT CREATE OUTPUT MAP.  IER=',I7)
 1135 FORMAT ('CMPLXI: ERROR ', I3,' COPYING KEYWORDS - CONTINUING')
 1136 FORMAT ('CMPLXI: COULD NOT OPEN OUTPUT MAP.  IER=',I7)
      END
      SUBROUTINE CMPLXP (COMB, C, IER)
C-----------------------------------------------------------------------
C   CMPLXP writes output describing the algorithm, prepares default
C   values and obtains necessary parameters for CMPLXN.
C   Inputs:
C      COMB     I        The algorithm type
C      C        R(*)     The algorithm parameters
C   Outputs:
C      IER      I        Error code: 0 --> okay
C                                    1 --> not okay
C      FREQ1    R        Frequency of first map
C      FREQ2    R        Frequency of second map
C      LNFREQ   R        Log(FREQ1/FREQ2)
C      FBLANK   R        Blanking value used in scratch file
C-----------------------------------------------------------------------
      INTEGER   COMB, IER
      REAL      C(*)

      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'CMPLX.INC'
C-----------------------------------------------------------------------
C                                       Initialize
      IER = 0
C                                       Conjugate
      IF (COMB.EQ.1) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         WRITE (MSGTXT,1010) C(1), C(2), C(3)
C                                       SWAP
      ELSE IF (COMB.EQ.2) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         WRITE (MSGTXT,1020) C(1), C(2), C(3)
C                                       Linear combination 'SUM '
      ELSE IF (COMB.EQ.3) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         IF (C(2).EQ.0.0) C(2) = 1.0
         WRITE (MSGTXT,1030) C(1), C(2), C(3), C(4)
C                                       Linear combination 'SUMC'
      ELSE IF (COMB.EQ.4) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         IF (C(2).EQ.0.0) C(2) = 1.0
         WRITE (MSGTXT,1040) C(1), C(2), C(3), C(4)
C                                       Linear combination 'SUMI'
      ELSE IF (COMB.EQ.5) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         IF (C(2).EQ.0.0) C(2) = 1.0
         WRITE (MSGTXT,1050) C(1), C(2), C(3), C(4)
C                                       Linear combination 'ISUM'
      ELSE IF (COMB.EQ.6) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         IF (C(2).EQ.0.0) C(2) = 1.0
         WRITE (MSGTXT,1060) C(1), C(2), C(3), C(4)
C                                       Division 'DIV '
      ELSE IF (COMB.EQ.7) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         WRITE (MSGTXT,1070) C(1), C(2), C(3)
C                                       division 'DIVC'
      ELSE IF (COMB.EQ.8) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         WRITE (MSGTXT,1080) C(1), C(2), C(3)
C                                       division 'DIVI'
      ELSE IF (COMB.EQ.9) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         WRITE (MSGTXT,1090) C(1), C(2), C(3)
C                                       Product 'MULT'
      ELSE IF (COMB.EQ.10) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         WRITE (MSGTXT,1100) C(1), C(2), C(3)
C                                       Product 'MULC'
      ELSE IF (COMB.EQ.11) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         WRITE (MSGTXT,1110) C(1), C(2), C(3)
C                                       Product 'MULI'
      ELSE IF (COMB.EQ.12) THEN
         IF (C(1).EQ.0.0) C(1) = 1.0
         WRITE (MSGTXT,1120) C(1), C(2), C(3)
         END IF
      CALL MSGWRT (2)
      GO TO 999
C
 999  RETURN
C-----------------------------------------------------------------------
 1010 FORMAT ('CONJ',F7.3,'*conj(M(1)) +',F7.3,' + i*',F7.3)
 1020 FORMAT ('SWAP',F7.3,'*M(1) +',F7.3,' + i*',F7.3)
 1030 FORMAT ('SUM ',F7.3,'*M(1) +',F7.3,'*M(2) +',F7.3,' + i*',F7.3)
 1040 FORMAT ('SUMC',F7.3,'*M(1) +',F7.3,'*conj(M(2)) +',F7.3,' + i*',
     *   F7.3)
 1050 FORMAT ('SUMI',F7.3,'*M(1) +',F7.3,'*i*M(2) +',F7.3,' + i*',F7.3)
 1060 FORMAT ('ISUM i*(',F7.3,'*M(1) +',F7.3,'*M(2)) +',F7.3,' + i*',
     *   F7.3)
 1070 FORMAT ('DIV ',F7.3,'*M(1) / M(2) +',F7.3,' + i*',F7.3)
 1080 FORMAT ('DIVC',F7.3,'*M(1) / conj(M(2)) +',F7.3,' + i*',F7.3)
 1090 FORMAT ('DIVI',F7.3,'*M(1) / (i*M(2)) +',F7.3,' + i*',F7.3)
 1100 FORMAT ('MULT',F7.3,'*M(1) * M(2) +',F7.3,' + i*',F7.3)
 1110 FORMAT ('MULC',F7.3,'*M(1) * conj(M(2)) +',F7.3,' + i*',F7.3)
 1120 FORMAT ('MULI',F7.3,'*M(1) * (i*M(2)) +',F7.3,' + i*',F7.3)
      END
      SUBROUTINE CMPLXN (NX, V1, V2, V3, V4, COMB, C, R1, R2)
C-----------------------------------------------------------------------
C   CMPLXN combines complex pixel rows V1/V2 and V3/V4 to form result
C   row R1/R2   The algorithm is specified by COMB and any parameters
C   are stored in the array C.
C   Inputs:
C      NX     I       Number of pixels in each vector.
C      V1     R(NX)   The pixel values of the input map 1
C      V2     R(NX)   The pixel values of the input map 2
C      COMB   I       The algorithm type: see Main pgm
C      C      R(20)   Up to 20 inputs parameters
C   Outputs:
C      R1     R(NX)   The result of the combination
C-----------------------------------------------------------------------
      INTEGER   NX, COMB
      REAL      V1(*), V2(*), V3(*), V4(*), R1(*), R2(*), C(*)
C
      INTEGER   I
      REAL      BRES, A, P, DEN
      LOGICAL   BLANK
      INCLUDE 'CMPLX.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
C                                       Value for blanked on output
      BRES = FBLANK
C                                       convert amp/phase
      IF (C(8).GT.0.0) THEN
         DO 10 I = 1,NX
            IF ((V1(I).NE.FBLANK) .AND. (V2(I).NE.FBLANK)) THEN
               A = V1(I)
               P = V2(I) * DG2RAD
               V1(I) = A * COS (P)
               V2(I) = A * SIN (P)
            ELSE
               V1(I) = FBLANK
               V2(I) = FBLANK
               END IF
 10         CONTINUE
         END IF
      IF ((COMB.GT.2) .AND. (C(9).GT.0.0)) THEN
         DO 20 I = 1,NX
            IF ((V3(I).NE.FBLANK) .AND. (V4(I).NE.FBLANK)) THEN
               A = V3(I)
               P = V4(I) * DG2RAD
               V3(I) = A * COS (P)
               V4(I) = A * SIN (P)
            ELSE
               V3(I) = FBLANK
               V4(I) = FBLANK
               END IF
 20         CONTINUE
         END IF
      IF (CBMULT(2).NE.1.0) THEN
         DO 30 I = 1,NX
            IF (V2(I).NE.FBLANK) V2(I) = CBMULT(2) * V2(I)
 30         CONTINUE
         END IF
      IF ((DOFILE(3)) .AND. (CBMULT(3).NE.1.0)) THEN
         DO 40 I = 1,NX
            IF (V3(I).NE.FBLANK) V3(I) = CBMULT(3) * V3(I)
 40         CONTINUE
         END IF
      IF ((DOFILE(4)) .AND. (CBMULT(4).NE.1.0)) THEN
         DO 50 I = 1,NX
            IF (V4(I).NE.FBLANK) V4(I) = CBMULT(4) * V3(I)
 50         CONTINUE
         END IF
C                                       CONJ
      IF (COMB.EQ.1) THEN
         DO 110 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = C(1) * V1(I) + C(2)
               R2(I) = -C(1) * V2(I) + C(3)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 110        CONTINUE
C                                       SWAP
      ELSE IF (COMB.EQ.2) THEN
         DO 120 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = C(1) * V1(I) + C(2)
               R2(I) = C(1) * V2(I) + C(3)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 120        CONTINUE
C                                       SUM
      ELSE IF (COMB.EQ.3) THEN
         DO 130 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = C(1) * V1(I) + C(2) * V3(I) + C(3)
               R2(I) = C(1) * V2(I) + C(2) * V4(I) + C(4)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 130        CONTINUE
C                                       SUMC
      ELSE IF (COMB.EQ.4) THEN
         DO 140 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = C(1) * V1(I) + C(2) * V3(I) + C(3)
               R2(I) = C(1) * V2(I) - C(2) * V4(I) + C(4)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 140        CONTINUE
C                                       SUMI
      ELSE IF (COMB.EQ.5) THEN
         DO 150 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = C(1) * V1(I) - C(2) * V4(I) + C(3)
               R2(I) = C(1) * V2(I) + C(2) * V3(I) + C(4)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 150        CONTINUE
C                                       ISUM
      ELSE IF (COMB.EQ.6) THEN
         DO 160 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = C(1) * V2(I) + C(2) * V4(I) + C(3)
               R1(I) = -(C(1) * V1(I) + C(2) * V3(I)) + C(4)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 160        CONTINUE
C                                       DIV
      ELSE IF (COMB.EQ.7) THEN
         DO 170 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            DEN = V3(I)*V3(I) + V4(I)*V4(I)
            IF ((.NOT.BLANK) .AND. (DEN.NE.0.0)) THEN
               R1(I) = C(1)/DEN * (V1(I)*V3(I) + V2(I)*V4(I)) + C(2)
               R2(I) = C(1)/DEN * (V2(I)*V3(I) - V1(I)*V4(I)) + C(3)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 170        CONTINUE
C                                       DIVC
      ELSE IF (COMB.EQ.8) THEN
         DO 180 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            DEN = V3(I)*V3(I) + V4(I)*V4(I)
            IF ((.NOT.BLANK) .AND. (DEN.NE.0.0)) THEN
               R1(I) = C(1)/DEN * (V1(I)*V3(I) - V2(I)*V4(I)) + C(2)
               R2(I) = C(1)/DEN * (V2(I)*V3(I) + V1(I)*V4(I)) + C(3)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 180        CONTINUE
C                                       DIVI
      ELSE IF (COMB.EQ.9) THEN
         DO 190 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            DEN = V3(I)*V3(I) + V4(I)*V4(I)
            IF ((.NOT.BLANK) .AND. (DEN.NE.0.0)) THEN
               R1(I) = C(1)/DEN * (V2(I)*V3(I) - V1(I)*V4(I)) + C(2)
               R2(I) = -C(1)/DEN * (V1(I)*V3(I) + V2(I)*V4(I)) + C(3)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 190        CONTINUE
C                                       MULT
      ELSE IF (COMB.EQ.10) THEN
         DO 200 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = C(1) * (V1(I)*V3(I) - V2(I)*V4(I)) + C(2)
               R2(I) = C(1) * (V2(I)*V3(I) + V1(I)*V4(I)) + C(3)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 200        CONTINUE
C                                       MULC
      ELSE IF (COMB.EQ.11) THEN
         DO 210 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = C(1) * (V1(I)*V3(I) + V2(I)*V4(I)) + C(2)
               R2(I) = C(1) * (V2(I)*V3(I) - V1(I)*V4(I)) + C(3)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 210        CONTINUE
C                                       MULI
      ELSE IF (COMB.EQ.12) THEN
         DO 220 I = 1,NX
            BLANK = (V1(I).EQ.FBLANK) .OR. (V2(I).EQ.FBLANK) .OR.
     *         (V3(I).EQ.FBLANK) .OR. (V4(I).EQ.FBLANK)
            IF (.NOT.BLANK) THEN
               R1(I) = -C(1) * (V1(I)*V4(I) + V2(I)*V3(I)) + C(2)
               R2(I) = C(1) * (V1(I)*V3(I) - V2(I)*V4(I)) + C(3)
            ELSE
               R1(I) = FBLANK
               R2(I) = FBLANK
               END IF
 220        CONTINUE
         END IF
C                                       to amp/phase
      IF (C(10).GT.0.0) THEN
         DO 250 I = 1,NX
            IF (R1(I).NE.FBLANK) THEN
               A = SQRT (R1(I)*R1(I) + R2(I)*R2(I))
               P = 0.0
               IF (A.GT.0.0) P = ATAN2 (R2(I), R1(I)) * RAD2DG
               R1(I) = A
               R2(I) = P
               END IF
 250        CONTINUE
         END IF
C                                       Common processing
      DO 910 I = 1,NX
C                                       Get max/min
         IF (R1(I).NE.FBLANK) THEN
            XX(1) = MAX (XX(1), R1(I))
            XN(1) = MIN (XN(1), R1(I))
            XX(2) = MAX (XX(2), R2(I))
            XN(2) = MIN (XN(2), R2(I))
         ELSE
            BFLAG = .TRUE.
            END IF
 910     CONTINUE
C
 999  RETURN
      END
      SUBROUTINE CMPLXH (IRET)
C-----------------------------------------------------------------------
C   CMPLXH creates and writes the HI file associated with task CMPLX.
C   Outputs:
C      IRET   I      > 0 => output all blanks
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      CHARACTER HILINE*72, WORD(12)*40, FTYPE(2,2)*4, NOTTYP*2
      INTEGER   NHISTF, IHDLUN, IHSLUN, I, IER, IERR, IBUFF1(256), J,
     *    IBUFF2(256), IPTR, ITEMP, NONOT, JTRIM, K
      LOGICAL   TRUE, FALSE
      INCLUDE 'INCS:DHIS.INC'
      INCLUDE 'CMPLX.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DHDR.INC'
      EQUIVALENCE (IBUFF1(1),IROW(1,1)),  (IBUFF2(1),IROW(257,1))
      DATA NHISTF, IHDLUN, IHSLUN /2,27,28/
      DATA WORD /'Conjugate', 'Real/imag <-> Amp/phase',
     *   'A(1)*M1 + A(2)*M2 + A(3) + i*A(4)',
     *   'A(1)*M1 + A(2)*conj(M2) + A(3) + i*A(4)',
     *   'A(1)*M1 + i*a(2)*M2 + A(3) + i*A(4)',
     *   'i*(A(1)*M1 + A(2)*M2) + A(3) + i*A(4)',
     *   'A(1)*(M1 / M2) + A(2) + i*A(3)',
     *   'A(1)*(M1 / conj(M2)) + A(2) + i*A(3)',
     *   'A(1)*(M1 / (i*M2)) + A(2) + i*A(3)',
     *   'A(1)*(M1 * M2) + A(2) + i*A(3)',
     *   'A(1)*(M1 * conj(M2)) + A(2) + i*A(3)',
     *   'A(1)*(M1 * (i*M2)) + A(2) + i*A(3)'/
      DATA TRUE, FALSE /.TRUE.,.FALSE./
      DATA FTYPE /'REAL','IMAG', 'AMP ','PHAS'/
      DATA NONOT, NOTTYP /1, 'CC'/
C-----------------------------------------------------------------------
C                                       Initialize HITAB
      CALL HIINIT (NHISTF)
      IRET = 0
      K = 1
      IF (CPARM(10).GT.0.0) K = 2
      DO 200 J = 2,1,-1
         IF (DOFILE(4+J)) THEN
C                                       Test validity of result
            IF (XX(J).LT.XN(J)) THEN
               WRITE (MSGTXT,1000) FTYPE(J,K)
               CALL MSGWRT (6)
               BFLAG = .TRUE.
            ELSE IF (XX(J).EQ.XN(J)) THEN
               WRITE (MSGTXT,1001) FTYPE(J,K), XX(J)
               CALL MSGWRT (6)
               END IF
C                                       Insert header parameters
            CALL COPY (256, CATIO(1,J), CATBLK)
            CATR(KRDMN) = XN(J)
            CATR(KRDMX) = XX(J)
C                                       Create and open new HI file
            CALL HICREA (IHDLUN, FCVOL(4+J), FCCNO(4+J), CATBLK, IBUFF2,
     *         IERR)
            IPTR = IBUFF2(3)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1010) FTYPE(J,K), IERR
               CALL MSGWRT (7)
               GO TO 200
               END IF
C                                       Copy both input HI files
            DO 50 I = 1,2
               IF (HISTDO.GE.-3+I) THEN
                  WRITE (HILINE,1020) I
                  CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
                  IF (IERR.NE.0) GO TO 190
                  ITEMP = HITAB(IPTR+2)
                  CALL HIOPEN (IHSLUN, FCVOL(I), FCCNO(I), IBUFF1, IERR)
                  IF (IERR.NE.0) GO TO 30
                  CALL HICOPY (IHSLUN, IBUFF1, IHDLUN, IBUFF2, IERR)
                  CALL HICLOS (IHSLUN, FALSE, IBUFF1, IER)
                  IF (IERR.EQ.0) GO TO 50
                     IF (IERR.GE.100) HITAB(IPTR+2) = ITEMP
 30                  WRITE (MSGTXT,1030) I, IERR
                     CALL MSGWRT (6)
                     WRITE (HILINE,1031)
                     CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
                     IF (IERR.NE.0) GO TO 190
               ELSE
                  WRITE (HILINE,1032) TSKNAM, I
                  CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
                  IF (IERR.NE.0) GO TO 190
                  END IF
 50            CONTINUE
            WRITE (HILINE,1050)
            CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
            WRITE (HILINE,1055) TSKNAM, RLSNAM
            CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
C                                       Add input parameters
            CALL HENCO1 (TSKNAM, NAMIN(1), CLSIN(1), ISSEQ(1), FCVOL(1),
     *         IHDLUN, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
            CALL HENCO2 (TSKNAM, NAMIN(2), CLSIN(2), ISSEQ(2), FCVOL(2),
     *         IHDLUN, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
            IF (CTYPE.GT.2) THEN
               CALL HENCO1 (TSKNAM, NAMIN(3), CLSIN(3), ISSEQ(3),
     *            FCVOL(3), IHDLUN, IBUFF2, IERR)
               IF (IERR.NE.0) GO TO 190
               CALL HENCO2 (TSKNAM, NAMIN(4), CLSIN(4), ISSEQ(4),
     *            FCVOL(4), IHDLUN, IBUFF2, IERR)
               IF (IERR.NE.0) GO TO 190
               END IF
            CALL HENCOO (TSKNAM, NAMOUT(J), CLSOUT(J), IDSEQ(J),
     *         FCVOL(4+J), IHDLUN, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
            WRITE (HILINE,1090) TSKNAM, IUSER
            CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
            I = JTRIM (WORD(CTYPE))
            WRITE (HILINE,1092) TSKNAM, ALGO, WORD(CTYPE)(:I)
            CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
            WRITE (HILINE,1094) TSKNAM, (IBLC(I,1), I = 1,7)
            CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
            WRITE (HILINE,1096) TSKNAM, (ITRC(I,1), I = 1,7)
            CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
            IF ((NRDIM(1).GT.2) .AND. (NRDIM(2).LE.2)) THEN
               WRITE (HILINE,1098) TSKNAM
               CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
               END IF
C                                       Parameters
            IF ((CTYPE.GT.2) .AND. (CTYPE.LE.5)) THEN
               WRITE (HILINE,1100) TSKNAM, (I, CPARM(I), I = 1,4)
            ELSE
               WRITE (HILINE,1101) TSKNAM, (I, CPARM(I), I = 1,3)
               END IF
            CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
C                                       blanking
            WRITE (HILINE,1110) TSKNAM
            CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
            IF (IERR.NE.0) GO TO 190
C                                       Clean beam scaling
            DO 60 I = 2,4
               IF ((CBMULT(I).NE.1.0) .AND. (DOFILE(I))) THEN
                  WRITE (HILINE,1112) TSKNAM, I, CBMULT(I)
                  CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
                  IF (IERR.NE.0) GO TO 190
                  MSGTXT = HILINE(7:)
                  CALL MSGWRT (3)
                  END IF
 60            CONTINUE
C                                       amp/phase
            IF (CPARM(8).GT.0.0) THEN
               HILINE = TSKNAM // '/ Input image 1 converted from'
     *            // ' amplitude/phase'
               CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
               IF (IERR.NE.0) GO TO 190
               END IF
            IF (CPARM(9).GT.0.0) THEN
               HILINE = TSKNAM // '/ Input image 2 converted from'
     *            // ' amplitude/phase'
               CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
               IF (IERR.NE.0) GO TO 190
               END IF
            IF (CPARM(10).GT.0.0) THEN
               HILINE = TSKNAM // '/ Output image converted to'
     *            // ' amplitude/phase'
               CALL HIADD (IHDLUN, HILINE, IBUFF2, IERR)
               IF (IERR.NE.0) GO TO 190
               END IF
C                                       Close HI file
 190        CALL HICLOS (IHDLUN, TRUE, IBUFF2, IER)
            WRITE (MSGTXT,1900) FTYPE(J,K)
            IF ((IER.NE.0) .OR. (IERR.NE.0)) WRITE (MSGTXT,1901)
     *         FTYPE(J,K), IERR, IER
            CALL MSGWRT (2)
C                                       copy tables
            CALL ALLTAB (NONOT, NOTTYP, 44, 45, FCVOL(1), FCVOL(4+J),
     *         FCCNO(1), FCCNO(4+J), CATBLK, IBUFF1, IBUFF2, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1905) FTYPE(J,K), IERR
               CALL MSGWRT (6)
               END IF
C                                       Close map file
            CALL MAPCLS ('INIT', FCVOL(4+J), FCCNO(4+J), OLUN(J),
     *         OIND(J), CATBLK, TRUE, IBUFF2, IERR)
            NCFILE = NCFILE - 1
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1910) FTYPE(J,K), IERR
               CALL MSGWRT (6)
               END IF
            END IF
 200     CONTINUE
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('OUTPUT ',A,' FILE COMPLETELY BLANKED',
     *   ' -- saving it anyway')
 1001 FORMAT ('Output ',A,' FILE constant at',1PE13.5,
     *   ' -- saving it anyway')
 1010 FORMAT ('CMPLXH: could not create HISTORY FOR ',A,' FILE.  IER=',
     *   I5)
 1020 FORMAT (31X,'/ History of input map', I2)
 1030 FORMAT ('WARNING COULD NOT OPEN/COPY INPUT HI FILE=',I2,
     *   '.  IER=',I7)
 1031 FORMAT (31X,'/ NO HISTORY TO BE FOUND')
 1032 FORMAT (A6,'/ No history copied from file',I2)
 1050 FORMAT (31X,'/ End of old histories')
 1055 FORMAT (A6,'RELEASE=''',A7,' ''')
 1090 FORMAT (A6,'USERID=',I5)
 1092 FORMAT (A6,'CTYPE=''',A,'''',2X,' /',A)
 1094 FORMAT (A6,'BLC=',7I5,' / Bottom left corner')
 1096 FORMAT (A6,'TRC=',7I5,' / Top right corner')
 1098 FORMAT (A6,'/ Single plane of Map 2 applied to all planes of',
     *   ' Map 1')
 1100 FORMAT (A6,4('A(',I1,')=',F9.4,2X))
 1101 FORMAT (A6,3('A(',I1,')=',1PE12.4,2X))
 1110 FORMAT (A6,'/ Undefined pixels magic-value blanked')
 1112 FORMAT (A6,'CBMULT(',I1,')=',F9.5,'  / scaled to match image 1',
     *   ' units')
 1900 FORMAT ('History file created and written for ',A,' file')
 1901 FORMAT ('HISTORY FILE FOR ',A,' INCOMPLETE.  IERRS =',2I7)
 1905 FORMAT ('WARNING CMPLXH COULD NOT COPY TABLES TO OUTPUT ',A,
     *   ' FILE.  IER=',I7)
 1910 FORMAT ('WARNING CMPLXH COULD NOT CLOSE OUTPUT ',A,
     *   ' FILE.  IER=',I7)
      END
