LOCAL INCLUDE 'MTARS.INC'
C                                       Local include for MTARS
      INCLUDE 'INCS:PMAD.INC'
      INTEGER   MAXGAU, MAXFRQ
      PARAMETER (MAXGAU = 9999)
      PARAMETER (MAXFRQ = 4000)
C
      HOLLERITH XINTXT(12), XINLIS(12), XOUTFI(12)
      REAL      FLUX
      REAL      QONE(MAXGAU), UONE(MAXGAU), SPIX(MAXGAU), RM(MAXGAU),
     *   RMTHIK(MAXGAU)
      INTEGER   THETYP(MAXGAU), NGAUSS, NFREQ, SCRTCH(256)
      CHARACTER INTEXT*48, INLIST*48, OUTFIL*48
      DOUBLE PRECISION FQVAL(MAXFRQ)
      COMMON /INPARM/ XINTXT, FLUX, XINLIS, XOUTFI
      COMMON /CHRCOM/ INTEXT, INLIST, OUTFIL
      COMMON /PARMS/ FQVAL, SCRTCH, NGAUSS, NFREQ
      COMMON /BUFRS/ QONE, UONE, SPIX, RM, RMTHIK, THETYP
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
C                                       End MTARS
LOCAL END
      PROGRAM MTARS
C-----------------------------------------------------------------------
C! Makes a model of Q and U in a text file suitable for TARS
C# Map Modeling Polarization
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   MTARS writes a text file with a polarization model
C   Inputs:
C     AIPS adverb  Prg. name.          Description.
C      INTEXT                       text file with frequencies
C      FLUX                         Noise level in Jy
C      INLIST                       Model components
C      OUTFILE                      Output file
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER   IRET
      INCLUDE 'MTARS.INC'
      DATA PRGM /'MTARS '/
C-----------------------------------------------------------------------
C                                       Get inputs, create output file
      CALL MTARSI (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Apply model to image
      CALL MTARSD (IRET)
C                                       Close down files, etc.
 990  CALL DIE (IRET, SCRTCH)
C
 999  STOP
      END
      SUBROUTINE MTARSI (PRGN, IRET)
C-----------------------------------------------------------------------
C   MTARSI gets input parameters for MTARS 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-----------------------------------------------------------------------
      CHARACTER PRGN*6
      INTEGER   IRET
C
      INTEGER   IERR, NPARM, I
      INCLUDE 'MTARS.INC'
      INCLUDE 'INCS:DFIL.INC'
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (.TRUE.)
      CALL VHDRIN
      IRET = 0
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
C                                       Get input parameters.
      NPARM = 37
      CALL GTPARM (PRGN, NPARM, RQUICK, XINTXT, 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, SCRTCH, IERR)
      IF (IRET.NE.0) GO TO 999
      IRET = 5
C                                       Convert characters
      CALL H2CHR (48, 1, XINTXT, INTEXT)
      CALL H2CHR (48, 1, XINLIS, INLIST)
      CALL H2CHR (48, 1, XOUTFI, OUTFIL)
      IF ((INLIST.EQ.' ') .OR. (INTEXT.EQ.' ') .OR. (OUTFIL.EQ.' '))
     *   THEN
         MSGTXT = 'AN INTEXT, INLIST AND OUTFILE MUST BE SPECIFIED'
         GO TO 990
         END IF
C                                       get frequencies
      CALL GETFRQ (IERR)
      IF (IERR.NE.0) GO TO 999
C                                       get components, err msg if error
      CALL READIT (IERR)
      IF (IERR.NE.0) GO TO 999
      WRITE (MSGTXT,1005) NGAUSS
      CALL MSGWRT (3)
      IF (NGAUSS.LE.0) THEN
         IRET = 10
         GO TO 999
         END IF
C                                       init random number generator
      IF (FLUX.GT.0.0) CALL RANDIN (I)
      IRET = 0
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MTARSI: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1005 FORMAT ('Will use',I5,' model components')
      END
      SUBROUTINE GETFRQ (IRET)
C-----------------------------------------------------------------------
C   FNDFQ reads the values of the frequency table
C   Outputs:
C      IRET    I   0 okay, 10 not match, else I/O error
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'MTARS.INC'
      INTEGER   TLUN, TIND, LUNTMP, LLIM, LP, JTRIM
      CHARACTER LINE*132
      DOUBLE PRECISION X
C-----------------------------------------------------------------------
C                                       read text file
      TLUN = LUNTMP (2)
C                                       open the text file
      CALL ZTXOPN ('READ', TLUN, TIND, INTEXT, .FALSE., IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN INTEXT FILE'
         GO TO 990
         END IF
      NGAUSS = 0
 100  CALL ZTXIO ('READ', TLUN, TIND, LINE, IRET)
      IF ((IRET.EQ.0) .AND. (NFREQ.LT.MAXFRQ)) THEN
         LLIM = JTRIM (LINE)
         LP = 1
         IF (LINE(:1).EQ.'#') GO TO 100
         IF (LINE(:1).EQ.';') GO TO 100
         CALL GETNUM (LINE, LLIM, LP, X)
         IF ((X.EQ.DBLANK) .OR. (X.EQ.0.0D0)) GO TO 100
         NFREQ = NFREQ + 1
         FQVAL(NFREQ) = X
         GO TO 100
      ELSE IF (IRET.EQ.2) THEN
         CALL ZTXCLS (TLUN, TIND, IRET)
      ELSE IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'READ INTEXT FILE'
         GO TO 990
         END IF
      WRITE (MSGTXT,1100) NFREQ
      CALL MSGWRT (4)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('GETFRQ: ERROR ',I4,' ON ',A)
 1100 FORMAT ('GETFRQ read',I5,' frequencies from INTEXT')
      END
      SUBROUTINE READIT (IRET)
C-----------------------------------------------------------------------
C   Prepares list of components for adverbs or text file
C   Output
C      IRET   I   Error code
C   rest in Common
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INCLUDE 'MTARS.INC'
      INTEGER   TLUN, TIND, LUNTMP, LLIM, LP, JTRIM
      CHARACTER LINE*132
      DOUBLE PRECISION X
C-----------------------------------------------------------------------
C                                       read text file
      TLUN = LUNTMP (2)
C                                       open the text file
      CALL ZTXOPN ('READ', TLUN, TIND, INLIST, .FALSE., IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPEN TEXT FILE'
         GO TO 999
         END IF
      NGAUSS = 0
 100  CALL ZTXIO ('READ', TLUN, TIND, LINE, IRET)
      IF ((IRET.EQ.0) .AND. (NGAUSS.LT.MAXGAU)) THEN
         LLIM = JTRIM (LINE)
C                                       blanks, comments
         IF (LLIM.LE.0) GO TO 100
         IF (LINE(1:1).EQ.'#') GO TO 100
         IF (LINE(1:1).EQ.';') GO TO 100
C                                       parse
C                                       Q flux
         LP = 1
         CALL GETNUM (LINE, LLIM, LP, X)
         IF ((X.EQ.DBLANK) .OR. (X.EQ.0.0D0)) THEN
            GO TO 100
         ELSE
            NGAUSS = NGAUSS + 1
            QONE(NGAUSS) = X
            END IF
C                                       U flux
         CALL GETNUM (LINE, LLIM, LP, X)
         IF (X.EQ.DBLANK) THEN
            NGAUSS = NGAUSS - 1
            GO TO 100
         ELSE
            UONE(NGAUSS) = X
            END IF
C                                       Spectral index
         CALL GETNUM (LINE, LLIM, LP, X)
         IF (X.EQ.DBLANK) THEN
            NGAUSS = NGAUSS - 1
            GO TO 100
         ELSE
            SPIX(NGAUSS) = X
            END IF
C                                       RM
         CALL GETNUM (LINE, LLIM, LP, X)
         IF (X.EQ.DBLANK) THEN
            NGAUSS = NGAUSS - 1
            GO TO 100
         ELSE
            RM(NGAUSS) = X
            END IF
C                                       RM thickness
         CALL GETNUM (LINE, LLIM, LP, X)
         IF (X.EQ.DBLANK) THEN
            NGAUSS = NGAUSS - 1
            GO TO 100
         ELSE
            RMTHIK(NGAUSS) = X
            END IF
C                                       the type
         CALL GETNUM (LINE, LLIM, LP, X)
         THETYP(NGAUSS) = 0
         IF (RMTHIK(NGAUSS).NE.0.0D0) THETYP(NGAUSS) = 1
         IF (X.NE.DBLANK) THEN
            THETYP(NGAUSS) = X + 0.1D0
            END IF
         GO TO 100
C                                       real error
      ELSE IF ((IRET.GT.0) .AND. (IRET.NE.2)) THEN
         WRITE (MSGTXT,1000) IRET, 'READING TEXT FILE'
         GO TO 990
C                                       EOF
      ELSE
         CALL ZTXCLS (TLUN, TIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'CLOSING TEXT FILE'
            GO TO 990
            END IF
         END IF
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('READIT ERROR',I4,' ON ',A)
      END
      SUBROUTINE MTARSD (IRET)
C-----------------------------------------------------------------------
C   MTARSD writes the output text file computing the model for each freq
C   Output:
C      IRET    I      Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      INTEGER   TLUN, TIND, I, LUNTMP, JP, JTRIM
      CHARACTER LINE*132
      DOUBLE PRECISION QVAL, UVAL
      INCLUDE 'MTARS.INC'
C-----------------------------------------------------------------------
      TLUN = LUNTMP (2)
      CALL ZTXOPN ('WRIT', TLUN, TIND, OUTFIL, .FALSE., IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'OPENING OUTFILE'
         GO TO 990
         END IF
      WRITE (LINE,1045)
      JP = JTRIM (LINE)
      CALL ZTXIO ('WRIT', TLUN, TIND, LINE(:JP), IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1000) IRET, 'WRITING OUTFILE'
         GO TO 990
         END IF
      DO 50 I = 1,NGAUSS
         WRITE (LINE,1050) I, QONE(I), UONE(I), SPIX(I), RM(I),
     *      RMTHIK(I)
         JP = JTRIM (LINE)
         CALL ZTXIO ('WRIT', TLUN, TIND, LINE(:JP), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTFILE'
            GO TO 990
            END IF
 50      CONTINUE
C                                       loop over frequency
      DO 100 I = 1,NFREQ
         CALL THEMOD (FQVAL(I), QVAL, UVAL)
         WRITE (LINE,1100) FQVAL(I), QVAL, UVAL
         JP = JTRIM (LINE)
         CALL ZTXIO ('WRIT', TLUN, TIND, LINE(:JP), IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1000) IRET, 'WRITING OUTFILE'
            GO TO 990
            END IF
 100     CONTINUE
      CALL ZTXCLS (TLUN, TIND, IRET)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('MTARSD ERROR',I4,' ON ',A)
 1045 FORMAT ('; MTARS',4X,'#',4X,'Qpol',5X,'Upol',3X,'Spix',8X,'RM',
     *   3X,'Thick')
 1050 FORMAT ('; MTARS',I5,2F9.3,F7.2,F10.1,F7.1)
 1100 FORMAT (3(1PE13.5))
      END
      SUBROUTINE THEMOD (FREQ, QVAL, UVAL)
C-----------------------------------------------------------------------
C   Apply model to one frequency
C   Inputs:
C      FREQ     D      Frequency in Hz
C   In/out
C      QVAL     D      Qpol model value
C      UVAL     D      Upol model value
C-----------------------------------------------------------------------
      DOUBLE PRECISION FREQ, QVAL, UVAL
C
      INCLUDE 'MTARS.INC'
      REAL      ANOISE
      INTEGER   K
      DOUBLE PRECISION QSUM, USUM, QV, UV
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      QSUM = 0.0D0
      USUM = 0.0D0
      DO 100 K = 1,NGAUSS
         CALL ROTMES (QONE(K), UONE(K), RM(K), RMTHIK(K), SPIX(K), FREQ,
     *      THETYP(K), QV, UV)
         QSUM = QSUM + QV
         USUM = USUM + UV
C                                       Add random noise?
         IF (FLUX.GT.0.0) THEN
            CALL NOISE (ANOISE)
            QSUM = QSUM + ANOISE * FLUX
            CALL NOISE (ANOISE)
            USUM = USUM + ANOISE * FLUX
            END IF
 100     CONTINUE
      QVAL = QSUM
      UVAL = USUM
C
 999  RETURN
      END
      SUBROUTINE NOISE (A)
C-----------------------------------------------------------------------
C   NOISE generates a random number approximately distributed in a
C   Gaussian manner about zero.  It does it by summing a uniformly-
C   distributed random number 12 times.
C   Output:
C      A   R       The current sample from the gaussian distribution
C-----------------------------------------------------------------------
      REAL      A, B
      INTEGER   J
C-----------------------------------------------------------------------
      A = -6.0
      DO 10 J = 1,12
         CALL RANDUM (B)
         A = A + B
 10      CONTINUE
C
 999  RETURN
      END
      SUBROUTINE ROTMES (QONE, UONE, RM, RMTHIK, SPIX, FREQ, MODEL,
     *   QV, UV)
C-----------------------------------------------------------------------
C   ROTMES computes the rotation measure rotated Q or U
C   Inputs:
C      QONE     R   Q at FREQ=1.E9
C      UONE     R   U at FREQ=1.E9
C      RM       R   Rotation measure in radians/m^2
C      SPIX     R   Spectral index
C      FREQ     D   Frequency
C      MODEL    I   Type of thickness model (2, 3, 4)
C   Outputs
C      QV       D   The Q at this lambda
C      UV       D   The Q at this lambda
C-----------------------------------------------------------------------
      INTEGER   MODEL
      REAL      QONE, UONE, RM, RMTHIK, SPIX
      DOUBLE PRECISION FREQ, QV, UV
C
      REAL      SPHI, CPHI, FACTOR
      DOUBLE PRECISION LAMONE, XX, DSINCS, LAMBSQ
      INCLUDE 'INCS:PSTD.INC'
C-----------------------------------------------------------------------
      FACTOR = (FREQ/1.D9) ** SPIX
      LAMONE = (VELITE / 1.D9) **2
      LAMBSQ = (VELITE / FREQ) ** 2
      IF (RMTHIK.NE.0.0) THEN
         XX = RMTHIK * LAMBSQ
         FACTOR = FACTOR * DSINCS (MODEL, 0, XX)
         END IF
      SPHI = FACTOR * SIN (2.0 * RM * (LAMBSQ - LAMONE))
      CPHI = FACTOR * COS (2.0 * RM * (LAMBSQ - LAMONE))
      QV = QONE * CPHI - UONE * SPHI
      UV = UONE * CPHI + QONE * SPHI
C
 999  RETURN
      END
      DOUBLE PRECISION FUNCTION DSINCS (MODEL, TYPE, XX)
C-----------------------------------------------------------------------
C   returns sin(xx)/xx on type 0 and d (sin(xx)/xx) / dx on type 1
C   Inputs:
C      MODEL   I   1 - sin(x)/x, 2 Gauss, 3 exp
C      TYPE    I   0 - return function, 1 return derivative
C      XX      D   argument
C   Output
C     DSINCS   D   function value or derivative
C-----------------------------------------------------------------------
      INTEGER   MODEL, TYPE
      DOUBLE PRECISION XX
C
      DOUBLE PRECISION F
C                                       1.8954 radians is the half-power
C                                       of sin(x) / x
C-----------------------------------------------------------------------
      DSINCS = 0.0D0
C                                       SIN(X)/X function
      IF (MODEL.EQ.1) THEN
         IF (TYPE.EQ.0) THEN
            IF (ABS(XX).LE.1.D-5) THEN
               DSINCS = 1.0D0 - XX*XX / 6.0D0 + XX*XX*XX*XX / 120.0D0
            ELSE
               DSINCS = SIN (XX) / XX
               END IF
C                                       SIN(X)/X derivative
         ELSE IF (TYPE.EQ.1) THEN
            IF (ABS(XX).LE.1.D-5) THEN
               DSINCS = -XX/3.D0 + XX*XX*XX/30.D0 -
     *            XX*XX*XX*XX*XX/840.D0
            ELSE
               DSINCS = (XX * COS(XX) - SIN(XX)) / (XX*XX)
               END IF
            END IF
C                                       Gauss function
      ELSE IF (MODEL.EQ.2) THEN
         F = -LOG (2.0D0) / (1.8954 * 1.8954)
         IF (TYPE.EQ.0) THEN
            DSINCS = EXP (F * XX * XX)
C                                       Gauss derivative
         ELSE IF (TYPE.EQ.1) THEN
            DSINCS = 2.0 * XX * F * EXP (F * XX * XX)
            END IF
C                                       Exp function
      ELSE IF (MODEL.EQ.3) THEN
         F = -LOG (2.0D0) / 1.8954
         IF (TYPE.EQ.0) THEN
            DSINCS = EXP (F * ABS(XX))
C                                       Exp derivative
         ELSE IF (TYPE.EQ.1) THEN
            DSINCS = F * EXP (F * ABS(XX))
            END IF
         END IF
C
 999  RETURN
      END
