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