SUBROUTINE SECADJ (IUNIT,IUO,IOBS,B,NX,FATAL) *** SECOND TRIP THRU ADJUSTMENT FILE IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD CHARACTER*2 ID LOGICAL FATAL LOGICAL LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP DIMENSION B(*),NX(*) COMMON /OPRINT/ CRIT,LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD DATA ICDP/0/ IF (LCS) THEN CALL HEAD CALL LINE (4) WRITE (6,1) 1 FORMAT (' ******** CONSTRAINTS *************',/, & '0 OBS #',/) ENDIF * CALL DIMCON (IOBS,IUO,B) 100 READ (IUNIT,2,END=777) CARD 2 FORMAT (A80) ID = CARD(1:2) IF (ID.EQ.'CC') THEN CALL SECCC (CARD,IUO,IOBS,B,FATAL) ELSEIF (ID.EQ.'PV') THEN CALL SECPV (CARD,IUO,IOBS,B,NX) ELSEIF (ID.EQ.'SV') THEN CALL SECSV (CARD,IUO,IOBS,B,NX,FATAL) ELSEIF (ID.EQ.'SM') THEN CALL SECSM (CARD,IUO,IOBS,B,NX,FATAL) ELSEIF (ID.EQ.'QQ') THEN CALL SECQQ (CARD,NX) ELSEIF (ID.EQ.'SS') THEN CALL SECSS (CARD,IUO,IOBS,B) ELSEIF (ID.EQ.'CA') THEN CALL SECCA (CARD,IUO,IOBS,B,NX,FATAL) ELSEIF (ID.EQ.'CD') THEN CALL SECCD (CARD,IUO,IOBS,B,NX,FATAL) ELSEIF (ID.EQ.'CH') THEN CALL SECCH (CARD,IUO,IOBS,B,NX,FATAL) ELSEIF (ID.EQ.'CZ') THEN CALL SECCZ (CARD,IUO,IOBS,B,NX,FATAL) ELSEIF (ID.EQ.'GT') THEN CALL SECGT (CARD,IUO,IOBS,B,NX,FATAL) ELSEIF (ID.EQ.'LT') THEN CALL SECLT (CARD,IUO,IOBS,B,NX,FATAL) * ELSEIF (ID.EQ.'CM') THEN * IF (IDIM.NE.1) CALL SECCM (CARD,IUO,IOBS,B,NX) * ELSEIF (ID.EQ.'TT') THEN * CALL SECTT (CARD) * ELSEIF (ID.EQ.'CT') THEN * IF (IDIM.NE.2) CALL SECCT(CARD,IUO,IOBS,B,NX,FATAL) * ELSEIF (ID.EQ.'CR') THEN * IF (IDIM.NE.1) CALL SECCR(CARD,IUO,IOBS,B,NX,FATAL) * ELSEIF (ID.EQ.'CL') THEN * IF (IDIM.NE.1) CALL SECCL(CARD,IUO,IOBS,B,NX,FATAL) ENDIF GO TO 100 *** END OF PROCESSING -- END OF FILE ENCOUNTERED 777 IF (LCS) THEN CALL LINE (2) WRITE (6,3) 3 FORMAT ('0************ END OF CONSTRAINTS *************') ENDIF RETURN END SUBROUTINE SECCA (CARD,IUO,IOBS,B,NX,FATAL) *** WRITE CONSTRAINTS FOR AZIMUTH RECORDS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD CHARACTER*4 ASS LOGICAL FATAL,GETSSN LOGICAL LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP LOGICAL LMSL,LSS,LUP LOGICAL ADDCON DIMENSION B(*),NX(*) DIMENSION IC(31),C(31) COMMON /CDGRID/ GRDLX, GRDUX, GRDLY, GRDUY, ICNTX, ICNTY, & ITREF COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI 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 /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ, & NREJ,NGPSR COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD READ (CARD,1) ISSN,JSSN,ID,IM,ASS,SD 1 FORMAT (2X,2I4, 3X,I3,I2,A4,F5.2) CALL NBLANK (ASS,4,IBLK) READ (ASS,2) SS 2 FORMAT (F4.2) *** STD DEV DEFAULT IS 0.01 ARC SECONDS IF ( CARD(23:27).EQ.' ' ) SD = 0.01D0 SD = SD / RADSEC NAZ = NAZ + 1 IF ( .NOT.GETSSN(ISSN,ISN) ) THEN CALL LINE (3) WRITE (6,4) CARD 4 FORMAT ('0ERROR - NO *80* RECORD FOR -- ',A80,/) ELSEIF ( .NOT.GETSSN(JSSN,JSN) ) THEN CALL LINE (3) WRITE (6,4) CARD ELSEIF ( CARD(14:22).NE.' ' ) THEN KIND = 12 NCON = NCON + 1 IOBS = IOBS + 1 IAUX = 0 IVF = 0 IF (NCD.GT.0) THEN ITIME = ITREF ELSE ITIME = 0 ENDIF OBSB = (ID + IM / 60.D0 + SS / 3600.D0) / RAD IF (OBSB.LT.0.D0) OBSB = OBSB + TWOPI IF (OBSB.GE.TWOPI) OBSB = OBSB - TWOPI 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 VSD = CMO / SD IF ( DABS(VSD).GT.VP ) THEN CALL LINE (1) WRITE (6,19) IOBS,VSD 19 FORMAT (1X,' OBS# = ',I5,F70.1, & ' *** WARNING - LARGE MISCLOSURE') IF ( DABS(VSD).GT.VM ) FATAL = .TRUE. ENDIF *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) 667 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR CONSTRAINED', & ' ASTRONOMIC AZIMUTH',/) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ELSEIF ( CARD(14:22).EQ.' ' ) THEN KIND = 12 NCON = NCON + 1 IOBS = IOBS + 1 IAUX = 0 IVF = 0 IF (NCD.GT.0) THEN ITIME = ITREF ELSE ITIME = 0 ENDIF 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) OBSB = OBS0 CMO = 0.D0 *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ENDIF *** ECHO CONSTRAINT IF (LCS) THEN CALL LINE (1) WRITE (6,7) IOBS,CARD 7 FORMAT (I7,3X,A80) ENDIF RETURN END SUBROUTINE SECCZ (CARD,IUO,IOBS,B,NX,FATAL) *** WRITE CONSTRAINTS FOR ZENITH DISTANCES IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD CHARACTER*4 ASS LOGICAL GETSSN,FATAL LOGICAL LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP LOGICAL LMSL,LSS,LUP LOGICAL ADDCON DIMENSION B(*),NX(*) DIMENSION IC(31),C(31) COMMON /CDGRID/ GRDLX, GRDUX, GRDLY, GRDUY, ICNTX, ICNTY, & ITREF COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI 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 /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ, & NREJ,NGPSR COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD READ (CARD,1) ISSN,JSSN,ID,IM,ASS,SD 1 FORMAT (2X,2I4, 3X,I3,I2,A4,F5.2) CALL NBLANK (ASS,4,IBLK) READ (ASS,2) SS 2 FORMAT (F4.2) *** STD DEV DEFAULT IS 0.01 ARC SECONDS IF ( CARD(23:27).EQ.' ' ) SD = 0.01D0 SD = SD / RADSEC NZD = NZD + 1 IF ( .NOT.GETSSN(ISSN,ISN) ) THEN CALL LINE (3) WRITE (6,4) CARD 4 FORMAT ('0ERROR - NO *80* RECORD FOR -- ',A80,/) ELSEIF ( .NOT.GETSSN(JSSN,JSN) ) THEN CALL LINE (3) WRITE (6,4) CARD ELSEIF ( CARD(14:22).NE.' ' ) THEN KIND = 14 NCON = NCON + 1 IOBS = IOBS + 1 IAUX = 0 IVF = 0 IF (NCD.GT.0) THEN ITIME = ITREF ELSE ITIME = 0 ENDIF OBSB = (ID + IM / 60.D0 + SS / 3600.D0) / RAD 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 VSD = CMO / SD IF ( DABS(VSD).GT.VP ) THEN CALL LINE (1) WRITE (6,11) IOBS,VSD 11 FORMAT (1X,' OBS#=',I5,F70.1, & ' *** WARNING - LARGE MISCLOSURE') IF ( DABS(VSD).GT.VM ) FATAL = .TRUE. ENDIF *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) 667 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR CONSTRAINED', & ' ZENITH DISTANCES',/) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ELSEIF ( CARD(14:22).EQ.' ' ) THEN KIND = 14 NCON = NCON + 1 IOBS = IOBS + 1 IAUX = 0 IVF = 0 IF (NCD.GT.0) THEN ITIME = ITREF ELSE ITIME = 0 ENDIF 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) OBSB = OBS0 CMO = 0.D0 *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ENDIF *** ECHO CONSTRAINT IF (LCS) THEN CALL LINE (1) WRITE (6,7) IOBS,CARD 7 FORMAT (I7,3X,A80) ENDIF RETURN END SUBROUTINE SECCD (CARD,IUO,IOBS,B,NX,FATAL) *** WRITE CONSTRAINTS FOR DISTANCE RECORDS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) CHARACTER*80 CARD LOGICAL GETSSN,FATAL LOGICAL ADDCON LOGICAL LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP LOGICAL LMSL,LSS,LUP DIMENSION B(*),NX(*) DIMENSION IC(31),C(31) COMMON /CDGRID/ GRDLX, GRDUX, GRDLY, GRDUY, ICNTX, ICNTY, & ITREF COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI 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 /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ, & NREJ,NGPSR COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD READ (CARD,1) ISSN,JSSN,OBSB,SD 1 FORMAT (2X,2I4,F12.4,F5.4) *** STD DEV DEFAULT IS 0.1 MM IF ( CARD(23:27).EQ.' ' ) SD = 0.0001D0 NDS = NDS + 1 IF ( .NOT.GETSSN(ISSN,ISN) ) THEN CALL LINE (3) WRITE (6,4) CARD 4 FORMAT ('0ERROR - NO *80* RECORD FOR -- ',A80,/) ELSEIF ( .NOT.GETSSN(JSSN,JSN) ) THEN CALL LINE (3) WRITE (6,4) CARD ELSEIF ( CARD(11:22).NE.' ' ) THEN KIND = 13 NCON = NCON + 1 IOBS = IOBS + 1 IAUX = 0 IVF = 0 IF (NCD.GT.0) THEN ITIME = ITREF ELSE ITIME = 0 ENDIF 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 VSD = CMO / SD IF ( DABS(VSD).GT.VP ) THEN CALL LINE (1) WRITE (6,11) IOBS,VSD 11 FORMAT (1X,' OBS# = ',I5,F70.1, & ' *** WARNING - LARGE MISCLOSURE') IF ( DABS(VSD).GT.VM ) FATAL = .TRUE. ENDIF *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) 667 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR CONSTRAINED', & ' DISTANCES',/) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ELSEIF ( CARD(11:22).EQ.' ' ) THEN KIND = 13 NCON = NCON + 1 IOBS = IOBS + 1 IAUX = 0 IVF = 0 IF (NCD.GT.0) THEN ITIME = ITREF ELSE ITIME = 0 ENDIF 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) OBSB = OBS0 CMO = 0.D0 *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ENDIF *** ECHO CONSTRAINT IF (LCS) THEN CALL LINE (1) WRITE (6,7) IOBS,CARD 7 FORMAT (I7,3X,A80) ENDIF RETURN END SUBROUTINE SECCH (CARD,IUO,IOBS,B,NX,FATAL) *** WRITE CONSTRAINTS FOR HEIGHT DIFFERENCES IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) PARAMETER (MXSSN = 9999) CHARACTER*80 CARD LOGICAL GETSSN,FATAL LOGICAL ADDCON LOGICAL ELFLAG,DFFLAG LOGICAL LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP LOGICAL LMSL,LSS,LUP DIMENSION B(*),NX(*) DIMENSION IC(31),C(31) COMMON /CDGRID/ GRDLX, GRDUX, GRDLY, GRDUY, ICNTX, ICNTY, & ITREF COMMON /CONST/ PI,PI2,RAD,RADSEC,TWOPI COMMON /FLAGS/ ELFLAG(MXSSN),DFFLAG(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 READ (CARD,1) ISSN,JSSN,OBSB,SD 1 FORMAT (2X,2I4,F12.4,F5.4) *** STD DEV DEFAULT IS 0.1 MM IF (CARD(23:27).EQ.' ') SD = 0.0001D0 IF ( .NOT.GETSSN(ISSN,ISN) ) THEN CALL LINE (3) WRITE (6,4) CARD 4 FORMAT ('0ERROR - NO *80* RECORD FOR -- ',A80,/) ELSEIF ( .NOT.GETSSN(JSSN,JSN) ) THEN CALL LINE (3) WRITE (6,4) CARD ELSEIF (CARD(11:22).NE.' ') THEN IF ( ELFLAG(ISN) ) THEN IF ( ELFLAG(JSN) ) THEN KIND = 16 ELSE KIND = 17 ENDIF ELSE IF ( ELFLAG(JSN) ) THEN KIND = 17 ELSE KIND = 15 ENDIF ENDIF NCON = NCON + 1 IOBS = IOBS + 1 IAUX = 0 IVF = 0 IF (NCD.GT.0) THEN ITIME = ITREF ELSE ITIME = 0 ENDIF 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 VSD = CMO / SD IF (DABS(VSD).GT.VP) THEN CALL LINE (1) WRITE (6,11) IOBS,VSD 11 FORMAT (1X,' OBS# = ',I5,F70.1, & ' *** WARNING - LARGE MISCLOSURE') IF (DABS(VSD).GT.VM) FATAL = .TRUE. ENDIF *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) 667 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR CONSTRAINED', & ' HEIGHT DIFFERENCES',/) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ELSEIF (CARD(11:22).EQ.' ') THEN IF ( ELFLAG(ISN) ) THEN IF ( ELFLAG(JSN) ) THEN KIND = 16 ELSE KIND = 17 ENDIF ELSE IF ( ELFLAG(JSN) ) THEN KIND = 17 ELSE KIND = 15 ENDIF ENDIF NCON = NCON + 1 IOBS = IOBS + 1 IAUX = 0 IVF = 0 IF (NCD.GT.0) THEN ITIME = ITREF ELSE ITIME = 0 ENDIF 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) OBSB = OBS0 CMO = 0.D0 *** UPDATE CONNECTIVITY IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,667) CALL ABORT2 ENDIF WRITE (IUO) KIND,ISN,JSN,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME ENDIF *** ECHO CONSTRAINT IF (LCS) THEN CALL LINE (1) WRITE (6,7) IOBS,CARD 7 FORMAT (I7,3X,A80) ENDIF RETURN END SUBROUTINE SECQQ (CARD,NX) *** ADD CONNECTIONS FOR AN ACCURACY RECORD IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) LOGICAL GETSSN LOGICAL ADDCON CHARACTER*80 CARD DIMENSION NX(*) DIMENSION IC(13) COMMON /CDGRID/ GRDLX, GRDUX, GRDLY, GRDUY, ICNTX, ICNTY, & ITREF COMMON /STATCT/ N84,N85,N86,N89,NDIR,NANG,NGPS,NZD,NDS,NAZ,NQQ, & NREJ,NGPSR READ (CARD,1) ISSN,JSSN 1 FORMAT (10X,I4,36X,I4) IF ( GETSSN(ISSN,ISN) ) THEN IF ( GETSSN(JSSN,JSN) ) THEN NQQ = NQQ + 1 CALL CONEC (ISN,JSN,IC,LENG) IF ( .NOT.ADDCON(IC,LENG,NX) ) THEN WRITE (6,666) 666 FORMAT ('0ERROR - INSUFFICIENT STORAGE FOR ACCURACY', & ' COMPUTATION') CALL ABORT2 ENDIF ENDIF ENDIF RETURN END SUBROUTINE CONEC (I,J,IC,LENG) *** FILL CONNECTION MATRIX FOR TWO STATIONS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) DIMENSION IC(13) COMMON /STRUCT/ NSTA,NAUX,NUNK,IDIM,NSTAS,NOBS,NCON,NZ,NCD IF (IDIM.EQ.1) THEN LENG = 2 IC(1) = IUNSTA(I,3) IC(2) = IUNSTA(J,3) ELSEIF (IDIM.EQ.2) THEN LENG = 4 IC(1) = IUNSTA(I,1) IC(2) = IUNSTA(I,2) IC(3) = IUNSTA(J,1) IC(4) = IUNSTA(J,2) ELSE LENG = 6 IC(1) = IUNSTA(I,1) IC(2) = IUNSTA(I,2) IC(3) = IUNSTA(I,3) IC(4) = IUNSTA(J,1) IC(5) = IUNSTA(J,2) IC(6) = IUNSTA(J,3) ENDIF RETURN END SUBROUTINE SECSS (CARD,IUO,IOBS,B) *** WRITE CONSTRAINT OBS. EQS. FOR AUXILIARY PARAMETERS IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) LOGICAL GETPRM 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 LMSL,LSS,LUP CHARACTER*80 CARD CHARACTER*1 TC1,TC2 DIMENSION IC(31),C(31) DIMENSION B(*) COMMON /CDGRID/ GRDLX, GRDUX, GRDLY, GRDUY, ICNTX, ICNTY, & ITREF COMMON /BYPASS/ LDIR,LANG,LZEN,LDIS,LAZI,LGPS 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 /OPRINT/ CRIT,LBB,LGF,LCS,LVD,LVA,LVZ,LVS, & LVR,LVG,LVC,LIS,LPS,LPG,LDR,LOS,LAP *** EXTRACT INFORMATION FROM RECORD READ (CARD,1) ICODE,IYR1,IMO1,IDY1,IHR1,IMN1,TC1, & IYR2,IMO2,IDY2,IHR2,IMN2,TC2,IVAL,ISD 1 FORMAT (2X,I2, 2(I4,4I2,A1),2I5) IF (ICODE.EQ.42) ICODE = 40 IF (ICODE.EQ.54) ICODE = 52 IF (ICODE.GE.26 .AND. ICODE.LE.29) ICODE = 25 IF (ICODE.EQ.25) THEN IF (LGPS) RETURN ELSEIF (ICODE.EQ.40) THEN IF (LZEN) RETURN ELSEIF (ICODE.EQ.52) THEN IF (LDIS) RETURN ELSE RETURN ENDIF IF (CARD(5:8).EQ.' ') IYR1 = 1801 IF (CARD(9:10).EQ.' ') IMO1 = 1 IF (CARD(11:12).EQ.' ') IDY1 = 1 IF (CARD(17:17).EQ.' ') TC1 = 'Z' IF (CARD(18:21).EQ.' ') IYR2 = 2099 IF (CARD(22:23).EQ.' ') IMO2 = 12 IF (CARD(24:25).EQ.' ') IDY2 = 31 IF (CARD(26:27).EQ.' ') IHR2 = 23 IF (CARD(28:29).EQ.' ') IMN2 = 59 IF (CARD(30:30).EQ.' ') TC2 = 'Z' IF (CARD(36:40).EQ.' ') ISD = 100 CALL TOMNT (IYR1,IMO1,IDY1,IHR1,IMN1,TC1,IOLD) CALL TOMNT (IYR2,IMO2,IDY2,IHR2,IMN2,TC2,INEW) ITIME = (IOLD + INEW) / 2 *** WRITE CONSTRAINT OBS. EQ. IF ( .NOT.GETPRM(ICODE,ITIME,IAUX) ) THEN CALL LINE (1) WRITE (6,2) CARD 2 FORMAT ('0*** ERROR - RECORD NOT IN PARAMETER TABLE',/,1X,A80) ELSEIF (CARD(31:40).NE.' ') THEN KIND = 0 NCON = NCON + 1 IVF = 0 IOBS = IOBS + 1 OBSB = DBLE(IVAL) * 1.0D-8 SD = DBLE(ISD) * 1.0D-8 CALL FORMIC (KIND,IAUX,IDUMMY,IDUM2,IC,LENG,B) CALL FORMC (KIND,C,B,IAUX,IDUMMY,IDUM2,ITIME) CALL COMPIC (IC,C,LENG) CALL COMPOB (KIND,OBS0,B,RDUMMY,IAUX,IDUMMY,IDUM2,ITIME) CMO = OBS0 - OBSB IF (IMODE.EQ.0) CMO = 0.D0 WRITE (IUO) KIND,IAUX,IDUMMY,IC,C,LENG,CMO,OBSB,SD, & IOBS,IVF,IAUX,ITIME *** ECHO OBSERVATION NUMBERS IF (LCS) THEN CALL LINE (1) WRITE (6,3) IOBS,CARD 3 FORMAT (1X,I6,3X,A80) ENDIF ENDIF RETURN END