      SUBROUTINE FINAL (IUO,A,NX,B,SHIFTS,GOOGE,G,SIGUWT)

*** LIST THE ADJUSTMENT RESULTS

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      LOGICAL INVERT,GETA
      LOGICAL LMSL,LSS,LUP
      DIMENSION A(*),NX(*),B(*),SHIFTS(*),GOOGE(*),G(*)
      COMMON /OPT/ AX,E2,DMSL,DGH,VM,VP,CTOL,ITMAX,ITMIN,IMODE,
     &             LMSL,LSS,LUP
      COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD
      COMMON /NUMVFS/ NVFTOT,NVFREE

***  COMPLETE THE COMPUTATION OF THE GOOGE NUMBERS

      IF (NVFREE.EQ.0) THEN
        DO 4 I = 1,NUNK
          IF ( .NOT.GETA(I,I,VAL,A,NX) ) THEN
            CALL INVIUN (I,ISN,ITYP,IUCODE)
            WRITE (6,5) I,ISN,ITYP,IUCODE
    5       FORMAT ('0 FATAL ERROR IN GOOGE COMPUTATION IN FINAL',4I5)
            CALL ABORT2
          ENDIF
          GOOGE(I) = VAL * VAL / GOOGE(I)
    4   CONTINUE
      ENDIF

*** INVERT WITHIN PROFILE

      IF (IMODE.NE.1 .AND. NVFREE.EQ.0) THEN
        IF ( .NOT.INVERT(A,NX) ) THEN
          WRITE (6,666)
  666     FORMAT ('0STATE ERROR IN FINAL')
          CALL ABORT2
        ENDIF
      ENDIF

*** LIST THE JOB STATISTICS

      CALL JOBSTT

*** LIST ADJUSTED OBSERVATIONS AND RESIDUALS

      CALL RESID (IUO,A,B,NX,G,SIGUWT)

*** LIST ADJUSTED AUXILIARY PARAMETERS

*     IF (NAUX.GT.0) CALL ADJAUX (A,NX,GOOGE,B,SIGUWT)

*** LIST ADJUSTED CRUSTAL DEFORMATION PARAMETERS

      IF (NCD.GT.0) CALL ADJGRD (A,NX,B,SIGUWT)

*** WRITE COVARIANCE MATRIX FOR STRAIN PARAMETERS

      IF( NCD.GT.0) CALL STRERR (A,NX,SIGUWT)

*** LIST THE RESIDUALS GROUPED AROUND INTERSECTION STATIONS

*     IF (IMODE.NE.0) CALL RESID2 (IUO,A,B,NX,G,SIGUWT)

*** LIST ADJUSTED POSITIONS AND SHIFTS

      CALL ADJPOS (A,B,NX,SHIFTS,GOOGE,SIGUWT)

*** COMPUTE ACCURACIES

      CALL ACCUR (A,NX,B,SHIFTS,SIGUWT)

*** UPDATE CONTROL POINT RECORDS

      IF (LUP) CALL UPDAT (B)

      RETURN
      END
      SUBROUTINE JOBSTT

*** LIST THE JOB STATISTICS

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD
      COMMON /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ,
     &                NREJ,NGPSR

*** HEADING

      CALL HEAD
      WRITE (6,1)
1     FORMAT ('0*** JOB STATISTICS ***',/)

*** PRINT STATS

      WRITE (6,2) NSTA,N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,
     &            NCON,NQQ,NREJ
2     FORMAT (  '0A.) BLUE-BOOK STATISTICS',/,
     &        T10,   'NO. *80* CONTROL RECORDS',I10,/,
     &        T10,   'NO. *84* GEOID HT. RECORDS',I8,/,
     &        T10,   'NO. *85* DEFLECTION RECORDS',I7,/,
     &        T10,   'NO. *86* ELEVATION RECORDS', I8,/,
     &        T10,   'NO. *89* ASTRO. COORD. RECORDS',I4,/,
     &        T10,   'NO. DIRECTIONS',I20,/,
     &        T10,   'NO. ANGLES',I24,/,
     &        T10,   'NO. GPS VECTORS',I19,/,
     &        T10,   'NO. ZENITH DISTANCES',I14,/,
     &        T10,   'NO. DISTANCES',I21,/,
     &        T10,   'NO. AZIMUTHS',I22,/,
     &        T2,'B.) NO. CONSTRAINTS',I23,/,
     &        T2,'C.) NO. ACCURACIES',I24,/,
     &        T2,'D.) NO. REJECTED OBS.',I21)

      RETURN
      END
      SUBROUTINE ADJPOS (A,B,NX,SHIFTS,GOOGE,SIGUWT)

*** LIST ADJUSTED POSITIONS

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      PARAMETER (MXSSN = 9999)
      LOGICAL LBB,LGF,LCS,LVD,LVA,LVZ,LVS,
     &        LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP
      LOGICAL LOCSSN,GETA
      LOGICAL LMSL,LSS,LUP
      CHARACTER*1 ADIR1,ADIR2,ADX,ADY
      CHARACTER*30 NAMES,NAME
      DIMENSION A(*),B(*),NX(*),SHIFTS(*),GOOGE(*)
      COMMON /NAMTAB/ NAMES(MXSSN)
      COMMON /OPRINT/ CRIT,LBB,LGF,LCS,LVD,LVA,LVZ,LVS,
     &                LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP
      COMMON /OPT/ AX,E2,DMSL,DGH,VM,VP,CTOL,ITMAX,ITMIN,IMODE,
     &             LMSL,LSS,LUP
      COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD
      COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI

*** HEADING

      IF (.NOT.LAP) RETURN
      CALL HEAD3
      NLINE = 2
      IF (LPS) NLINE = NLINE + 1
      IF (IMODE.GE.2) NLINE = NLINE + 1
      IF (LPG) NLINE = NLINE + 1

*** GET POSITIONS

      OPEN(42, FILE = 'elps', STATUS = 'UNKNOWN')
      DO 2 ISN = 1,NSTA
        CALL GETGLA (GLAT,ISN,B)
        CALL GETGLO (GLON,ISN,B)
        CALL GETMSL (GMSL,ISN,B)
        CALL GETGH (GHT,ISN,B)
        EHT = GMSL + GHT
        CALL RADCUR (GLAT,RMER,RPV) 
        RX = RMER + EHT
        RY = (RPV + EHT) * DCOS(GLAT)
        NAME = NAMES(ISN)
        CALL GETDMS (GLAT,ID1,IM1,S1,ISIGN)
        IF (ISIGN.GT.0) THEN
          ADIR1 = 'N'
        ELSE
          ADIR1 = 'S'
        ENDIF
        CALL GETDMS (GLON,ID2,IM2,S2,ISIGN)
        IF (ISIGN.GT.0) THEN
          ADIR2 = 'E'
        ELSE
          ADIR2 = 'W'
        ENDIF
        IF ( .NOT.LOCSSN(ISN,ISSN) ) THEN
          WRITE (6,666) ISN
  666     FORMAT ('0SSN TABLE ERROR IN ADJPOS--',I5)
          CALL ABORT2
        ENDIF

        CALL LINE3 (NLINE)
        WRITE (6,3) ISN,ISSN,NAME,ID1,IM1,S1,ADIR1,
     &              ID2,IM2,S2,ADIR2,GMSL,GHT,EHT
    3   FORMAT ('0', I5, I5, 1X, A30,    2I3, F9.5, A1,
     +          1X, I4, I3, F9.5, A1, 2X, F8.3, F9.3, F10.3)

*** PRINT VELOCITIES IF ENABLED AND PRINT ERROR ELLIPSES

        IF(NCD .GT. 0) THEN
           CALL VELOC(GLAT,GLON,B,VN,VE,VU,SN,SE,CORR,A,NX,SIGUWT)
           WRITE(6,20) VN, VE, VU
   20      FORMAT(10X,'VELOCITY IN MM/YR: NORTH = ',F7.2,
     &       3X,' EAST = ',F7.2,3X,' UP = ',F7.2)
           WRITE(6,25) SN, SE, CORR 
   25      FORMAT(10X,'VELOCITY ERRORS:   NORTH = ',F7.4,
     &       3X,' EAST = ',F7.4,3X,'CORR = ',F7.4)
           WRITE(42,43) NAME,ID1,IM1,S1,ID2,IM2,S2,VN,VE,
     &                  VU,SN,SE,CORR
   43      FORMAT(A6,I3,I3,F9.5,I4,I3,F9.5,6F9.5)
        ENDIF

*** PRINT SHIFTS IF ENABLED

        IF (LPS) THEN
          IF (IMODE.NE.0) THEN
            I1 = IUNSHF(ISN,1)
            I2 = IUNSHF(ISN,2)
            I3 = IUNSHF(ISN,3)
            DX = SHIFTS(I1)
            DY = SHIFTS(I2)
            DZ = SHIFTS(I3)
            DX2 = DX * DX
            DY2 = DY * DY
            DH = DSQRT(DX2 + DY2)
            IF ( DABS(DX) .LE. 1.D-3 .OR. DABS(DY) .LE. 1.D-3 ) THEN
              IAZ = 0
            ELSE
              IAZ = DATAN2(DY,DX) * RAD + 0.5D0
              IF (IAZ.LT.0) IAZ = IAZ + 360
            ENDIF
            DTOT = DSQRT(DX2 + DY2 + DZ * DZ)
            IF (DX.LT. 0.D0 ) THEN
              DX = -DX
              ADX = 'S'
            ELSE
              ADX = 'N'
            ENDIF
            IF (DY.LT. 0.D0 ) THEN
              DY = -DY
              ADY = 'W'
            ELSE
              ADY = 'E'
            ENDIF
            WRITE (6,4) DX,ADX,DY,ADY,DZ,IAZ,DH,DTOT
    4       FORMAT (32X, 'SHIFTS (M.)', 4X, F8.3, A1, 9X, F8.3, A1, 22X,
     +              F8.3, ' AZ=', I3, ' HOR=', F5.1, ' TOT=', F5.1)
          ENDIF
        ENDIF

*** PRINT INVERSE ELEMENTS IF ENABLED

        IF (IMODE.NE.1) THEN
          IX = IUNSTA(ISN,1)
          IY = IUNSTA(ISN,2)
          IZ = IUNSTA(ISN,3)
          IF ( .NOT.GETA(IX,IX,SX,A,NX) ) THEN
            WRITE (6,667) ISN,IX
  667       FORMAT ('0GET SIGMA ERROR IN ADJPOS--',2I5)
            CALL ABORT2
          ENDIF
          IF ( .NOT.GETA(IY,IY,SY,A,NX) ) THEN
            WRITE (6,667) ISN,IY
            CALL ABORT2
          ENDIF
          IF ( .NOT.GETA(IZ,IZ,SZ,A,NX) ) THEN
            WRITE (6,667) ISN,IZ
            CALL ABORT2
          ENDIF
          SX = DSQRT(SX)
          SY = DSQRT(SY)
          SZ = DSQRT(SZ)

*** CHANGE LAT AND LONG STANDARD DEV. FROM SECONDS TO METERS

          SX = ( SX / RADSEC ) * RX
          SY = ( SY / RADSEC ) * RY

          IF (LSS) THEN
            SX = SX * SIGUWT
            SY = SY * SIGUWT
            SZ = SZ * SIGUWT
            WRITE (6,5) SX,SY,SZ
    5       FORMAT (25X, 'SCALED SIGMAS (M.)', 4X, F8.3, 10X, F8.3, 23X,
     +              F8.3)
          ELSE
            WRITE (6,9) SX,SY,SZ
    9       FORMAT (23X, 'UNSCALED SIGMAS (M.)', 4X, F8.3, 10X, F8.3,
     +              T94, F8.3)
          ENDIF
        ENDIF

*** PRINT GOOGE NUMBERS IF ENABLED

        IF (LPG) THEN
          IX = IUNSTA(ISN,1)
          IY = IUNSTA(ISN,2)
          IZ = IUNSTA(ISN,3)
          WRITE (6,6) GOOGE(IX),GOOGE(IY),GOOGE(IZ)
    6     FORMAT (32X, 'GOOGES', 11X, 1PD8.1, 10X, 1PD8.1, 23X, 1PD8.1)
	  WRITE (6,*) '0------------------------------------'
        ENDIF
    2 CONTINUE
      CLOSE(42, STATUS = 'KEEP')

      RETURN
      END
      SUBROUTINE ACCUR (A,NX,B,SHIFTS,SIGUWT)

*** COMPUTE AND LIST ACCURACIES

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      CHARACTER*80 CARD
      CHARACTER*2 CC12
      LOGICAL GETSSN
      LOGICAL LMSL,LSS,LUP
      DIMENSION A(*),NX(*),B(*),SHIFTS(*)
      COMMON /OPT/ AX,E2,DMSL,DGH,VM,VP,CTOL,ITMAX,ITMIN,IMODE,
     &             LMSL,LSS,LUP

*** DO NOT COMPUTE ACCURACIES UNLESS INVERSE COMPUTED

      IF (IMODE.NE.1) THEN
        IUNIT = 1
        OPEN (IUNIT,ERR=200,STATUS='OLD',FILE='AFILE',IOSTAT=IOS,
     &        BLANK='ZERO')
        CALL HEAD4

***** LOOP OVER ADJUSTMENT FILE FOR ACCURACY CARDS (QQ)

  100   READ (IUNIT,1,END = 777) CARD
    1   FORMAT (A80)
        CC12 = CARD(1:2)

        IF (CC12.EQ.'QQ') THEN
          READ (CARD,2) ISSN,JSSN
    2     FORMAT (10X,I4,36X,I4)
          IF ( GETSSN(ISSN,ISN) .AND. GETSSN(JSSN,JSN) ) THEN
            CALL RELACC (ISSN,JSSN,ISN,JSN,A,NX,B,SHIFTS,SIGUWT)
          ENDIF
        ENDIF
        GO TO 100

  777   CLOSE (IUNIT)
        CALL LINE4 (2)
        WRITE (6,3)
    3   FORMAT ('0************ END OF ACCURACY PROCESSING **********')
  200   CONTINUE
      ENDIF

      RETURN
      END
      SUBROUTINE UPDAT (B)

*** UPDATE CONTROL PT RECORDS

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      CHARACTER*80 CARD
      CHARACTER*2 BBID
      CHARACTER*7 BBNAM
      DIMENSION B(*)
      COMMON /NAME/ BBNAM
      COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD

*** OPEN OLD BLUE BOOK

      IOLD = 2
      OPEN (IOLD,ERR=666,STATUS='OLD',FILE='BBOOK',BLANK='ZERO')

*** OPEN NEW BLUE BOOK

      INEW = 4
C     OPEN (INEW,ERR=667,STATUS='NEW',FILE=BBNAM)
      OPEN (INEW,ERR=667,STATUS='UNKNOWN',FILE=BBNAM)

*** READ THE BLUE BOOK RECORDS

  100 READ (IOLD,1,END = 668) CARD
    1 FORMAT (A80)
      BBID = CARD(8:9)

      IF (BBID.EQ.'80') THEN
        CALL UP80 (CARD,B)
      ELSEIF (BBID.EQ.'84') THEN
        IF (IDIM.NE.2) CALL UP84 (CARD,B)
      ELSEIF (BBID.EQ.'86') THEN
        CALL UP86 (CARD,B)
      ENDIF

      WRITE (INEW,2) CARD
    2 FORMAT (A80)
      GO TO 100

 668  CLOSE (IOLD)
      CLOSE (INEW)
      CALL LINE (2)
      WRITE (6,5) BBNAM
  5   FORMAT ('0UPDATED CONTROL POINT RECORDS IN FILE -- ',A7)
      RETURN

*** NO OLD BLUE BOOK FOUND

 666  WRITE (6,699)
 699  FORMAT ('0ERROR - NO OLD BLUE BOOK FOUND',/)
      CALL ABORT2
      RETURN

*** NOT ABLE TO OPEN NEW BB FILE

 667  WRITE (6,698)
 698  FORMAT ('0ERROR - NOT ABLE TO OPEN NEW BLUE BOOK FILE',/)
      CALL ABORT2

      RETURN
      END
      SUBROUTINE UP80 (CARD,B)

*** UPDATE THE *80* CONTROL PT RECORD

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      PARAMETER (MXSSN = 9999)
      CHARACTER*80 CARD
      CHARACTER*1 ADIR1,ADIR2
      CHARACTER*2 AD1,AM1,AM2
      CHARACTER*3 AD2
      CHARACTER*6 AMSL
      CHARACTER*7 AS1,AS2
      LOGICAL ELFLAG,DFFLAG,GETSSN
      DIMENSION B(*)
      COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD
      COMMON /FLAGS/ ELFLAG(MXSSN),DFFLAG(MXSSN)

      READ (CARD,1) ISSN
    1 FORMAT (10X,I4)

*** UPDATE LAT. AND LONG.

      IF ( GETSSN(ISSN,ISN) ) THEN
        IF (IDIM.NE.1) THEN
          CALL GETGLA (GLAT,ISN,B)
          CALL GETGLO (GLON,ISN,B)
          CALL VERDMS (GLAT,ID1,IM1,S1,ISIGN)
          IF (ISIGN.GT.0) THEN
            ADIR1 = 'N'
          ELSE
            ADIR1 = 'S'
          ENDIF
          CALL VERDMS (GLON,ID2,IM2,S2,ISIGN)
          IF (ISIGN.GT.0) THEN
            ADIR2 = 'E'
          ELSE
            ADIR2 = 'W'
          ENDIF
          IS1 = S1 * 100000.D0
          IS2 = S2 * 100000.D0

          WRITE (AD1,4) ID1
          WRITE (AM1,4) IM1
          WRITE (AS1,2) IS1
          WRITE (AD2,3) ID2
          WRITE (AM2,4) IM2
          WRITE (AS2,2) IS2
    4     FORMAT (I2.2)
    2     FORMAT (I7.7)
    3     FORMAT (I3.3)

          CARD(45:46) = AD1
          CARD(47:48) = AM1
          CARD(49:55) = AS1
          CARD(56:56) = ADIR1
          CARD(57:59) = AD2
          CARD(60:61) = AM2
          CARD(62:68) = AS2
          CARD(69:69) = ADIR2
        ENDIF

*** UPDATE HEIGHT

        IF ( ELFLAG(ISN) .AND. IDIM.NE.2) THEN
          CALL GETMSL (GMSL,ISN,B)
          MSL = GMSL * 100.D0
          WRITE (AMSL,5) MSL
    5     FORMAT (I6.3)
          CARD(70:75) = AMSL
        ENDIF

      ELSE
        WRITE (6,666) CARD
 666    FORMAT ('0ERROR - ILLEGAL ISN IN UP80--',A80)
        CALL ABORT2
      ENDIF

      RETURN
      END
      SUBROUTINE UP84 (CARD,B)

*** UPDATE *84* GEOID HEIGHT RECORDS

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      PARAMETER (MXSSN = 9999)
      CHARACTER*80 CARD
      CHARACTER*5 AGH
      LOGICAL ELFLAG,DFFLAG,GETSSN
      DIMENSION B(*)
      COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD
      COMMON /FLAGS/ ELFLAG(MXSSN),DFFLAG(MXSSN)

      READ (CARD,1) ISSN
    1 FORMAT (10X,I4)
      IF ( GETSSN(ISSN,ISN) ) THEN
        IF ( .NOT.ELFLAG(ISN) .AND. IDIM.NE.2 ) THEN
          CALL GETGH (GGH,ISN,B)
          IGH = GGH * 10.D0
          WRITE (AGH,5) IGH
    5     FORMAT (I5.2)
          CARD(72:76) = AGH
        ENDIF
      ELSE
        WRITE (6,666) CARD
 666    FORMAT ('0ERROR - ILLEGAL ISN IN UP84--',A80)
        CALL ABORT2
      ENDIF

      RETURN
      END
      SUBROUTINE UP86 (BCARD, B)

*** UPDATE *86* ELEVATION RECORDS

      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      IMPLICIT INTEGER (I-N)
      PARAMETER (MXSSN = 9999)
      CHARACTER*80 BCARD
      CHARACTER*7 AGH, AMSL
      LOGICAL ELFLAG, DFFLAG, GETSSN
      DIMENSION B(*)
      COMMON /FLAGS/  ELFLAG(MXSSN), DFFLAG(MXSSN)

      READ (BCARD,1) ISSN
    1 FORMAT (10X, I4)
      IF (GETSSN(ISSN, ISN) ) THEN
        IF (ELFLAG(ISN) ) THEN
          CALL GETMSL (GMSL, ISN, B)
          MSL = IDNINT(GMSL*1000.D0)
          WRITE (AMSL,3) MSL
    3     FORMAT (I7.3)
          BCARD(17:23) = AMSL
        ELSE
          CALL GETGH (GGH, ISN, B)
          IGH = IDNINT(GGH*1000.D0)
          WRITE (AGH,3) IGH
          BCARD(35:41) = AGH
        ENDIF

*** ELLIPSOIDAL HEIGHT NOT UPDATED

      ELSE
        WRITE (*,666) BCARD
  666   FORMAT ('0ILLEGAL ISN IN UP86--', A80)
        CALL ABORT2
      ENDIF

      RETURN
      END
      SUBROUTINE RELACC (ISSN,JSSN,ISN,JSN,A,NX,B,SHIFTS,SIGUWT)

*** COMPUTE RELATIVE ACCURACIES ON SPHERE

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)

*** THE VALUE OF VBIG IS MACHINE DEPENDENT - IT IS THE LARGEST INTEGER

      PARAMETER ( VBIG = 2147483647.D0, IVBIG = 2147483647 )
      PARAMETER (MXSSN = 9999)
      LOGICAL PROP
      LOGICAL LMSL,LSS,LUP
      CHARACTER*30 NAMES,NAME1,NAME2
      CHARACTER*1 A2
      DIMENSION A(*),NX(*),B(*),SHIFTS(*)
      DIMENSION IC(31),C(31)
      COMMON /NAMTAB/ NAMES(MXSSN)
      COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI
      COMMON /OPT/ AX,E2,DMSL,DGH,VM,VP,CTOL,ITMAX,ITMIN,IMODE,
     &             LMSL,LSS,LUP
      COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD
      COMMON /CDGRID/ GRDLX,GRDUX,GRDLY,GRDUY,ICNTX,ICNTY,ITREF

*** DISTANCE IS KIND = 7

      IAUX = 0
      KIND = 7
      CALL FORMIC (KIND,ISN,JSN,IAUX,IC,LENG,B)
      CALL FORMC (KIND,C,B,ISN,JSN,IAUX,ITREF)
      CALL COMPIC (IC,C,LENG)
      CALL COMPOB (KIND,DIST,B,DUMMY,ISN,JSN,IAUX,ITREF)
      IF ( .NOT.PROP(C,IC,LENG,VARDST,A,NX,IFLAG) ) THEN
        IF (IFLAG.EQ.1) THEN
          WRITE (6,666)
  666     FORMAT ('0STATE ERROR IN RELACC')
          CALL ABORT2
        ELSE
          WRITE (6,667)
  667     FORMAT ('0PROFILE ERROR IN RELACC')
          CALL ABORT2
        ENDIF
      ENDIF

*** AZIMUTH IS KIND = 8

      KIND = 8
      CALL FORMIC (KIND,ISN,JSN,IAUX,IC,LENG,B)
      CALL FORMC (KIND,C,B,ISN,JSN,IAUX,ITREF)
      CALL COMPIC (IC,C,LENG)
      CALL COMPOB (KIND,AZM,B,DUMMY,ISN,JSN,IAUX,ITREF)
      CALL DIRDMS (AZM,ID1,IM1,S1)
      IF ( .NOT.PROP(C,IC,LENG,VARAZM,A,NX,IFLAG) ) THEN
        IF (IFLAG.EQ.1) THEN
          WRITE (6,666)
          CALL ABORT2
        ELSE
          WRITE (6,667)
          CALL ABORT2
        ENDIF
      ENDIF

*** ZENITH DISTANCE IS KIND = 9

      KIND = 9
      CALL FORMIC (KIND,ISN,JSN,IAUX,IC,LENG,B)
      CALL FORMC (KIND,C,B,ISN,JSN,IAUX,ITREF)
      CALL COMPIC (IC,C,LENG)
      DO 10 I = 1,LENG
        C(I) = -C(I)
 10   CONTINUE
      CALL COMPOB (KIND,VERANG,B,DUMMY,ISN,JSN,IAUX,ITREF)
      VERANG = PI2 - VERANG
      CALL GETDMS (VERANG,ID2,IM2,S2,ISIGN)
      IF (ISIGN.GT.0) THEN
        A2 = 'E'
      ELSE
        A2 = 'D'
      ENDIF
      IF ( .NOT.PROP(C,IC,LENG,VARVER,A,NX,IFLAG) ) THEN
        IF (IFLAG.EQ.1) THEN
          WRITE (6,666)
          CALL ABORT2
        ELSE
          WRITE (6,667)
          CALL ABORT2
        ENDIF
      ENDIF

      SD = DSQRT(VARDST)
      SA = DSQRT(VARAZM) * RADSEC
      SV = DSQRT(VARVER) * RADSEC
      IF (LSS) THEN
        SD = SD * SIGUWT
        SA = SA * SIGUWT
        SV = SV * SIGUWT
      ENDIF
      REL1 = (DIST / SD)
      IF (REL1 .GT. VBIG) THEN
        IREL1 = IVBIG
      ELSE
        IREL1 = IDINT(REL1)
      ENDIF

      DELX = SHIFTS( IUNSHF(JSN,1) ) - SHIFTS( IUNSHF(ISN,1) )
      DELY = SHIFTS( IUNSHF(JSN,2) ) - SHIFTS( IUNSHF(ISN,2) )
      SHIFT = DSQRT(DELX * DELX + DELY * DELY)
      IF (SHIFT.LT. 0.0001D0 ) SHIFT = 0.0001D0
      REL2 = (DIST / SHIFT)
      IF (REL2 .GT. VBIG) THEN
        IREL2 = IVBIG
      ELSE
        IREL2 = IDINT(REL2)
      ENDIF
      IF (IMODE.EQ.0) IREL2 = 0
      NAME1 = NAMES(ISN)
      NAME2 = NAMES(JSN)
      SADST = DIST * SA / RADSEC
      SVDST = DIST * SV / RADSEC

*** PRINT RESULTS

      CALL LINE4 (5)

      WRITE (*,1) ISSN, NAME1, JSSN, NAME2
    1 FORMAT ('0FROM: (', I5, ')  ', A30, '    TO: (', I5, ')  ', A30)
      WRITE (*,2) DIST, SD, IREL1, SHIFT, IREL2
    2 FORMAT (9X, 'DISTANCE=', 12X, F13.3, 2X, 'SIGMA=', F9.4, ' M.',
     &        5X, 'ACC. 1:', I8, 5X, 'HOR. SHIFT=', F7.2, '   1:', I12)
      WRITE (*,3) ID1, IM1, S1, SA, SADST
    3 FORMAT (9X, 'AZIMUTH=', 3X, I4, I3, F6.2, 3X, 'SIGMA=', F5.2,
     &        ' SEC./OR', F7.4, ' M.')
      WRITE (*,4) ID2, IM2, S2, A2, SV, SVDST
    4 FORMAT (9X, 'VERT.ANG.=', 2X, I4, I3, F6.2, A1, 2X, 'SIGMA=',
     &        F5.2, ' SEC./OR', F7.4, ' M.')

      RETURN
      END
