      SUBROUTINE NCALC (INIT, VOBS, IS, JS, WT, NUMBL, REFANT, MODE,
     *   MINNO, GAERR, CONFAC, G, NREF, PRTLV, FFLIM, FFLAST, FRAC, RMS,
     *   IERR)
C-----------------------------------------------------------------------
C! Gain Soln: Does least sq. gain solution with amplitude constraints.
C# UV Calibration
C-----------------------------------------------------------------------
C;  Copyright (C) 1995, 2004-2005, 2021
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   NCALC computes antenna gains.  Will add penalty term to constrain
C   the amplitude of the gains.  Penalty term is proportional to the
C   difference in the current gain RMS (in sigmas) from the expected
C   value.
C   Inputs:
C      INIT     L        T -> start with (1,0) compute NREF if needed
C                        F -> start with GLAST, keep NREF as is
C      VOBS     R(2,*)   Averaged visibility (real, imaginary)
C      IS       I(*)     Array of first antenna numbers.
C      JS       I(*)     Array of second antenna numbers.
C      NUMBL    I        Number of observations.
C      REFANT   I        Desired reference antenna.
C      MODE     I        Solution mode: 0 = full gain soln.
C                           1 = phase only keep ampl. info.
C                           2 = phase only discard ampl. info.
C                        + 10 * weight func (1 sqrt, 2 4th root, 3 -> 1
C      MINNO    I        Min. number of antennas acceptable.
C      GAERR    R(*)     Standard deviations of the assumed
C                        distributions of the amplitudes of the gains.
C                        Used to constrain the solutions.
C      CONFAC   R        Factor to multiply times the penalty term to
C                        increase or decrease its importance.
C      PRTLV    I        Print level,   0 = none
C                           1 = print (MSGWRT) soln.
C                           2 = print RMS at each iteration
C                           3 = print data plus soln.
C      FFLIM    R        Limit clip to max (std, FFLIM) * rms
C      FFLAST   R        Mark bad those data with closure error >
C                        FFLAST * rms closure error on last iteration
C   In/out:
C      WT       R(*)     Array of visibility weights - adjusted for
C                        amplitude normalizations and weight function
C   Outputs:
C      G        R(2,*)   Antenna gains to be applied (real, imaginary)
C                        returnsd 1,0 for missing antennas
C      NREF     I        Reference antenna used.
C      RMS      R        RMS closure error
C      IERR     I        Return error code 0 = OK
C                           1 = no valid data
C                           2 = didn't converge
C                           3 = too few antennas
C   Task BPASS does not change reference if it is set and sets it if
C   it needs to.
C-----------------------------------------------------------------------
      LOGICAL   INIT
      INTEGER   IS(*), JS(*), NUMBL, REFANT, MODE, MINNO, NREF, PRTLV,
     *   IERR, IIER
      REAL      VOBS(2,*), WT(*), GAERR(*), CONFAC, G(2,*), FFLIM,
     *   FFLAST, FRAC, RMS
C
      INTEGER   ITRMAX
      PARAMETER (ITRMAX = 10)
C
      INTEGER   LDH, N
      INTEGER   IARG1, IARG2, MAXANS, K, KK, J, JJ, I, II, L, LL, NT,
     *   NTD, MODESV, IT, ITMAX, IIP, JJP, IIA, JJA, ID2, LMODE, LWT,
     *   ITER, ITRMIN
      REAL      XRE, XIM, XAMP, XPHAS, XXX, PH, AMP, SUMWT, FF(ITRMAX),
     *   Z(2), ZR, ZI, QQ, XX, YY, GG(ITRMAX)
      DOUBLE PRECISION S, SL, PENSUM, GN, W, RCOND, DET(2),
     *   TOL, XLAM, C, AI, AJ, PI, PJ, SR, SI, CR, CI
      LOGICAL   DORMS
      INCLUDE 'INCS:PUVD.INC'
      INCLUDE 'INCS:GAIN.INC'
      INTEGER   IA(MAXANT), IB(MAXANT), INERT(3), KPVT(MAXPRM)
      REAL      SWT(MAXANT), GLAST(2,MAXANT)
      INCLUDE 'INCS:DMSG.INC'
      COMMON /GLASTS/ GLAST
      DATA ITMAX/50/, TOL/1D-6/
      DATA GG /7.0, 5.0, 4.0, 3.5, 3.0, 2.8, 2.6, 2.4, 2.2, 2.5/
C-----------------------------------------------------------------------
      IERR = 1
      IF (NUMBL.LE.0) GO TO 999
      CALL RCOPY (ITRMAX, GG, FF)
      DO 5 I = 1,ITRMAX
         FF(I) = MAX (FF(I), FFLIM)
 5       CONTINUE
      IF (FFLAST.GE.1.0) FF(ITRMAX) = FFLAST
C                                       interpret mode
      LMODE = MOD (MODE, 10)
      ITRMIN = ITRMAX
      IF (LMODE.GT.3) THEN
         ITRMIN = 1
         LMODE = LMODE - 4
         END IF
      LWT = MODE / 10
C                                       inits
      LDH = MAXPRM
      MAXANS = MAXANT
      DO 10 I = 1,MAXANS
         SWT(I) = 0.0
 10      CONTINUE
      NT = 0
      SUMWT = 0.0
C                                       Determine which antennas have
C                                       data. NT is the highest
C                                       numbered antenna with data
C                                       present. SWT(K) is the sum of
C                                       data weights involving antenna
C                                       K. SUMWT is the sum of all data
C                                        weights.
      DO 20 K = 1,NUMBL
         I = IS(K)
         J = JS(K)
         NT = MAX (NT,J)
C                                       Assume that any 0 observations
C                                       ought to have been flagged, and
C                                       insist on non negative weights:
         XXX = SQRT (VOBS(1,K)*VOBS(1,K) + VOBS(2,K)*VOBS(2,K))
         IF (XXX.EQ.0.0) WT(K) = 0.0
         IF (WT(K).GT.0.) THEN
C                                       In case MODE=2, so that
C                                       amplitude info. is to be
C                                       ignored, give the obs. unit
C                                       modulus:
            IF (LMODE.EQ.2) THEN
               VOBS(1,K) = VOBS(1,K) / XXX
               VOBS(2,K) = VOBS(2,K) / XXX
               WT(K) = WT(K) * XXX * XXX
               END IF
            CALL REWAIT (LWT, WT(K))
            SWT(I) = SWT(I) + WT(K)
            SWT(J) = SWT(J) + WT(K)
            SUMWT = SUMWT + WT(K)
C                                       If PRTLV .ge. 3  print data.
            IF ((PRTLV.GE.3) .AND. (WT(K).GT.1.0E-20)) THEN
               XRE = VOBS(1,K) + 1.0E-20
               XIM = VOBS(2,K)
               XAMP = SQRT (XRE * XRE + XIM * XIM)
               XPHAS = 57.296 * ATAN2 (XIM, XRE)
               WRITE (MSGTXT,1010) I, J, XAMP, XPHAS
               CALL MSGWRT (3)
               END IF
         ELSE
            WT(K) = 0.0
            END IF
 20      CONTINUE
C                                       Check whether any data were
C                                       present:
      IF (SUMWT.EQ.0.) GO TO 999
      IF ((TSKNAM.EQ.'BPASS') .AND. (REFANT.GT.0) .AND.
     *   (SWT(REFANT).LE.0.0)) GO TO 999
C                                       init solutions
      DO 25 I = 1,MAXANS
         IF ((INIT) .OR. (SWT(I).LE.0.0)) THEN
            G(1,I) = 1.0
            G(2,I) = 0.0
         ELSE
            G(1,I) = GLAST(1,I) * COS (GLAST(2,I))
            G(2,I) = GLAST(1,I) * SIN (GLAST(2,I))
            END IF
 25      CONTINUE
C                                       Check the reference antenna for
C                                       presence of data.
C                                       Choose another, if need be:
      IF ((INIT) .OR. (NREF.LE.0) .OR. (NREF.GT.MAXANS)) THEN
         NREF = REFANT
         IF ((NREF.LT.1) .OR. (NREF.GT.MAXANS) .OR. (SWT(NREF).LE.0.0))
     *      THEN
            XXX = 0.0
            DO 30 I = 1,NT
               IF (SWT(I).GT.XXX) THEN
                  XXX = SWT(I)
                  NREF = I
                  END IF
 30            CONTINUE
            IF (TSKNAM.EQ.'BPASS') REFANT = NREF
            END IF
         END IF
C                                       Check for plenty of antennae,
C                                       and count the number (NTD)
C                                       with data:
      NTD = 0
      DO 40 I = 1,NT
         IF (SWT(I).GT.0.0) NTD = NTD + 1
 40      CONTINUE
      IERR = 3
      IF (NTD.LT.MINNO) GO TO 999
      DORMS = (2.5*(NTD-1).LE.NUMBL)
C                                       Assign a new antenna numbering,
C                                       based only on those antennas
C                                       with data present.  Assign 1
C                                       to the reference antenna.
C                                       Store the assignments in IA,
C                                       and let IB be the inverse
C                                       permutation.
      IA(1) = NREF
      IB(NREF) = 1
      K = 1
      DO 50 I = 1,NT
         IF ((SWT(I).GT.0.0) .AND. (I.NE.NREF)) THEN
            K = K + 1
            IA(K) = I
            IB(I) = K
            END IF
 50      CONTINUE
C                                       Set initial guesses to zero for
C                                       the arguments of the gains,
C                                       stored in XPRM(1),...,
C                                       XPRM(NTD-1),and
C                                       to unity for their moduli,
C                                       stored in XPRM(NTD),...,
C                                       XPRM(2*NTD-1).
C                                       Also initialize the correction
C                                       vector, STEP, to 0.
C                                       N is the total number of real
C                                       unknowns.
      N = 2 * NTD - 1
      IF ((LMODE.EQ.1) .OR. (LMODE.EQ.2)) N = NTD - 1
      DO 60 I = 1,N
         IF (INIT) THEN
            IF (I.LT.NTD) THEN
               XPRM(I) = 0.0D0
            ELSE
               XPRM(I) = 1.0D0
               END IF
         ELSE
            IF (I.LT.NTD) THEN
               K = IA(I+1)
               XPRM(I) = GLAST(2,K)
            ELSE
               K = IA(I+1-NTD)
               XPRM(I) = GLAST(1,K)
               END IF
            K = IA(I)
            END IF
         STEP(I) = 0.0D0
 60      CONTINUE
      MODESV = LMODE
C                                       Robust iteration
      IF (.NOT.DORMS) ITRMIN = ITRMAX
      DO 400 ITER = ITRMIN,ITRMAX
C                                       When solving for amplitude and
C                                       phase solutions, first converge
C                                       upon `phase-only' (MODE=1) soln
         IF (((LMODE.EQ.0) .OR. (LMODE.EQ.3)) .AND. (ITER.LT.ITRMIN+5))
     *      THEN
            LMODE = 1
            N = NTD - 1
            END IF
C                                       Loop-back point to do amp/phase
 100     CONTINUE
C
C                                       Iterate:
         DO 250 IT = 1,ITMAX
C                                       Zero the gradient and
C                                       Hessian arrays:
            DO 110 I = 1,N
               GRAD(I) = 0.0
               DO 105 J = 1,N
                  HESS(I,J) = 0.0
 105              CONTINUE
 110           CONTINUE
C                                       On first iteration, calculate
C                                       the objective function, SL:
            IF (IT.EQ.1) CALL NEVAL (XPRM, 0.0D0, STEP, VOBS, IS, JS,
     *         IA, WT, NUMBL, NTD, LMODE, PRTLV, GAERR, CONFAC, G, SL,
     *         PENSUM)
C                                       Accumulate (half) the gradient
C                                       of S and (half) the Hessian:
            DO 130 K = 1,NUMBL
               IF (WT(K).LE.0.) GO TO 130
               I = IS(K)
               J = JS(K)
               II = IB(I)
               JJ = IB(J)
               IIP = II - 1
               JJP = JJ - 1
               PI = 0.0D0
               PJ = 0.0D0
               IF (I.NE.NREF) PI = XPRM(IIP)
               IF (J.NE.NREF) PJ = XPRM(JJP)
               SR = SIN (PJ - PI) * VOBS(1,K)
               SI = SIN (PJ - PI) * VOBS(2,K)
               CR = COS (PJ - PI) * VOBS(1,K)
               CI = COS (PJ - PI) * VOBS(2,K)
               IF ((LMODE.NE.1) .AND. (LMODE.NE.2)) THEN
                  IIA = NTD + II - 1
                  JJA = NTD + JJ - 1
                  AI = XPRM(IIA)
                  AJ = XPRM(JJA)
                  END IF
               IF (I.EQ.NREF) THEN
                  IF ((LMODE.EQ.1) .OR. (LMODE.EQ.2)) THEN
                     GRAD(JJP) = GRAD(JJP) + WT(K) * (SR + CI)
                     HESS(JJP,JJP) = HESS(JJP,JJP) + WT(K) * (CR - SI)
                  ELSE
                     GRAD(JJP) = GRAD(JJP) + WT(K) * AI * AJ * (SR + CI)
                     GRAD(IIA) = GRAD(IIA) + WT(K) * AJ * (AI*AJ-CR+SI)
                     GRAD(JJA) = GRAD(JJA) + WT(K) * AI * (AI*AJ-CR+SI)
                     HESS(JJP,JJP) = HESS(JJP,JJP) + WT(K) * AI * AJ *
     *                  (CR - SI)
                     HESS(IIA,IIA) = HESS(IIA,IIA) + WT(K) * AJ**2
                     HESS(JJA,JJA) = HESS(JJA,JJA) + WT(K) * AI**2
                     IARG1 = MIN (IIA, JJA)
                     IARG2 = MAX (IIA, JJA)
                     HESS(IARG1,IARG2) = HESS(IARG1,IARG2)
     *                  + WT(K) * (2.0D0 * AI * AJ - CR + SI)
                     IARG1 = MIN (IIA, JJP)
                     IARG2 = MAX (IIA, JJP)
                     HESS(IARG1,IARG2) = HESS(IARG1,IARG2)
     *                  + WT(K) * AJ * (SR + CI)
                     HESS(JJP,JJA) = HESS(JJP,JJA) + WT(K) * AI *
     *                  (SR + CI)
                     END IF
               ELSE IF (J.EQ.NREF) THEN
                  IF ((LMODE.EQ.1) .OR. (LMODE.EQ.2)) THEN
                     GRAD(IIP) = GRAD(IIP) - WT(K) * (SR + CI)
                     HESS(IIP,IIP) = HESS(IIP,IIP) + WT(K) * (CR - SI)
                  ELSE
                     GRAD(IIP) = GRAD(IIP) - WT(K) * AI * AJ * (SR + CI)
                     GRAD(IIA) = GRAD(IIA) + WT(K) * AJ * (AI * AJ -
     *                  CR + SI)
                     GRAD(JJA) = GRAD(JJA) + WT(K) * AI * (AI * AJ -
     *                  CR + SI)
                     HESS(IIP,IIP) = HESS(IIP,IIP) + WT(K) * AI * AJ *
     *                  (CR - SI)
                     HESS(IIA,IIA) = HESS(IIA,IIA) + WT(K) * AJ**2
                     HESS(JJA,JJA) = HESS(JJA,JJA) + WT(K) * AI**2
                     IARG1 = MIN (IIA, JJA)
                     IARG2 = MAX (IIA, JJA)
                     HESS(IARG1,IARG2) = HESS(IARG1,IARG2)
     *                  + WT(K) * (2.0D0 * AI * AJ - CR + SI)
                     HESS(IIP,IIA) = HESS(IIP,IIA) - WT(K) * AJ *
     *                  (SR + CI)
                     IARG1 = MIN (IIP, JJA)
                     IARG2 = MAX (IIP, JJA)
                     HESS(IARG1,IARG2) = HESS(IARG1,IARG2)
     *                  - WT(K) * AI * (SR + CI)
                     END IF
               ELSE
                  IF ((LMODE.EQ.1) .OR. (LMODE.EQ.2)) THEN
                     GRAD(IIP) = GRAD(IIP) - WT(K) * (SR + CI)
                     GRAD(JJP) = GRAD(JJP) + WT(K) * (SR + CI)
                     HESS(IIP,IIP) = HESS(IIP,IIP) + WT(K) * (CR - SI)
                     HESS(JJP,JJP) = HESS(JJP,JJP) + WT(K) * (CR - SI)
                     IARG1 = MIN (IIP, JJP)
                     IARG2 = MAX (IIP, JJP)
                     HESS(IARG1,IARG2) = HESS(IARG1,IARG2)
     *                  - WT(K) * (CR - SI)
                  ELSE
                     GRAD(IIP) = GRAD(IIP) - WT(K) * AI * AJ * (SR + CI)
                     GRAD(JJP) = GRAD(JJP) + WT(K) * AI * AJ * (SR + CI)
                     GRAD(IIA) = GRAD(IIA) + WT(K) * AJ * (AI * AJ -
     *                  CR + SI)
                     GRAD(JJA) = GRAD(JJA) + WT(K) * AI * (AI * AJ -
     *                  CR + SI)
                     HESS(IIP,IIP) = HESS(IIP,IIP) + WT(K) * AI * AJ *
     *                  (CR - SI)
                     HESS(JJP,JJP) = HESS(JJP,JJP) + WT(K) * AI * AJ *
     *                  (CR - SI)
                     IARG1 = MIN (IIP, JJP)
                     IARG2 = MAX (IIP, JJP)
                     HESS(IARG1,IARG2) = HESS(IARG1,IARG2)
     *                  - WT(K) * AI * AJ * (CR - SI)
                     HESS(IIA,IIA) = HESS(IIA,IIA) + WT(K) * AJ**2
                     HESS(JJA,JJA) = HESS(JJA,JJA) + WT(K) * AI**2
                     IARG1 = MIN (IIA, JJA)
                     IARG2 = MAX (IIA, JJA)
                     HESS(IARG1,IARG2) = HESS(IARG1,IARG2)
     *                  + WT(K) * (2.0D0 * AI * AJ - CR + SI)
                     HESS(IIP,IIA) = HESS(IIP,IIA) - WT(K) * AJ *
     *                  (SR + CI)
                     IARG1 = MIN (IIA, JJP)
                     IARG2 = MAX (IIA, JJP)
                     HESS(IARG1,IARG2) = HESS(IARG1,IARG2)
     *                  + WT(K) * AJ * (SR + CI)
                     IARG1 = MIN (IIP, JJA)
                     IARG2 = MAX (IIP, JJA)
                     HESS(IARG1, IARG2) = HESS(IARG1,IARG2)
     *                  - WT(K) * AI * (SR + CI)
                     HESS(JJP,JJA) = HESS(JJP,JJA) + WT(K) * AI *
     *                  (SR + CI)
                     END IF
                  END IF
 130           CONTINUE
C                                       Add in the amplitude penalty
C                                       terms:
            IF (LMODE.EQ.3) THEN
               XLAM = PENSUM - NTD
               C = 0.1 * CONFAC
               DO 150 I = 1,NTD
                  K = IA(I)
                  KK = NTD + I - 1
                  GRAD(KK) = GRAD(KK) + 2.0D0*C * XLAM *
     *               (XPRM(KK) - 1.0D0) / GAERR(K)**2
                  HESS(KK,KK) = HESS(KK,KK) + 2.0D0*C * XLAM /
     *               GAERR(K)**2
                  DO 140 J = I,NTD
                     L = IA(J)
                     LL = NTD + J - 1
                     HESS(KK,LL) = HESS(KK,LL) + 4.0D0 * C *
     *                  (XPRM(LL) - 1.0D0) * (XPRM(KK) - 1.0D0)
     *                  / (GAERR(L) * GAERR(K))**2
 140                 CONTINUE
 150              CONTINUE
               END IF
C                                       Fill in the lower triangular
C                                       part of the Hessian:
            DO 160 I = 2,N
               JJ = I - 1
               DO 155 J = 1,JJ
                  HESS(I,J) = HESS(J,I)
 155              CONTINUE
 160           CONTINUE
C                                       Save the Hessian, in case
C                                       that it's indefinite:
            DO 170 I = 1,N
               DO 165 J = 1,N
                  SHESS(I,J) = HESS(I,J)
 165              CONTINUE
 170           CONTINUE
C                                       Calculate and print the
C                                       Euclidean norm of the gradient,
C                                       in order to monitor the
C                                       progress toward a critical
C                                       point:
            CALL DNRM2 (N, GRAD, 1, GN)
            IF (PRTLV.GE.2) THEN
               WRITE (MSGTXT,1000) IT,GN
               CALL MSGWRT (3)
               END IF
C                                       Factor the Hessian, and obtain
C                                       an estimate of its cond. no.:
            CALL DSICO (HESS, LDH, N, KPVT, RCOND, GWORK)
            IF (PRTLV.GE.2) THEN
               WRITE (MSGTXT,1001) RCOND
               CALL MSGWRT (3)
               END IF
C                                       Compute determinant and inertia:
            IF ((1.0D0+RCOND).NE.1.0D0) THEN
               CALL DSIDI (HESS, LDH, N, KPVT, DET, INERT, GWORK, 110)
               ID2 = DET(2)
               IF (PRTLV.GE.2) THEN
                  WRITE (MSGTXT,1002) DET(1), ID2, INERT
                  CALL MSGWRT (3)
                  END IF
               END IF
C                                       If the Hessian is indefinite
C                                       or singular, use Greenstadt's
C                                       modification:
            IF ((INERT(1).NE.N) .OR. ((1.0D0+RCOND).EQ.1.0D0)) THEN
               CALL GM (N, SHESS, HESS, GWORK, LDH, GRAD, IIER)
               IF (IIER.NE.0) GO TO 999
C                                       Solve for the Newton correction
C                                       (to be placed in GRAD):
            ELSE
               CALL DSISL (HESS, LDH, N, KPVT, GRAD)
               END IF
C                                       Take a damped Newton step:
            DO 180 I = 1,N
               STEP(I) = GRAD(I)
               IF (I.GE.NTD.AND.XPRM(I) - STEP(I).LE.0.)
     *            STEP(I) = 0.5 * XPRM(I)
 180           CONTINUE
            W = 1.
            DO 190 KK = 1,8
               CALL NEVAL (XPRM, W, STEP, VOBS, IS, JS, IA, WT, NUMBL,
     *            NTD, LMODE, PRTLV, GAERR, CONFAC, G, S, PENSUM)
               IF (S.LT.SL) GO TO 200
               IF (KK.LE.4) W = 0.5 * W
               IF (KK.GT.4) W = 0.1 * W
 190           CONTINUE
            GO TO 260
 200        IF ((ABS (1.0D0-S/SL).LE.5.0D-6) .AND. (GN.LT.1.)) GO TO 260
            SL = S
            DO 210 I = 1,N
               XPRM(I) = XPRM(I) - W * STEP(I)
 210           CONTINUE
C                                       not yet converged?
            DO 220 I = 1,N
               IF (ABS (STEP(I)).GT.(ABS (XPRM(I)) + 1D-3) * TOL)
     *            GO TO 250
 220           CONTINUE
            GO TO 260
 250        CONTINUE
         IERR = 2
         IF (LMODE.EQ.MODESV) GO TO 999
C                                       converged switch to A&P
 260     IF (MODESV.NE.LMODE) THEN
            LMODE = MODESV
            N = 2 * NTD - 1
            GO TO 100
            END IF
C                                       squirrel away results
         PH = 0.0
         AMP = 1.0
         DO 270 I = 1,NTD
            K = IA(I)
            IF ((LMODE.EQ.0) .OR. (LMODE.EQ.3)) AMP = XPRM(NTD+I-1)
            IF (I.GT.1) PH = XPRM(I-1)
            G(1,K) = AMP * COS (PH)
            G(2,K) = AMP * SIN (PH)
            GLAST(1,K) = AMP
            GLAST(2,K) = PH
 270        CONTINUE
C                                       find statistics
         S = 0.0
         XXX = 1.0
         DO 280 K = 1,NUMBL
            IF (WT(K).GT.0.0) THEN
               II = IS(K)
               JJ = JS(K)
               Z(1) = G(1,JJ)
               Z(2) = - G(2,JJ)
               ZR = G(1,II) * Z(1) - G(2,II) * Z(2)
               ZI = G(1,II) * Z(2) + G(2,II) * Z(1)
               IF (LMODE.EQ.1) XXX = SQRT ((VOBS(1,K)*VOBS(1,K)) +
     *            (VOBS(2,K)*VOBS(2,K)))
               Z(1) = VOBS(1,K)/XXX - ZR
               Z(2) = VOBS(2,K)/XXX - ZI
               QQ = Z(1) * Z(1) + Z(2) * Z(2)
               S = S + WT(K) * QQ
               END IF
 280        CONTINUE
         RMS = SQRT (S/SUMWT)
C                                       drop some of the extremes
         SUMWT = 0.0
         XXX = 1.0
         CALL RFILL (MAXANS, 0.0, SWT)
         IF (.NOT.DORMS) RMS = 1.0E10
         DO 310 K = 1,NUMBL
            II = IS(K)
            JJ = JS(K)
            IF (WT(K).NE.0.0) THEN
               WT(K) = ABS (WT(K))
               Z(1) = G(1,JJ)
               Z(2) = - G(2,JJ)
               ZR = G(1,II) * Z(1) - G(2,II) * Z(2)
               ZI = G(1,II) * Z(2) + G(2,II) * Z(1)
               IF (LMODE.EQ.1) XXX = SQRT ((VOBS(1,K)*VOBS(1,K)) +
     *            (VOBS(2,K)*VOBS(2,K)))
               Z(1) = ABS (VOBS(1,K)/XXX - ZR) / RMS
               Z(2) = ABS (VOBS(2,K)/XXX - ZI) / RMS
               IF (((Z(1).GT.FF(ITER)) .OR. (Z(2).GT.FF(ITER))) .AND.
     *            (DORMS)) THEN
                  WT(K) = -WT(K)
               ELSE
                  SWT(II) = SWT(II) + WT(K)
                  SWT(JJ) = SWT(JJ) + WT(K)
                  SUMWT = SUMWT + WT(K)
                  END IF
               END IF
 310        CONTINUE
 400     CONTINUE
      IERR = 0
      IF (.NOT.DORMS) RMS = 0.0
C                                       fraction excluded
      XX = 0.0
      YY = 0.0
      DO 410 K = 1,NUMBL
         IF (WT(K).NE.0.0) THEN
            XX = XX + 1.0
            IF (WT(K).LT.0.0) YY = YY + 1.0
            END IF
 410     CONTINUE
      FRAC = 1.0
      IF (XX.GT.0.0) FRAC = YY / XX
C                                       print results
      IF (PRTLV.GE.1) THEN
         AMP = 1.0
         DO 540 I = 1,NT
            IF (SWT(I).GT.0.) THEN
               K = IB(I)
               IF (LMODE.EQ.0.OR.LMODE.EQ.3) AMP = XPRM(NTD+K-1)
               PH = 0.0
               IF (K.GT.1) PH = 57.2958 * ATAN2 (G(2,I), G(1,I))
               WRITE (MSGTXT,1100) I, AMP, PH
               CALL MSGWRT (3)
               END IF
 540        CONTINUE
         END IF
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('Iteration #',I4,'   gradient norm=',1PE15.5)
 1001 FORMAT ('Reciprocal cond. no.=',1PE15.5)
 1002 FORMAT ('Det.=',F15.5,'E',I4,'   Inertia=',3I3)
 1010 FORMAT ('Baseline ',I3,'-',I3,' Amp=',F10.5,' Phase=',F6.1)
 1100 FORMAT ('Ant=',I4,' Amp=',1PE15.5,' Phase=',0PF8.3)
      END
