SUBROUTINE SECBB (IUNIT,IUO,IOBS,B,NX,FATAL) *** FORM OBS EQ. FOR NON-GPS BB RECORDS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD CHARACTER*2 IRT LOGICAL LDIR,LANG,LZEN,LDIS,LAZI,LGPS LOGICAL LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP LOGICAL FATAL,LSN DIMENSION B(*),NX(*) COMMON /OPRINT/ CRIT,LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP COMMON /BYPASS/ LDIR,LANG,LZEN,LDIS,LAZI,LGPS *** PRINT HEADING, THEN PROCESS BBOOK IF (LBB) THEN CALL HEAD CALL LINE (4) WRITE (6,3) 3 FORMAT (' ************ BLUE BOOK ************',/, & '0 OBS #',/) ENDIF *** LOOP OVER RECORDS OF BLUE BOOK 100 READ (IUNIT,2,END = 777) CARD 2 FORMAT (A80) IRT = CARD(8:9) LSN = .FALSE. IF (IRT.EQ.'20' .OR. IRT.EQ.'22') THEN IF (.NOT.LDIR) CALL HORDIR (CARD,IUO,IOBS,B,NX,FATAL,LSN) ELSEIF (IRT.EQ.'30' .OR. IRT.EQ.'32') THEN IF (.NOT.LANG) CALL HORANG (CARD,IUO,IOBS,B,NX,FATAL,LSN) ELSEIF (IRT.EQ.'40' .OR. IRT.EQ.'42') THEN IF (.NOT.LZEN) CALL VERTAN (CARD,IUO,IOBS,B,NX,FATAL,LSN) ELSEIF (IRT.EQ.'52' .OR. IRT.EQ.'54') THEN IF (.NOT.LDIS) CALL DISTOB (CARD,IUO,IOBS,B,NX,FATAL,LSN) ELSEIF (IRT.EQ.'60') THEN IF (.NOT.LAZI) CALL ASTRAZ (CARD,IUO,IOBS,B,NX,FATAL,LSN) ENDIF *** ECHO THE BLUE BOOK OBSERVATIONS IF (LBB) CALL ECHOBB (CARD,IOBS,LSN) GO TO 100 *** END OF PROCESSING -- END OF FILE ENCOUNTERED *** 777 IF (LBB) THEN CALL LINE (2) WRITE (6,4) 4 FORMAT (' ******** END OF BLUE BOOK ********') ENDIF RETURN END SUBROUTINE ECHOBB (CARD,IOBS,LSN) *** ECHO THE BLUE BOOK RECORDS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD LOGICAL LSN,LBV LOGICAL LEB,LLB,LEG,LLG COMMON /PECHO/ LEB,LLB,LEG,LLG COMMON /ECHO/ VSD,LBV *** ECHO ALL OF THE BLUE BOOK IF (.NOT.LEB) THEN IF (.NOT.LLB) THEN IF (LSN) THEN IF (CARD(6:6).NE.'R') THEN IF (LBV) THEN CALL LINE (1) WRITE (6,1) IOBS,CARD,VSD 1 FORMAT (1X,I6,3X,A80,F10.1, & ' *** WARNING - LARGE MISCLOSURE') ELSE CALL LINE (1) WRITE (6,3) IOBS,CARD 3 FORMAT (1X,I6,3X,A80) ENDIF ELSE CALL LINE (1) WRITE (6,2) CARD ENDIF ELSE CALL LINE (1) WRITE (6,2) CARD 2 FORMAT (10X,A80) ENDIF ENDIF ENDIF *** ECHO OBSERVATIONS ONLY IF (LEB) THEN IF (LSN) THEN IF (CARD(6:6).NE.'R') THEN IF (LBV) THEN CALL LINE (1) WRITE (6,1) IOBS,CARD,VSD ELSE CALL LINE (1) WRITE (6,3) IOBS,CARD ENDIF ENDIF ENDIF ENDIF *** ECHO LARGE MISCLOSURES ONLY IF (LLB) THEN IF (LSN) THEN IF (CARD(6:6).NE.'R') THEN IF (LBV) THEN CALL LINE (1) WRITE (6,1) IOBS,CARD,VSD ENDIF ENDIF ENDIF ENDIF RETURN END SUBROUTINE HORDIR (CARD,IUO,IOBS,B,NX,FATAL,LSN) *** OBSERVATION EQUATIONS FOR HORIZONTAL DIRECTIONS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD CHARACTER*13 DATE CHARACTER*4 ASS LOGICAL FATAL,LSN LOGICAL GETSSN,GETZ,GETIVF LOGICAL ADDCON LOGICAL LMSL,LSS,LUP DIMENSION IC(31),C(31) DIMENSION B(*),NX(*) 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 /IZS/ IZ2 COMMON /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ, & NREJ,NGPSR SAVE ITIME READ (CARD,1) IRT,ISSN,LIST,JSSN,ID,IM,ASS 1 FORMAT (7X,I2, 1X,I4, I2,34X,I4, 9X,I3,I2,A4) CALL NBLANK (ASS,4,IBLK) READ (ASS,3) SS 3 FORMAT (F4.2) IF (IRT.EQ.20) THEN DATE = CARD(38:50) CALL TRNDAT(DATE,ITIME) ENDIF IF (CARD(6:6).EQ.'O') NREJ = NREJ + 1 IF ( CARD( 6: 6).NE.'O' ) THEN IF ( .NOT.GETSSN(ISSN,ISN) ) THEN CALL LINE (3) WRITE (6,2) CARD 2 FORMAT ('0ERROR - NO *80* RECORD FOR--',A80,/) ELSEIF ( .NOT.GETSSN(JSSN,JSN) ) THEN CALL LINE (3) WRITE (6,2) CARD ELSE *** RETRIEVE THE STD DEV CALL STDDEV (CARD,IRT,SD) *** KIND = 11 HORIZONTAL DIRECTION IF ( .NOT.GETZ(ISSN,LIST,IZ) ) RETURN OBSB = (ID + IM / 60.D0 + SS / 3600.D0) / RAD IF (IZ.NE.IZ2) CALL STOREZ (ISN,JSN,B,IZ,OBSB,ITIME) KIND = 11 IOBS = IOBS + 1 NOBS = NOBS + 1 NDIR = NDIR + 1 LSN = .TRUE. IF ( .NOT.GETIVF(20,ITIME,IVF) ) IVF = 0 CALL FORMIC (KIND,ISN,JSN,IZ,IC,LENG,B) CALL FORMC (KIND,C,B,ISN,JSN,IZ,ITIME) CALL COMPIC (IC,C,LENG) CALL COMPOB (KIND,OBS0,B,OBSB,ISN,JSN,IZ,ITIME) CMO = OBS0 - OBSB IF (CMO.GT.PI) THEN CMO = CMO - TWOPI ELSEIF (CMO.LT.-PI) THEN CMO = CMO + TWOPI ENDIF IF (IMODE.EQ.0) CMO = 0.D0 CALL BIGV (KIND,ISN,JSN,IOBS,IVF,CMO,SD,FATAL) *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) 667 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR HORIZONTAL', & ' DIRECTIONS',/) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IZ,ITIME ENDIF ENDIF RETURN END SUBROUTINE STOREZ (ISN,JSN,B,IZ,OBSB,ITIME) *** STORE THE ROTATION PARM IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) DIMENSION B(*) COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI COMMON /IZS/ IZ2 KIND = 8 CALL COMPOB (KIND,OBS0,B,OBSB,ISN,JSN,IAUX,ITIME) ROT = OBS0 - OBSB 1 IF (ROT.GE.TWOPI) THEN ROT = ROT - TWOPI GO TO 1 ENDIF 2 IF (ROT.LT.0.D0) THEN ROT = ROT + TWOPI GO TO 2 ENDIF CALL PUTROT (ROT,IZ,B) IZ2 = IZ RETURN END SUBROUTINE HORANG (CARD,IUO,IOBS,B,NX,FATAL,LSN) *** OBSERVATION EQUATIONS FOR HORIZONTAL ANGLES IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD CHARACTER*13 DATE CHARACTER*3 ASS LOGICAL LMSL,LSS,LUP LOGICAL GETSSN,ADDCON,GETIVF LOGICAL FATAL,LSN DIMENSION IC(31),C(31) DIMENSION B(*),NX(*) 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 /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ, & NREJ,NGPSR SAVE ITIME READ (CARD,1) IRT,ISSN,JSSN,ID,IM,ASS,KSSN 1 FORMAT (7X,I2, 1X,I4,36X,I4, 9X,I3,I2,A3,I4) CALL NBLANK (ASS,3,IBLK) READ (ASS,3) SS 3 FORMAT (F3.1) IF (IRT.EQ.30) THEN DATE = CARD(38:50) CALL TRNDAT(DATE, ITIME) ENDIF IF (CARD(6:6).EQ.'O') NREJ = NREJ + 1 IF ( CARD(6:6).NE.'O' ) THEN IF ( .NOT.GETSSN(ISSN,ISN) ) THEN CALL LINE (3) WRITE (6,2) CARD 2 FORMAT ('0ERROR - NO *80* RECORD FOR--',A80,/) ELSEIF ( .NOT.GETSSN(JSSN,JSN) ) THEN CALL LINE (3) WRITE (6,2) CARD ELSEIF ( .NOT.GETSSN(KSSN,KSN) ) THEN CALL LINE (3) WRITE (6,2) CARD ELSE *** RETRIEVE THE STD DEV CALL STDDEV (CARD,IRT,SD) *** KIND = 10 HORIZONTAL ANGLES KIND = 10 IOBS = IOBS + 1 NOBS = NOBS + 1 NANG = NANG + 1 LSN = .TRUE. OBSB = (ID + IM / 60.D0 + SS / 3600.D0) / RAD IF ( .NOT.GETIVF(30,ITIME,IVF) ) IVF = 0 CALL FORMIC (KIND,ISN,JSN,KSN,IC,LENG,B) CALL FORMC (KIND,C,B,ISN,JSN,KSN,ITIME) CALL COMPIC(IC,C,LENG) CALL COMPOB (KIND,OBS0,B,OBSB,ISN,JSN,KSN,ITIME) CMO = OBS0 - OBSB IF (CMO.GT.PI) THEN CMO = CMO - TWOPI ELSEIF (CMO.LT.-PI) THEN CMO = CMO + TWOPI ENDIF IF (IMODE.EQ.0) CMO = 0.D0 CALL BIGV (KIND,ISN,JSN,IOBS,IVF,CMO,SD,FATAL) *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) 667 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR HORIZONTAL', & ' ANGLES',/) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,KSN,ITIME ENDIF ENDIF RETURN END SUBROUTINE VERTAN (CARD,IUO,IOBS,B,NX,FATAL,LSN) *** OBSERVATION EQUATIONS FOR ZENITH DISTANCES IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD CHARACTER*13 DATE CHARACTER*3 ASS LOGICAL FATAL,LSN LOGICAL GETSSN,GETPRM,GETIVF LOGICAL ADDCON LOGICAL LMSL,LSS,LUP DIMENSION B(*),NX(*) DIMENSION IC(31),C(31) 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 /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ, & NREJ,NGPSR SAVE DATE READ (CARD,1) IRT,ISSN,JSSN,ID,IM,ASS 1 FORMAT (7X,I2, 1X,I4,36X,I4, 9X,I3,I2,A3) CALL NBLANK (ASS,3,IBLK) READ (ASS,3) SS 3 FORMAT (F3.1) IF (IRT.EQ.40) THEN DATE = CARD(38:50) ELSE DATE(9:13) = CARD(46:50) ENDIF CALL TRNDAT(DATE, ITIME) IF (CARD(6:6).EQ.'O') NREJ = NREJ + 1 IF ( CARD( 6: 6).NE.'O' ) THEN IF ( .NOT.GETSSN(ISSN,ISN) ) THEN CALL LINE (3) WRITE (6,2) CARD 2 FORMAT ('0ERROR - NO *80* RECORD FOR--',A80,/) ELSEIF ( .NOT.GETSSN(JSSN,JSN) ) THEN CALL LINE (3) WRITE (6,2) CARD ELSE *** RETRIEVE THE STD DEV CALL STDDEV (CARD,IRT,SD) *** KIND = 9 ZENITH DISTANCE KIND = 9 IOBS = IOBS + 1 NOBS = NOBS + 1 NZD = NZD + 1 LSN = .TRUE. OBSB = (ID + IM / 60.D0 + SS / 3600.D0) / RAD IF ( .NOT.GETPRM(40,ITIME,IAUX) ) IAUX = 0 IF ( .NOT.GETIVF(40,ITIME,IVF) ) IVF = 0 CALL FORMIC (KIND,ISN,JSN,IAUX,IC,LENG,B) CALL FORMC (KIND,C,B,ISN,JSN,IAUX,ITIME) CALL COMPIC (IC,C,LENG) CALL COMPOB (KIND,OBS0,B,OBSB,ISN,JSN,IAUX,ITIME) CMO = OBS0 - OBSB IF (IMODE.EQ.0) CMO = 0.D0 CALL BIGV (KIND,ISN,JSN,IOBS,IVF,CMO,SD,FATAL) *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) 667 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR ZENITH', & ' DISTANCES',/) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ENDIF ENDIF RETURN END SUBROUTINE ASTRAZ (CARD,IUO,IOBS,B,NX,FATAL,LSN) *** OBSERVATION EQUATIONS FOR ASTRONOMIC AZIMUTHS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD CHARACTER*13 DATE CHARACTER*3 ASS CHARACTER*4 PVC LOGICAL FATAL,LSN LOGICAL GETSSN,GETIVF LOGICAL ADDCON LOGICAL LMSL,LSS,LUP DIMENSION IC(31),C(31) DIMENSION B(*),NX(*) 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 /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ, & NREJ,NGPSR READ (CARD,1) IRT,ISSN,PVC,AC,JSSN,ID,IM,ASS 1 FORMAT (7X,I2,1X,I4,A4,A1,31X,I4,9X,I3,I2,A3) CALL NBLANK (ASS,3,IBLK) READ (ASS,3) SS 3 FORMAT (F3.1) CALL NBLANK (PVC,3,IBLK) READ (PVC,4) ETA 4 FORMAT (F4.1) IF (CARD(19:19).EQ.'W') ETA = -ETA DATE = CARD(38:50) CALL TRNDAT(DATE, ITIME) IF (CARD(6:6).EQ.'O') NREJ = NREJ + 1 *** CHECK IF AZIMUTH ORIGIN IS NORTH OR SOUTH IF (CARD(72:72).EQ.'S') THEN IF (ID.GE.0 .AND. ID.LE.179) THEN ID=ID + 180 ELSEIF (ID.GE.180 .AND. ID.LE.359) THEN ID = ID - 180 ELSE WRITE (6,666) ID 666 FORMAT ('0ERROR - ILLEGAL AZIMUTH DEGREES = ',I4) CALL ABORT2 ENDIF ENDIF IF (CARD( 6: 6).NE.'O' ) THEN IF ( .NOT.GETSSN(ISSN,ISN) ) THEN CALL LINE (3) WRITE (6,2) CARD 2 FORMAT ('0ERROR - NO *80* RECORD FOR--',A80,/) ELSEIF ( .NOT.GETSSN(JSSN,JSN) ) THEN CALL LINE (3) WRITE (6,2) CARD ELSE *** RETRIEVE THE STD DEV CALL STDDEV (CARD,IRT,SD) *** KIND = 8 ASTRONOMIC AZIMUTH KIND = 8 IOBS = IOBS + 1 NOBS = NOBS + 1 NAZ = NAZ + 1 LSN = .TRUE. OBSB = (ID + IM / 60.D0 + SS / 3600.D0) / RAD *** CHANGE TO ASTRO AZ IF OBS IS LAPLACE AZIMUTH IF (AC .NE. 'A' .AND. CARD(15:19) .NE. ' ') THEN CALL GETGLA (GLA, ISN, B) OBSB = OBSB + DTAN(GLA)*( ETA/(3600.D0*RAD) ) ENDIF IF (OBSB.LT.0.D0) OBSB = OBSB + TWOPI IF (OBSB.GE.TWOPI) OBSB = OBSB - TWOPI IF ( .NOT.GETIVF(60,ITIME,IVF) ) IVF = 0 CALL FORMIC (KIND,ISN,JSN,IDUMMY,IC,LENG,B) CALL FORMC (KIND,C,B,ISN,JSN,IDUMMY,ITIME) CALL COMPIC (IC,C,LENG) CALL COMPOB (KIND,OBS0,B,OBSB,ISN,JSN,IDUMMY,ITIME) CMO = OBS0 - OBSB IF (CMO.GT.PI) THEN CMO = CMO - TWOPI ELSEIF (CMO.LT.-PI) THEN CMO = CMO + TWOPI ENDIF IF (IMODE.EQ.0) CMO = 0.D0 CALL BIGV (KIND,ISN,JSN,IOBS,IVF,CMO,SD,FATAL) *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) 667 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR LAPLACE', & ' AZIMUTHS',/) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ENDIF ENDIF RETURN END SUBROUTINE STDDEV (CARD,IRT,SD) *** DETERMINE THE STD DEV OF A OBSERVATION IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*3 AM,AMM CHARACTER*4 ASS CHARACTER*80 CARD COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI COMMON /VF/ VFACTR(31) *** NOT FULLY IMPLEMENTED YET *** STANDARD DEVIATIONS FOR DIRECTIONS, AZIMUTHS AND ZEN. DIST. IF ( IRT.EQ.20 .OR. IRT.EQ.22 .OR. & IRT.EQ.40 .OR. IRT.EQ.42 .OR. IRT.EQ.60 ) THEN IF (CARD(77:80).NE.' ') THEN READ (CARD,1) ASS 1 FORMAT (76X,A4) CALL NBLANK (ASS,4,IBLK) READ (ASS,2) SD 2 FORMAT (F4.2) SD = SD / RADSEC ELSE SD = 1.D0 / RADSEC ENDIF IF(IRT.EQ.20 .OR. IRT.EQ.22) THEN SD = SD * DSQRT(VFACTR(11)) ELSEIF (IRT.EQ.40 .OR. IRT.EQ.42) THEN SD = SD * DSQRT(VFACTR(9)) ELSEIF (IRT.EQ.60) THEN SD = SD * DSQRT(VFACTR(8)) ENDIF *** STD DEV FOR REDUCED DISTANCES ELSEIF (IRT.EQ.52) THEN IF (CARD(77:80).NE.' ') THEN READ (CARD,3) ASS 3 FORMAT (76X,A4) CALL NBLANK (ASS,4,IBLK) READ (ASS,4) SD 4 FORMAT (F4.1) SD = SD / 1000.D0 ELSE SD = 0.01D0 ENDIF SD = SD * DSQRT(VFACTR(7)) *** STD DEV FOR REDUCED LONG DISTANCES ELSEIF (IRT.EQ.54) THEN IF (CARD(78:80).NE.' ') THEN READ (CARD,5) AM 5 FORMAT (77X,A3) CALL NBLANK (AM,3,IBLK) READ (AM,6) SD 6 FORMAT (F3.2) ELSE SD = 0.1D0 ENDIF SD = SD * DSQRT(VFACTR(7)) *** STD DEV FOR HORIZONTAL ANGLES ELSEIF (IRT.EQ.30 .OR. IRT.EQ.32) THEN READ (CARD,7) AMM 7 FORMAT (68X,A3) CALL NBLANK (AMM,3,IBLK) IF (IBLK.EQ.3) THEN SD = 60.D0 / RADSEC ELSEIF (IBLK.EQ.2) THEN SD = 10.D0 / RADSEC ELSE SD = 1.D0 / RADSEC ENDIF SD = SD * DSQRT(VFACTR(10)) ENDIF RETURN END SUBROUTINE FORMOB (IUO,IUO2,B,G) *** REFORM OBS EQUATIONS USING MOST RECENT PARAMETERS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) LOGICAL LMSL,LSS,LUP LOGICAL FATAL DIMENSION B(*),G(*) DIMENSION IC(31),C(31) DIMENSION R1(3,3), R2(3,3) DIMENSION WEI1(2,2), VEL1(2,2,3) DIMENSION WEI2(2,2), VEL2(2,2,3) DIMENSION WEI(2,2), VEL(2,2,3) DIMENSION LSTA(2) COMMON /OPT/ AX,E2,DMSL,DGH,VM,VP,CTOL,ITMAX,ITMIN,IMODE, & LMSL,LSS,LUP COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI *** LOOP OVER THE OBSERVATIONS FATAL = .FALSE. REWIND IUO REWIND IUO2 100 READ (IUO,END = 777) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME IF (KIND.LE.18) THEN CALL FORMIC (KIND,ISN,JSN,IAUX,IC,LENG,B) CALL FORMC (KIND,C,B,ISN,JSN,IAUX,ITIME) CALL COMPIC (IC,C,LENG) CALL COMPOB (KIND,OBS0,B,OBSB,ISN,JSN,IAUX,ITIME) IF (KIND.EQ.1 .OR. KIND.EQ.2) THEN CMO = ( OBS0 - OBSB ) * RADSEC ELSE CMO = OBS0 - OBSB ENDIF IF ( KIND.EQ. 8 .OR. KIND.EQ.10 .OR. & KIND.EQ.11 .OR. KIND.EQ.12 .OR. KIND.EQ.20 ) THEN IF (CMO.GT.PI) THEN CMO = CMO - TWOPI ELSEIF (CMO.LT.-PI) THEN CMO = CMO + TWOPI ENDIF ENDIF CALL BIGL (KIND,ISN,JSN,IOBS,IVF,CMO,SD,FATAL) WRITE (IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ELSEIF (KIND .EQ. 19 .OR. KIND .EQ. 20 .OR. KIND .EQ. 21) THEN GLAT = C(5) GLON = C(6) CALL GRDWEI(GLON,GLAT,ISN,JSN,WEI) CALL GRDVEC(ISN,JSN,VEL,B) K = KIND - 18 OBS0 = WEI(1,1)*VEL(1,1,K) & + WEI(2,1)*VEL(2,1,K) & + WEI(1,2)*VEL(1,2,K) & + WEI(2,2)*VEL(2,2,K) IF(KIND .EQ. 19 .or. KIND .EQ. 20) THEN OBS0 = OBS0*RADSEC ENDIF CMO = OBS0 - OBSB WRITE( IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ELSEIF (KIND .EQ. 22 .OR. KIND .EQ. 23 .OR. KIND .EQ. 24) THEN CALL COMPSM(KIND,OBS0,LENG,C,IC,B) CMO = OBS0 - OBSB WRITE( IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME *** SITE VELOCITY RECORD ELSEIF (KIND .EQ. 25 .OR. KIND .EQ. 26 .OR. KIND .EQ. 27) THEN CALL GETGLA(GLAT,ISN,B) CALL GETGLO(GLON,ISN,B) CALL GRDPOS(GLON,GLAT,IGR,JGR) CALL GRDWEI(GLON,GLAT,IGR,JGR,WEI) CALL GRDVEC(IGR,JGR,VEL,B) K = KIND - 24 LENG = 4 C(1) = WEI(1,1) C(2) = WEI(2,1) C(3) = WEI(1,2) C(4) = WEI(2,2) IC(1) = IUNGRD(IGR ,JGR ,K) IC(2) = IUNGRD(IGR + 1,JGR ,K) IC(3) = IUNGRD(IGR ,JGR + 1,K) IC(4) = IUNGRD(IGR + 1,JGR + 1,K) OBS0 = WEI(1,1) * VEL(1,1,K) & + WEI(2,1) * VEL(2,1,K) & + WEI(1,2) * VEL(1,2,K) & + WEI(2,2) * VEL(2,2,K) IF(KIND .EQ. 25 .OR. KIND .EQ. 26) THEN OBS0 = OBS0 * RADSEC ENDIF CMO = OBS0 - OBSB WRITE(IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME *** D(X,Y,Z)/DT OBSERVATIONS ELSEIF(KIND.EQ.28 .OR. KIND.EQ.29 .OR. KIND.EQ.30)THEN CALL BUILDG(R1,GLAT1,GLON1,DTIME,X1,Y1,Z1,ISN,ITIME,B) CALL BUILDG(R2,GLAT2,GLON2,DTIME,X2,Y2,Z2,JSN,ITIME,B) CALL GRDPOS(GLON1,GLAT1,I1,J1) CALL GRDPOS(GLON2,GLAT2,I2,J2) CALL GRDWEI(GLON1,GLAT1,I1,J1,WEI1) CALL GRDWEI(GLON2,GLAT2,I2,J2,WEI2) CALL GRDVEC(I1,J1,VEL1,B) CALL GRDVEC(I2,J2,VEL2,B) LCNT = 2 LSTA(1) = ISN LSTA(2) = JSN LENG = 0 CALL ADDCD(IC,LENG,LSTA,LCNT,B,KIND) ITYPE = KIND - 27 CALL FORMCT(ITYPE,R1,WEI1,VEL1,R2,WEI2,VEL2,C,OBS0) CALL COMPIC(IC,C,LENG) CMO = OBS0 - OBSB WRITE(IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME *** DL/DT OBSERVATION ELSEIF (KIND .EQ. 31) THEN LCNT = 2 LSTA(1) = ISN LSTA(2) = JSN LENG = 0 CALL ADDCD(IC,LENG,LSTA,LCNT,B,KIND) CALL FORMLT(ISN,JSN,B,C,OBS0) CALL COMPIC(IC,C,LENG) CMO = OBS0 - OBSB WRITE(IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ELSEIF (KIND .GT. 999) THEN NVEC = ISN IAUX = JSN NR = 3 * NVEC WRITE (IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME CALL FORMG (IUO,IUO2,NVEC,NR,G,B,FATAL,IVF,IAUX,ITIME) ELSE WRITE(6,776) 776 FORMAT('0ABORTED IN FORMOB--UNRECOGNIZED KIND OF OBSERVATION') CALL ABORT2 ENDIF GO TO 100 *** ABORT DUE TO LARGE MISCLOSURES 777 IF (FATAL) THEN CALL LINE (3) WRITE (6,3) VM 3 FORMAT ('0ERROR - TERMINATED DUE TO MISCLOSURES (C-O)/SD', & ' EXCEEDING ' ,F7.1,/) CALL ABORT2 ENDIF REWIND IUO REWIND IUO2 *** EXCHANGE PRIMARY/SECONDARY OBS EQ FILE INDICATOR ITEMP = IUO IUO = IUO2 IUO2 = ITEMP RETURN END SUBROUTINE BIGV (KIND,ISN,JSN,IOBS,IVF,CMO,SD,FATAL) *** LIST LARGE RESIDUALS (MISCLOSURES) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) LOGICAL FATAL,LBV,LOCSSN LOGICAL LMSL,LSS,LUP LOGICAL LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP 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 /ECHO/ VSD,LBV COMMON /NUMVFS/ NVFTOT,NVFREE COMMON /VFTB2/ VFS(30),VTV(30),VFRN(30),VFSS(30) LBV = .FALSE. VSD = CMO / SD IF (NVFTOT.GT.0) THEN IF (IVF.LT.0 .OR. IVF.GT.NVFTOT) THEN WRITE (6,3) IVF,NVFTOT 3 FORMAT ('0ERROR - ILLEGAL IVF = ',I10,' FOR N=',I10, & ' FOR OBS#',I10,' IN BIGV') CALL ABORT2 ELSEIF (IVF.NE.0) THEN VSD = VSD / DSQRT( VFS(IVF) ) ENDIF ENDIF IF (KIND.GE.7) THEN IF (DABS(VSD).GT.VP) LBV = .TRUE. IF (DABS(VSD).GT.VM) FATAL = .TRUE. ELSE IF (DABS(VSD).GT.VP) THEN CALL LINE (1) LBV = .TRUE. IF ( .NOT.LOCSSN(ISN,ISSN) ) THEN WRITE (6,666) ISN 666 FORMAT ('0SSN TABLE ERROR IN BIGV--',I5) CALL ABORT2 ENDIF IF ( .NOT.LOCSSN(JSN,JSSN) ) THEN WRITE (6,666) JSN CALL ABORT2 ENDIF WRITE (6,1) IOBS,ISSN,JSSN,VSD 1 FORMAT (' ',' OBSERVATION #',I5,' BETWEEN STATIONS', & I5,' AND',I5,F30.1,' *** WARNING - LARGE MISCLOSURE') IF (DABS(VSD).GT.VM) FATAL = .TRUE. ENDIF ENDIF IF (.NOT.LBB) WRITE (6,2) IOBS,ISN,JSN,VSD 2 FORMAT (' ',' OBS# = ',I5,10X,'FROM#',I4,10X,'TO#',I4, & F20.1,' *** WARNING - LARGE MISCLOSURE') RETURN END SUBROUTINE BIGL (KIND,ISN,JSN,IOBS,IVF,CMO,SD,FATAL) *** LIST LARGE RESIDUALS (MISCLOSURES) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) LOGICAL LMSL,LSS,LUP LOGICAL FATAL COMMON /NUMVFS/ NVFTOT,NVFREE COMMON /VFTB2/ VFS(30),VTV(30),VFRN(30),VFSS(30) COMMON /OPT/ AX,E2,DMSL,DGH,VM,VP,CTOL,ITMAX,ITMIN,IMODE, & LMSL,LSS,LUP VSD = CMO / SD IF (NVFTOT.GT.0) THEN IF (IVF.LT.0 .OR. IVF.GT.NVFTOT) THEN WRITE (6,3) IVF,NVFTOT 3 FORMAT ('0ERROR - ILLEGAL IVF = ',I10,' FOR N=',I10, & ' IN BIGL') CALL ABORT2 ELSEIF (IVF.NE.0) THEN VSD = VSD / DSQRT( VFS(IVF) ) ENDIF ENDIF IF (DABS(VSD).GT.VP) THEN CALL LINE (1) WRITE (6,1) IOBS,VSD 1 FORMAT (' ',' OBS# ',I5,F70.1, & ' *** WARNING - LARGE MISCLOSURE') IF (DABS(VSD).GT.VM) FATAL = .TRUE. ENDIF RETURN END LOGICAL FUNCTION VFCVRG (IUO,IUO2,B,G,A,NX,GOOGE) *** REFORM OBS. EQS., COMPUTE INVERSE AND V.F.'S, AND TEST CONVERGE IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) LOGICAL LMSL,LSS,LUP LOGICAL GETA LOGICAL FATAL,FATAL2,FIXVF,PROP,INVERT DIMENSION B(*),G(*),A(*),NX(*),GOOGE(*) DIMENSION IC(31),C(31) COMMON /OPT/ AX,E2,DMSL,DGH,VM,VP,CTOL,ITMAX,ITMIN,IMODE, & LMSL,LSS,LUP COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI COMMON /NUMVFS/ NVFTOT,NVFREE COMMON /VFTB2/ VFS(30),VTV(30),VFRN(30),VFSS(30) COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD VFCVRG = .TRUE. VFSTOL = 1.D-5 VFCTOL = 1.D-2 *** COMPLETE THE COMPUTATION OF THE GOOGE NUMBERS DO 44 I = 1,NUNK IF ( .NOT.GETA(I,I,VAL,A,NX) ) THEN CALL INVIUN (I,ISN,ITYP,IUCODE) WRITE (6,55) I,ISN,ITYP,IUCODE 55 FORMAT ('0 FATAL ERROR IN GOOGE COMPUTATION IN VFCVRG',4I5) CALL ABORT2 ENDIF GOOGE(I) = VAL * VAL / GOOGE(I) 44 CONTINUE *** INVERT WITHIN PROFILE IF (IMODE.NE.1) THEN IF ( .NOT.INVERT(A,NX) ) THEN WRITE (6,666) 666 FORMAT ('0STATE ERROR IN INVERSION OF VFCVRG') CALL ABORT2 ENDIF ENDIF *** INITIALIZE VARIANCE FACTORS DO 1 IVF = 1,NVFTOT IF ( .NOT.FIXVF(IVF) ) THEN VTV(IVF) = 0.D0 VFRN(IVF) = 0.D0 ENDIF 1 CONTINUE *** LOOP OVER THE OBSERVATIONS FATAL2 = .FALSE. FATAL = .FALSE. REWIND IUO REWIND IUO2 100 READ (IUO,END = 777) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME IF (KIND.LE.999.AND. .NOT.(KIND.GE.19 .AND. & KIND.LE.21)) THEN CALL FORMIC (KIND,ISN,JSN,IAUX,IC,LENG,B) CALL FORMC (KIND,C,B,ISN,JSN,IAUX,ITIME) CALL COMPIC (IC,C,LENG) CALL COMPOB (KIND,OBS0,B,OBSB,ISN,JSN,IAUX,ITIME) IF (KIND.EQ.1 .OR. KIND.EQ.2) THEN CMO = ( OBS0 - OBSB ) * RADSEC ELSE CMO = OBS0 - OBSB IF ( KIND.EQ. 8 .OR. KIND.EQ.10 .OR. & KIND.EQ.11 .OR. KIND.EQ.12 ) THEN IF (CMO.GT.PI) THEN CMO = CMO - TWOPI ELSEIF (CMO.LT.-PI) THEN CMO = CMO + TWOPI ENDIF ENDIF ENDIF IF (IVF.NE.0) THEN IF ( .NOT.FIXVF(IVF) ) THEN IF ( PROP(C,IC,LENG,VARL0,A,NX,IFLAG) ) THEN VARLB = SD * SD * VFS(IVF) RN = 1.D0 - VARL0 / VARLB IF ( RN .LT. 1.0D-6 ) RN = 0.D0 VFRN(IVF) = VFRN(IVF) + RN VTV(IVF) = VTV(IVF) + CMO * CMO / VARLB ELSEIF (IFLAG.EQ.1) THEN WRITE (6,668) 668 FORMAT ('0STATE ERROR IN VFCVRG') CALL ABORT2 ELSE WRITE (6,669) 669 FORMAT ('0PROFILE ERROR IN VFCVRG') CALL ABORT2 ENDIF ENDIF ENDIF CALL BIGL (KIND,ISN,JSN,IOBS,IVF,CMO,SD,FATAL) WRITE (IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME *** GPS OBSERVATIONS ELSE NVEC = ISN IAUX = JSN NR = 3 * NVEC WRITE (IUO2) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME CALL FORMG2 (IUO,IUO2,NVEC,NR,G,B,A,NX,FATAL, & IVF,IAUX,ITIME) ENDIF GO TO 100 *** ABORT DUE TO LARGE MISCLOSURES 777 IF (FATAL) THEN CALL LINE (3) WRITE (6,3) VM 3 FORMAT ('0ERROR - TERMINATED DUE TO MISCLOSURES (C-O)/SD', & ' EXCEEDING ' ,F11.1,/) CALL ABORT2 ENDIF REWIND IUO REWIND IUO2 *** EXCHANGE PRIMARY/SECONDARY OBS EQ FILE INDICATOR ITEMP = IUO IUO = IUO2 IUO2 = ITEMP *** HEADING CALL LINE (3) WRITE (6,20) 20 FORMAT ('0NUM VAR. FACTOR DEG. OF FREE.', & T44,'V.F. RATIO(COMP/INIT)',/) *** COMPUTE VARIANCE FACTOR AND TEST CONVERGENCE DO 2 IVF = 1,NVFTOT IF ( FIXVF(IVF) ) THEN CALL LINE (1) WRITE (6,10) IVF,VFS(IVF) 10 FORMAT (1X,I3,F14.3,' *** FIXED ***') ELSEIF (VFRN(IVF).LT.VFSTOL) THEN CALL LINE (1) WRITE (6,11) IVF,VFRN(IVF) 11 FORMAT (1X,I3,' ERROR - FIXED VARIANCE FACTOR = ',1PD8.2, & ' **** IS SINGULAR ********') FATAL2 = .TRUE. ELSE VF = VTV(IVF) / VFRN(IVF) IF ( DABS(VF - 1.D0) .GT. VFCTOL ) VFCVRG = .FALSE. VFS(IVF) = VF * VFS(IVF) VFRAT = VFS(IVF) / VFSS(IVF) CALL LINE (1) WRITE (6,12) IVF,VFS(IVF),VFRN(IVF),VFRAT 12 FORMAT (1X,I3,2F14.3,T44,F15.3) ENDIF 2 CONTINUE *** ABORT IF SINGULAR VARIANCE FACTORS IF (FATAL2) THEN CALL LINE (3) WRITE (6,4) 4 FORMAT ('0ERROR - TERMINATED DUE TO VARIANCE FACTOR', & ' SINGULARITIES ') CALL ABORT2 ENDIF RETURN END SUBROUTINE TRNDAT(DATE, ITIME) *** Read blue-book date-time IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) CHARACTER*13 DATE CHARACTER*2 CENTRY CHARACTER*1 TC READ(DATE,5) CENTRY,IYR,IMO,IDY,IHR,IMN,TC 5 FORMAT(A2,5I2,A1) IF(DATE(3:4) .EQ. ' ') IYR = 84 IF(DATE(5:6) .EQ. ' ') IMO = 1 IF(DATE(7:8) .EQ. ' ') IDY = 1 IF(DATE(9:10) .EQ. ' ') IHR = 0 IF(DATE(11:12) .EQ. ' ') IMN = 0 IF(DATE(13:13) .EQ. ' ') TC = 'Z' IF(DATE(1:2) .EQ. '18') THEN IYR = IYR + 1800 ELSE IYR = IYR + 1900 ENDIF CALL TOMNT(IYR,IMO,IDY,IHR,IMN,TC,ITIME) RETURN END