C***********************************************************************MAIN0001 C* MAIN0002 C* MAIN CONTROLS ALL COMPUTATIONS. MATRIX AND VECTOR DIMENSIONS,WHICH LMAIN0003 C* THE MAXIMUM NETWORK SIZE, ARE SET UP AS DESCRIBED BELOW. MOST VARIAMAIN0004 C* ARE COMMON TO MAIN AND THE VARIOUS SUBROUTINES AND FOR THIS REASON TMAIN0005 C* ARE ONLY DESCRIBED HERE AS FOLLOWS: MAIN0006 C* MAIN0007 C* A -FIRST ORDER DESIGN MATRIX MAIN0008 C* B -IMAGE OF FIRST ORDER DESIGN MATRIX WITH CERTAIN MULTIPLICMAIN0009 C* TIONS (SEE DELQX) USED IN COMPUTING THE CORRECTION TO THE MAIN0010 C* VARIANCE MATRIX OF PARAMETERS FOR BLAHA STATIONS MAIN0011 C* D -VECTOR USED IN FORWARD SOLUTION OF X-VECTOR (SEE XSIN) MAIN0012 C* N -NUMBER OF UNKNOWNS (SIZE OF NORMAL EQUATIONS) MAIN0013 C* V -VECTOR OF RESIDUALS (AND STANDARDIZED RESIDUALS) MAIN0014 C* W -MISCLOSURE VECTOR FOR DISTANCE, DIRECTION, ANGLE AND AZIMMAIN0015 C* OBSERVATIONS MAIN0016 C* X -SOLUTION VECTOR MAIN0017 C* AA -SEMI-MAJOR AXIS OF REFERENCE ELLIPSOID MAIN0018 C* AP -MATRIX OF APPROXIMATE COORDINATES, HEIGHTS, DEFLECTION COMAIN0019 C* PONENTS, LATITUDE, LONGITUDE, RADII OF CURVATURE OF REFEREMAIN0020 C* ELLIPSOID, POINT SCALE FACTOR AND MERIDIAN CONVERGENCE. MAIN0021 C* AS -SIMILAR TO B ABOVE (SEE DELQX) MAIN0022 C* BB -SEMI-MINOR AXIS OF REFERENCE ELLIPSOID MAIN0023 C* BH -VECTOR OF ELEMENTS FOR INFORMATION MATRIX FOR BLAHA STATIMAIN0024 C* IB -VARIABLE BANDING CONTROL VECTOR MAIN0025 C* IC -MATRIX OF DESIGN MATRIX COLUMN NUMBERS FOR STATION COORDIMAIN0026 C* ID -RETURN CODE FROM INERR FOR ILLEGAL DATA ENTRY MAIN0027 C* NB -NUMBER OF BLAHA STATIONS MAIN0028 C* ND -NUMBER OF INDEPENDENT DIRECTION BUNDLES MAIN0029 C* NF -NUMBER OF FIXED STATIONS MAIN0030 C* NN -NUMBER OF UNKNOWN COORDINATES MAIN0031 C* NO -TOTAL NUMBER OF DISTANCE, DIRECTION, ANGLE AND AZIMUTH OBMAIN0032 C* VATIONS MAIN0033 C* NP -NUMBER OF WEIGHTED STATIONS MAIN0034 C* NR -DIMENSIONED SIZE OF NORMAL EQUATIONS MAIN0035 C* NS -TOTAL NUMBER OF STATIONS MAIN0036 C* NV -TOTAL NUMBER OF DISTANCE, DIRECTION, ANGLE AND AZIMUTH OBMAIN0037 C* VATIONS PLUS THE NUMBER OF COORDINATES OF WEIGHTED STATIONMAIN0038 C* N1 -NUMBER OF DISTANCE OBSERVATIONS MAIN0039 C* N2 -NUMBER OF DIRECTION OBSERVATIONS MAIN0040 C* N3 -NUMBER OF ANGLE OBSERVATIONS MAIN0041 C* N4 -NUMBER OF AZIMUTH OBSERVATIONS MAIN0042 C* OX -MATRIX OF COORDINATES OF WEIGHTED STATIONS MAIN0043 C* PX -VECTOR CONTAINING ELEMENTS OF INFORMATION MATRIX FOR WEIGMAIN0044 C* STATIONS MAIN0045 C* RL -LONGITUDE OF ORIGIN OF PROJECTION IN RADIANS MAIN0046 C* RN -MATRIX OF NORMAL EQUATIONS MAIN0047 C* RP -LATITUDE OF ORIGIN OF PROJECTION IN RADIANS MAIN0048 C* RU -CONSTANT VECTOR MAIN0049 C* R1 -RADIUS OF CONFORMAL SPHERE FOR THE DOUBLE STEREOGRAPHIC MAIN0050 C* PROJECTION MAIN0051 C* S0 -VALUE OF THE QUADRATIC FORM OF WEIGHTED RESIDUALS MAIN0052 C* TL -VECTOR CONTAINING THE INPUT TITLE (READ FROM THE TITLE CAMAIN0053 C* WX -MISCLOSURE VECTOR FOR WEIGHTED STATIONS MAIN0054 C* X0 -FALSE EASTING OF THE MAP PROJECTION MAIN0055 C* X1 -TRANSLATION COMPONENT FROM THE GEOCENTRE TO THE REFERENCEMAIN0056 C* ELLIPSOID MAIN0057 C* Y0 -FALSE NORTHING OF THE MAP PROJECTION MAIN0058 C* Y1 -TRANSLATION COMPONENT FROM THE GEOCENTRE TO THE REFERENCEMAIN0059 C* ELLIPSOID MAIN0060 C* Z1 -TRANSLATION COMPONENT FROM THE GEOCENTRE TO THE REFERENCEMAIN0061 C* ELLIPSOID MAIN0062 C* CBH -VECTOR CONTAINING NAMES OF BLAHA STATIONS MAIN0063 C* CIO -MATRIX OF NAMES OF SIGHTED STATIONS FOR OBSERVATIONS MAIN0064 C* CNF -VECTOR OF NAMES OF FIXED STATIONS MAIN0065 C* CPX -VECTOR OF NAMES OF WEIGHTED STATIONS MAIN0066 C* DOB -MATRIX CONTAINING REDUCED OBSERVATIONS AND THEIR STANDARDMAIN0067 C* VIATIONS MAIN0068 C* FAC -VECTOR OF FACTORS FOR INPUT STANDARD DEVIATIONS OF OBSERVMAIN0069 C* IBH -VECTOR OF SEQUENCE NUMBERS FOR BLAHA STATIONS MAIN0070 C* ICA -MATRIX OF COLUMN CODES FOR THE DESIGN MATRIX MAIN0071 C* ICP -WORKING VECTOR MAIN0072 C* IDF -NUMBER OF DEGREES OF FREEDOM OF ADJUSTMENT MAIN0073 C* IID -RETURN CODE FROM XSIN INDICATING STATUS OF CONVERGENCE MAIN0074 C* IOB -MATRIX OF SEQUENCE NUMBERS FOR STATIONS AND TYPE CODES OFMAIN0075 C* SERVATIONS MAIN0076 C* IPX -VECTOR OF SEQUENCE NUMBERS FOR WEIGHTED STATIONS MAIN0077 C* NBR -DIMENSIONED SIZE OF VECTORS ASSOCIATED WITH BLAHA STATIONMAIN0078 C* NB2 -NUMBER OF COORDINATES OF BLAHA STATIONS MAIN0079 C* NB3 -NUMBER OF UPPER DIAGONAL ELEMENTS FOR BLAHA INFORMATION MMAIN0080 C* NSR -DIMENSIONED SIZE OF MATRICES AND VECTORS ASSOCIATED WITH MAIN0081 C* NUMBER OF STATIONS MAIN0082 C* RKO -POINT SCALE FACTOR AT THE ORIGIN OF THE MAP PROJECTION MAIN0083 C* SBH -INFORMATION MATRIX FOR BLAHA STATIONS MAIN0084 C* SPX -INFORMATION MATRIX FOR WEIGHTED STATIONS MAIN0085 C* ZER -ESTIMATED ZERO ERROR FOR DISTANCES MAIN0086 C* ALPH -PERCENTAGE CONFIDENCE LEVEL FOR TESTING AND ELLIPSES MAIN0087 C* CENT -VECTOR OF CENTERING ERRORS FOR DISTANCES (CENT(1)), DIRECMAIN0088 C* (CENT(2)), ANGLES(CENT(3)), AND AZIMUTHS(CENT(4)) MAIN0089 C* CERR -VECTOR OF STATION NAMES IN A SET FOR SIMULTANEOUS ELLIPSEMAIN0090 C* CNAM -VECTOR OF STATION NAMES FOR ALL STATIONS MAIN0091 C* DOBR -MATRIX CONTAINING OBSERVED VALUES OF OBSERVATIONS MAIN0092 C* ICER -VECTOR OF SEQUENCE NUMBERS FOR A SET OF STATIONS FOR SIMUMAIN0093 C* TANEOUS ELLIPSES MAIN0094 C* ITER -ITERATION COUNTER MAIN0095 C* NBHR -DIMENSIONED SIZE OF VECTOR CONTAINING ELEMENTS OF BLAHA MAIN0096 C* INFORMATION MATRIX MAIN0097 C* NB2R -DIMENSIONED SIZE OF BLAHA INFORMATION MATRIX MAIN0098 C* NCOV -CODE FOR TYPE OF MATRIX INPUT FOR WEIGHTED STATIONS (=0 FMAIN0099 C* COVARIANCE MATRIX AND =1 FOR WEIGHT MATRIX) MAIN0100 C* NFAC -CODE FOR WHETHER FAC IS OTHER THAN ONES (0=UNITY,1=FACTORMAIN0101 C* READ) MAIN0102 C* NFIX -VECTOR OF SEQUENCE NUMBERS FOR FIXED STATIONS MAIN0103 C* NINC -COUNTER FOR DIVERGENCE MONITORING MAIN0104 C* NPRA -CODE FOR PRINTING THE DESIGN MATRIX A MAIN0105 C* NPRN -CODE FOR PRINTING THE NORMAL EQUATIONS MAIN0106 C* NPRU -CODE FOR PRINTING THE CONSTANT VECTOR MAIN0107 C* NPRW -CODE FOR PRINTING THE MISCLOSURE VECTOR MAIN0108 C* NPXR -DIMENSIONED SIZE OF VECTOR FOR UPPER DIAGONAL ELEMENTS OFMAIN0109 C* INFORMATION MATRIX FOR WEIGHTED STATIONS MAIN0110 C* NP2R -DIMENSIONED SIZE OF INFORMATION MATRIX FOR WEIGHTED STATIMAIN0111 C* VARF -ESTIMATED VARIANCE FACTOR MAIN0112 C* VCLS -VECTOR CONTAINING ORDERED RESIDUALS MAIN0113 C* CONVG -CONVERGENCE CRITERION MAIN0114 C* NABST -CODE FOR PRINTING STATION ABSTRACTS MAIN0115 C* NCENT -CODE FOR CENTERING ERRORS MAIN0116 C* NCODE -CODE FOR PREANALYSIS OR ADJUSTMENT MAIN0117 C* NCORR -CODE FOR PRINTING REDUCTION CORRECTIONS FOR OBSERVATIONS MAIN0118 C* NCOVD -CODE FOR TYPE OF INFORMATION MATRIX READ FOR BLAHA STATIOMAIN0119 C* (=0 COVARIANCE MATRIX; =1 WEIGHT MATRIX) MAIN0120 C* NCRIT -CODE FOR CONVERGENCE CRITERION MAIN0121 C* NDELX -CODE FOR PRINTING ITERATIVE CORRECTIONS TO INITIAL COORDIMAIN0122 C* NELPS -CODE FOR ERROR ELLIPSES (NON-SIMULTANEOUS) MAIN0123 C* NITER -CODE FOR MAXIMUM NUMBER OF ITERATIONS TO BE ALLOWED MAIN0124 C* NMULT -CODE FOR MULTIPLICATION OF THE INVERSE OF THE NORMAL EQUAMAIN0125 C* BY THE ESTIMATED VARIANCE FACTOR MAIN0126 C* NPRCX -CODE FOR PRINTING COVARIANCE MATRIX OF PARAMETERS MAIN0127 C* NPROJ -CODE FOR MAP PROJECTION MAIN0128 C* NRED1 -CODE FOR REDUCTIONS OF OBSERVATIONS FROM TERRAIN TO ELLIPMAIN0129 C* NRED2 -CODE FOR REDUCTIONS OF OBSERVATIONS FROM ELLIPSOID TO PLAMAIN0130 C* NRED3 -CODE FOR REDUCTION OF AZIMUTHS FROM TERRAIN TO PLANE MAIN0131 C* NSIMU -CODE FOR SIMULTANEOUS ELLIPSES MAIN0132 C* NSQRT -CODE FOR PRINTING CHOLESKI SQUARE ROOT MAIN0133 C* NSRES -CODE FOR STANDARD DEVIATIONS OF RESIDUALS MAIN0134 C* NSTAN -CODE FOR CONFIDENCE LEVEL OF TESTING AND ELLIPSES MAIN0135 C* NTEST -CODE FOR TEST USED FOR REJECTION OF RESIDUALS MAIN0136 C* NUNIT -CODE FOR LINEAR UNITS MAIN0137 C* NVARF -CODE FOR KNOWLEDGE OF VARIANCE FACTOR MAIN0138 C* NZERO -CODE FOR ESTIMATION OF ZERO ERROR MAIN0139 C* WANGC -ANGULAR MISCLOSURE CRITERION MAIN0140 C* WDISC -LINEAR MISCLOSURE CRITERION MAIN0141 C* NUMREJ -NUMBER OF RESIDUALS FLAGGED FOR REJECTION MAIN0142 C* MAIN0143 C***********************************************************************MAIN0144 IMPLICIT REAL*8(A-H,O-Z) MAIN0145 C CHANGE NR BELOW (WHEN CHANGING THE FOLLOWING DIMENSION STATEMENT) MAIN0146 DIMENSION RN(121,121),RU(121),X(121),D(121),ICP(121),IB(121) MAIN0147 @,CERR(121) MAIN0148 C CHANGE NFR BELOW MAIN0149 DIMENSION NFIX(30),CNF(30) MAIN0150 C CHANGE NOR BELOW MAIN0151 DIMENSION A(300,6),ICA(300,6),IOB(300,4),DOB(300,4),W(300), MAIN0152 @ CIO(300,3),DOBR(300,4),AS(300,6),B(300,6),VCLS(300) MAIN0153 C CHANGE NSR BELOW MAIN0154 DIMENSION AP(60,12),IC(60,2),CNAM(60),ICER(60) MAIN0155 C CHANGE NPR BELOW MAIN0156 DIMENSION IPX(30),OX(30,2),CPX(30) MAIN0157 C CHANGE NP2R BELOW MAIN0158 DIMENSION SPX(60,60),WX(60) MAIN0159 C CHANGE NBR BELOW MAIN0160 DIMENSION IBH(30),CBH(30) MAIN0161 C CHANGE NB2R BELOW MAIN0162 DIMENSION SBH(60,60) MAIN0163 C THE FOLLOWING DIMENSION MUST BE NB2R*(NB2R+1)/2 (=NBHR BELOW) MAIN0164 DIMENSION BH(1830) MAIN0165 C THE FOLLOWING DIMENSION MUST BE NP2R*(NP2R+1)/2 (=NPXR BELOW) MAIN0166 DIMENSION PX(1830) MAIN0167 C THE FOLLOWING DIMENSION MUST BE NOR+NP2R MAIN0168 DIMENSION V(360) MAIN0169 C THE FOLLOWING DIMENSIONS MUST NOT BE CHANGED MAIN0170 DIMENSION FAC(5),TL(10),CENT(4) MAIN0171 C INITIALIZE VARIABLES FOR DIMENSIONED SIZES MAIN0172 NR=121 MAIN0173 NFR=30 MAIN0174 NOR=300 MAIN0175 NSR=60 MAIN0176 NPR=30 MAIN0177 NP2R=60 MAIN0178 NPXR=1830 MAIN0179 NBR=30 MAIN0180 NB2R=60 MAIN0181 NBHR=1830 MAIN0182 C READ AND STORE INPUT DATA MAIN0183 CALL READ(TL,NP2R,NCODE,NF,NP,NSTAN,NPROJ,NUNIT,NELPS,NDELX, MAIN0184 @ NFAC,NITER,NZERO,NTEST,NMULT,NCOV,CNF,NFR,NP2,NP3,CPX,NPR, MAIN0185 @ PX,NPXR,ALPH ,FAC,CNAM,NSR,AP,NS,X,D,NR,IOB,NOR,DOB,CIO,NO,ND,N, MAIN0186 @ NCORR,CONVG,CENT,NCENT,NCRIT,NRED1,NRED2,NRED3,NB,CBH,BH, MAIN0187 @ NBR,NBHR,NCOVB,N1,N2,N3,N4,CERR,NSIMU,NSRES,NPRA,NPRN,NPRW, MAIN0188 @ NPRU,NPRCX,NSQRT,NB2,NB3,NVARF,NDISK,1,WANGC,WDISC,NABST) MAIN0189 C GENERATE SEQUENCE NUMBERS MAIN0190 CALL NAMC(NSR,NOR,NO,NS,NP,NFIX,IPX,CIO,CNAM,CNF,CPX,IOB,NF,NPR, MAIN0191 @ NFR,IBH,CBH,NBR,NB) MAIN0192 ID=0 MAIN0193 C CHECKS ON INPUT DATA MAIN0194 CALL INERR(NO,IOB,DOB,ID,NS,NCODE,NOR) MAIN0195 IF(ID.EQ.1)GOTO99 MAIN0196 CALL CHEK(N,NP,NB,NF,CNF,NFR,CPX,NPR,CBH,NBR,NO,N1,N2,N3,N4, MAIN0197 @ NZERO,ND,IDF) MAIN0198 C GENERATE DESIGN MATRIX AND NORMAL EQUATION COLUMN CODES MAIN0199 CALL COL(NFIX,NF,IC,NS,NSR,NFR,NB,IBH,NBR) MAIN0200 CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,1,NZERO,N) MAIN0201 C COMPUTE STANDARD DEVIATIONS OF OBSERVATIONS AND INFORMATION FOR EACH MAIN0202 C STATION MAIN0203 CALL FILDOR(IOB,DOB,DOBR,NO,NOR,NCENT,AP,NSR,CENT) MAIN0204 IF(NPROJ.EQ.3)GOTO50 MAIN0205 CALL FILAP(AP,NSR,NPROJ,NUNIT,AA,BB,NS,RP,RL,XO,YO,X1,Y1,Z1,R1, MAIN0206 @ RKO) MAIN0207 C PRINT TITLE PAGE AND INITIAL COORDINATES MAIN0208 CALL PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSR,NFIX,MAIN0209 @ NPROJ,NUNIT,NELPS,NSTAN,ALPH,NFAC,NZERO,NTEST,NCOV, MAIN0210 @ NCORR,NMULT,NITER,NDELX,NCRIT,CONVG,NRED1,NRED2,NCENT,CENT, MAIN0211 @ NRED3,1,NB,CBH,NBR,ZER,NCOVB,IBH,IPX,AA,BB,RP,RL,XO,YO,X1,Y1,Z1, MAIN0212 @ RKO,IDF) MAIN0213 IF(NCODE.EQ.1)GOTO50 MAIN0214 IF(NRED1.EQ.0)GOTO51 MAIN0215 C MAKE OBSERVATION REDUCTIONS FROM TERRAIN TO ELLIPSOID MAIN0216 CALL TOELPS(IOB,DOB,DOBR,NOR,AA,BB,X1,Y1,Z1,AP,NSR,NCORR,NO,CNAM, MAIN0217 @ NRED3) MAIN0218 51 IF(NRED2.EQ.0)GOTO50 MAIN0219 C MAKE OBSERVATION REDUCTIONS FROM ELLIPSOID TO PLANE MAIN0220 CALL TOPLAN(IOB,DOB,NOR,XO,YO,RKO,AP,NSR,NCORR,NO,CNAM, MAIN0221 @ NRED3,NPROJ,AA,BB,R1,DOBR,NRED1) MAIN0222 50 CONTINUE MAIN0223 IF(NPROJ.NE.3)GOTO53 MAIN0224 CALL PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSR,NFIX,MAIN0225 @ NPROJ,NUNIT,NELPS,NSTAN,ALPH,NFAC,NZERO,NTEST,NCOV, MAIN0226 @ NCORR,NMULT,NITER,NDELX,NCRIT,CONVG,NRED1,NRED2,NCENT,CENT, MAIN0227 @ NRED3,1,NB,CBH,NBR,ZER,NCOVB,IBH,IPX,AA,BB,RP,RL,XO,YO,X1,Y1,Z1, MAIN0228 @ RKO,IDF) MAIN0229 C FORM INFORMATION MATRIX FOR WEIGHTED AND/OR BLAHA STATIONS MAIN0230 53 IF(NB.NE.0)CALL FORMPX(OX,AP,NBR,NSR,NB,NB2,SBH,NB2R,BH,NBHR,NCOVBMAIN0231 @,IB,NR,RU,D,IBH,X,CONVG,CNAM,NS,IOB,NOR,IC,ICA,W,CBH,WX,NO,2) MAIN0232 IF(NP.NE.0)CALL FORMPX(OX,AP,NPR,NSR,NP,NP2,SPX,NP2R,PX,NPXR,NCOV,MAIN0233 @ IB,NR,RU,D,IPX,X,CONVG,CNAM,NS,IOB,NOR,IC,ICA,W,CPX,WX,NO,1) MAIN0234 C CHECK DETERMINATION OF NETWORK MAIN0235 CALL CHKDEM(NS,NF,NFIX,NFR,NP,IPX,NPR,NB,IBH,NBR,NO,IOB,NOR,CNAM,NMAIN0236 @SR,N1,N4) MAIN0237 C INITIALIZE SOME VARIABLES MAIN0238 ZER=0.0D0 MAIN0239 NN=N-NZERO MAIN0240 ITER=-1 MAIN0241 21 ITER=ITER+1 MAIN0242 CALL ZERON(RN,RU,IB,N,NR) MAIN0243 C FORM NORMAL EQUATIONS AND CONSTANT VECTOR, PRINTING INTERMEDIATE RE- MAIN0244 C SULTS IF REQUESTED MAIN0245 CALL NORVEC(IOB,DOB,N,SPX,NP,IPX,ICP,RN,RU,A,ICA,AP,IC,IB,NO,NS, MAIN0246 @ NCODE,OX,NZERO,W,WX,NPR,NOR,NP2R,NR,NSR,ITER,ZER,CNAM,DOBR, MAIN0247 @NFAC,FAC) MAIN0248 IF(ITER.EQ.0.AND.NCODE.EQ.2)CALL CHKMIS(W,NOR,NO,WANGC,WDISC,IOB, MAIN0249 @DOB,CNAM,NSR,NUNIT) MAIN0250 IF(NPRA.NE.0.AND.((NPRA.EQ.1.AND.ITER.EQ.0).OR.(NPRA.EQ.2))) MAIN0251 @ CALL PRAR(A,NOR,6,NO,6,1,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, MAIN0252 @ CPX,NP,WX,NR,NP2R,NPR,NO) MAIN0253 IF(NPRN.NE.0.AND.((NPRN.EQ.1.AND.ITER.EQ.0).OR.(NPRN.EQ.2))) MAIN0254 @ CALL PRAR(RN,NR,NR,N,N,21,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, MAIN0255 @ CPX,NP,WX,NR,NP2R,NPR,NO) MAIN0256 IF(NPRW.NE.0.AND.((NPRW.EQ.1.AND.ITER.EQ.0).OR.(NPRW.EQ.2))) MAIN0257 @ CALL PRAR(W,NOR,1,NO,1,4,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, MAIN0258 @ CPX,NP,WX,NR,NP2R,NPR,NO) MAIN0259 IF(NPRU.NE.0.AND.((NPRU.EQ.1.AND.ITER.EQ.0).OR.(NPRU.EQ.2))) MAIN0260 @CALL PRAR(RU,NR,1,N,1,3,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, MAIN0261 @ CPX,NP,WX,NR,NP2R,NPR,NO) MAIN0262 C SOLVE SYSTEM VIA THE CHOLESKI METHOD MAIN0263 CALL XSIN(RN,N,NCODE,NN,RU,D,IID,IB,X,NR,CONVG,NSQRT,ITER,CNAM, MAIN0264 @ NS,IOB,NOR,IC,NSR,ICA,RU,W,CPX,NB,WX,NP2R,NPR,NO,1,NITER,0) MAIN0265 NV=NO+NP2 MAIN0266 IF(NCODE.EQ.1)GOTO24 MAIN0267 C UPDATE COORDINATES MAIN0268 CALL UPDAT(NS,ITER,NF,NFIX,AP,X,NZERO,ZER,N,NSR,CNAM,NFR,NDELX, MAIN0269 @NB,IBH,NBR) MAIN0270 C CHECK FOR DIVERGENCE OR CONVERGENCE MAIN0271 CALL CHKDIV(ITER,X,NINC,CERR,NSR,NR,NB,NF,NS,CONVG) MAIN0272 IF(ITER.LT.NITER.AND.IID.EQ.1)GOTO21 MAIN0273 IF(NPROJ.EQ.3)GOTO52 MAIN0274 C COMPUTE ADJUSTED INFORMATION FOR STATIONS MAIN0275 CALL FILAP(AP,NSR,NPROJ,NUNIT,AA,BB,NS,RP,RL,XO,YO,X1,Y1,Z1,R1, MAIN0276 @ RKO) MAIN0277 C PRINT ADJUSTED COORDINATES MAIN0278 52 CALL PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSR,NFIX,MAIN0279 @ NPROJ,NUNIT,NELPS,NSTAN,ALPH,NFAC,NZERO,NTEST,NCOV, MAIN0280 @ NCORR,NMULT,NITER,NDELX,NCRIT,CONVG,NRED1,NRED2,NCENT,CENT, MAIN0281 @ NRED3,2,NB,CBH,NBR,ZER,NCOVB,IBH,IPX,AA,BB,RP,RL,XO,YO,X1,Y1,Z1, MAIN0282 @ RKO,IDF) MAIN0283 IF(IDF.EQ.0)GOTO24 MAIN0284 C COMPUTE RESIDUALS... MAIN0285 CALL RESID(IOB,NO,A,X,W,WX,ICA,N,V,NV,ND,NP,ICP,SPX,NOR,NR, MAIN0286 @ NP2R,CNAM,NSR,ZER,DOBR,IDF,S0) MAIN0287 C ...PRINT THEM AND THEN STANDARDIZE THEM MAIN0288 CALL PRES(IDF,S0,NO,IOB,DOB,ZER,V,NV,CNAM,NSR,DOBR,NOR,NSRES) MAIN0289 C CHECK RESIDUALS AGAINST REJECTION CRITERION MAIN0290 CALL RESREJ(V,NV,DOB,IOB,NOR,NO,NTEST,ALPH,IDF,CNAM,NSR,NUMREJ) MAIN0291 24 CONTINUE MAIN0292 C COMPUTE AND PRINT SOME STATISTICS OF THE ADJUSTMENT MAIN0293 CALL STATS(ITER,NITER,N1,N2,N3,N4,NP,NB,NZERO,ND,N,IDF,S0,NVARF, MAIN0294 @ NUMREJ,NCODE,V,NV,DOB,NOR,NO,IOB,ALPH,VCLS,VARF) MAIN0295 IF(NB.NE.0)CALL DELQX(RN,NR,SBH,NB2R,A,ICA,NOR,NZERO,NB,N,IC,OX MAIN0296 @,IOB,DOB,IBH,NBR,NO,RU,ICP,AP,NSR,IB,WX,CNAM,DOBR,NS,W,CBH,NPR, MAIN0297 @ NP2R,NFR,FAC,NFIX,NF,B) MAIN0298 C MULTIPLY INVERSE OF NORMAL EQUATIONS BY ESTIMATED VARIANCE FACTOR IF MAIN0299 C REQUESTED MAIN0300 IF(NMULT.EQ.1.AND.NCODE.EQ.2)CALL MULCX(VARF,RN,NR,N) MAIN0301 C COMPUTE ERROR ELLIPSES AND PRINT THEM MAIN0302 CALL ERREL(RN,NR,N,IC,NS,NELPS,NSIMU,NVARF,AP,NSR,A,NOR,CERR, MAIN0303 @ALPH,IDF,NF,NB,CNAM,VARF,NMULT,NCODE,NSTAN,NUNIT,ICER,TL,CNF, MAIN0304 @NFR,CPX,NPR,PX,NPXR,FAC,X,D,IOB,DOB,CIO,NO,CENT,CBH,NBR,BH,NBHR, MAIN0305 @NPRCX,NABST) MAIN0306 C PRINT COVARIANCE MATRIX IF REQUESTED MAIN0307 IF(NPRCX.EQ.1)CALL PRAR(RN,NR,NR,N,N,23,CNAM,NS,ITER,IOB,NOR,IC, MAIN0308 @ NSR,ICA,RU,W,CPX,NP,WX,NR,NP2R,NPR,NO) MAIN0309 C PRINT STATION ABSTRACTS IF REQUESTED MAIN0310 IF(NABST.EQ.1.AND.NPROJ.NE.3.AND.NCODE.EQ.2)CALL ABSTR(CNAM,NSR, MAIN0311 @AP,RN,NR,IOB,NOR,NO,IC,NB,NS,NUNIT,NPROJ,RKO,AA,BB,XO,YO,R1) MAIN0312 99 STOP MAIN0313 END MAIN0314 SUBROUTINE ABSTR(CNAM,NSR,AP,RN,NR,IOB,NOR,NO,IC,NB,NS,NUNIT,NPROJABSTR001 @,RKO,AA,BB,XO,YO,R1) ABSTR002 C***********************************************************************ABSTR003 C* ABSTR004 C* ABSTR PRINTS ABSTRACTS OF EACH FREE STATION UPON REQUEST IF A MAP PRABSTR005 C* JECTION IS BEING USED IN THE ADJUSTMENT. ABSTR006 C* ABSTR007 C* ABSTR008 C* INPUT: ABSTR009 C* -ALL DESCRIBED IN MAIN ABSTR010 C* ABSTR011 C* OUTPUT: ABSTR012 C* PRINTED ABSTRACTS (SEE MANUAL FOR DESCRIPTION) ABSTR013 C* ABSTR014 C* ABSTR015 C* WRITTEN BY: ABSTR016 C* R.R. STEEVES, AUG., 1978 ABSTR017 C* ABSTR018 C***********************************************************************ABSTR019 IMPLICIT REAL*8(A-H,O-Z) ABSTR020 LOGICAL*1 DATE(18) ABSTR021 DIMENSION CNAM(NSR),AP(NSR,12),RN(NR,NR),IOB(NOR,4),IC(NSR,2), ABSTR022 @IVEC(50) ABSTR023 DATA UF,UM/' FEET ',' METRES '/ ABSTR024 U=UM ABSTR025 IF(NUNIT.EQ.1)U=UF ABSTR026 CALL GDATE(DATE) ABSTR027 NSTA=NS-NB ABSTR028 PI=3.141592653589793D0 ABSTR029 DO 1 I=1,NSTA ABSTR030 IF(IC(I,1).EQ.0)GOTO1 ABSTR031 PRINT101,CNAM(I),DATE ABSTR032 CALL RADMS(AP(I,9),IDP,IMP,SP) ABSTR033 CALL RADMS(AP(I,10),IDL,IML,SL) ABSTR034 CALL RADMS(AP(I,12),IDC,IMC,SC) ABSTR035 PRINT102,AP(I,1),U,IDP,IMP,SP ABSTR036 PRINT103,AP(I,2),U,IDL,IML,SL ABSTR037 CX1=RN(IC(I,1),IC(I,1)) ABSTR038 CX2=RN(IC(I,1),IC(I,2)) ABSTR039 PRINT104,AP(I,3),U,AP(I,4),U,CX1,CX2 ABSTR040 CX1=CX2 ABSTR041 CX2=RN(IC(I,2),IC(I,2)) ABSTR042 PRINT105,AP(I,5),AP(I,6),CX1,CX2 ABSTR043 PRINT106,IDC,IMC,SC,AP(I,11) ABSTR044 PRINT107 ABSTR045 CALL SIGST(IOB,I,IVEC,NSS,NOR,NO) ABSTR046 DO 2 JJ=1,NSS ABSTR047 J=IVEC(JJ) ABSTR048 GAZ=DATAN2(AP(J,1)-AP(I,1),AP(J,2)-AP(I,2)) ABSTR049 IF(GAZ.LT.0)GAZ=GAZ+2.D0*PI ABSTR050 CALL RADMS(GAZ,IDA,IMA,SA) ABSTR051 SIJ=DSQRT((AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2) ABSTR052 IF(NPROJ.LT.3)CALL TKSTER(I,J,AP,NSR,R1,XO,YO,RKO,TT,S) ABSTR053 IF(NPROJ.GT.3)CALL TKTM(I,J,AP,NSR,RKO,AA,BB,XO,TT,S) ABSTR054 CALL RADMS(TT,IDT,IMT,ST) ABSTR055 PRINT108,CNAM(I),CNAM(J),IDA,IMA,SA,SIJ,IDT,IMT,ST,S ABSTR056 2 CONTINUE ABSTR057 1 CONTINUE ABSTR058 101 FORMAT('1',8X,'ABSTRACT FOR STATION:',5X,A8,2X,'(AS DETERMINED BY ABSTR059 @PROGRAM GEOPAN ON ',18A1,')',/,' ',8X,91('-'),//) ABSTR060 102 FORMAT(' ','EASTING (X) :',F14.3,A8,6X,'LATITUDE :',I5,I4,F10.5,ABSTR061 @ 4X,'|',/,' ',76X,'|') ABSTR062 103 FORMAT(' ','NORTHING (Y) :',F14.3,A8,6X,'LONGITUDE :',I5,I4,F10.5,ABSTR063 @ 4X,'|',8X,'COVARIANCE MATRIX',/,' ',76X,'|',6X,'--X--',11X,'--Y--ABSTR064 @') ABSTR065 104 FORMAT(' ','ORTHOMETRIC HEIGHT :',F13.3,A8,';GEOIDAL HEIGHT :', ABSTR066 @ F10.3,A8,'|',1X,D15.8,1X,D15.8,/,' ',76X,'|') ABSTR067 105 FORMAT(' ','DEFLECTION COMPONENTS :',F8.1,' SECONDS (NORTH);',F8.1ABSTR068 @,' SECONDS (EAST)',5X,'|',1X,D15.8,1X,D15.8,/,' ',76X,'|') ABSTR069 106 FORMAT(' ','MERIDIAN CONVERGENCE :',I5,I4,F7.2,' ; POINT SCALE FABSTR070 @ACTOR :',F11.7,2X,'|',//) ABSTR071 107 FORMAT(' ',13X,'FROM',6X,'TO',11X,'GRID AZIMUTH',5X,'GRID DISTANCEABSTR072 @',4X,'ARC TO CHORD',4X,'LINE SCALE',/) ABSTR073 108 FORMAT(' ',13X,2(A8,2X),I5,I4,F7.2,2X,F12.3,5X,I3,I4,F7.2,F14.7,/)ABSTR074 RETURN ABSTR075 END ABSTR076 SUBROUTINE ANGL(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, ANGL0001 @ ITER,W,NOR,NSR,NR,CNAM,DOBR) ANGL0002 C***********************************************************************ANGL0003 C* ANGL0004 C* ANGL COMPUTES OBSERVATION EQUATION COEFFICIENTS FOR AN ANGLE OB- ANGL0005 C* SERVATION. IT ALSO ADDS CONTRIBUTIONS OF ANGLE OBSERVATION TO NORMALANGL0006 C* EQUATIONS AND CONSTANT VECTOR. - PRINTS ANGLE MISCLOSURES ON ZEROTH ANGL0007 C* ITERATION. ANGL0008 C* ANGL0009 C* ANGL0010 C* INPUT: ANGL0011 C* - ALL DESCRIBED IN MAIN ANGL0012 C* ANGL0013 C* OUTPUT: ANGL0014 C* - ALL DESCRIBED IN MAIN. ANGL0015 C* ANGL0016 C* ANGL0017 C* WRITTEN BY: ANGL0018 C* R.R. STEEVES, MAY, 1976 ANGL0019 C* ANGL0020 C***********************************************************************ANGL0021 IMPLICIT REAL*8(A-H,O-Z) ANGL0022 DIMENSION IOB(NOR,4),DOB(NOR,4), A(NOR,6),RU(N),ICA(NOR, ANGL0023 @6),IB(N),RN(NR,NR) ,W(NO),CNAM(NSR),AP(NSR,12),DOBR(NOR,4) ANGL0024 DIST(XI,YI,XJ,YJ)=DSQRT((XJ-XI)**2+(YJ-YI)**2) ANGL0025 PI=3.141592653589793D0 ANGL0026 RO=3600.D0*180.D0/PI ANGL0027 IFR=IOB(I,2) ANGL0028 ITO1=IOB(I,3) ANGL0029 ITO2=IOB(I,4) ANGL0030 SIJ=DIST(AP(IFR,1),AP(IFR,2),AP(ITO1,1),AP(ITO1,2)) ANGL0031 SIK=DIST(AP(IFR,1),AP(IFR,2),AP(ITO2,1),AP(ITO2,2)) ANGL0032 C COMPUTE DESIGN MATRIX ELEMENTS ANGL0033 A(I,3)=(AP(IFR,2)-AP(ITO1,2))/SIJ**2*RO ANGL0034 A(I,4)=(AP(ITO1,1)-AP(IFR,1))/SIJ**2*RO ANGL0035 A(I,5)=(AP(ITO2,2)-AP(IFR,2))/SIK**2*RO ANGL0036 A(I,6)=(AP(IFR,1)-AP(ITO2,1))/SIK**2*RO ANGL0037 A(I,1)=-A(I,3)-A(I,5) ANGL0038 A(I,2)=-A(I,4)-A(I,6) ANGL0039 C COMPUTE WEIGHT ANGL0040 P=1.D0/DOBR(I,1)**2 ANGL0041 C ADD CONTRIBUTION TO NORMAL EQUATIONS ANGL0042 CALL NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) ANGL0043 IF(NCODE.EQ.1)GOTO2 ANGL0044 C COMPUTE MISCLOSURE IF ADJUSTMENT REQUESTED ANGL0045 AL=DATAN2(AP(ITO2,1)-AP(IFR,1),AP(ITO2,2)-AP(IFR,2)) ANGL0046 IF(AL.LT.0.0D0)AL=AL+2.0D0*PI ANGL0047 AL1=DATAN2(AP(ITO1,1)-AP(IFR,1),AP(ITO1,2)-AP(IFR,2)) ANGL0048 IF(AL1.LT.0.0D0)AL1=AL1+2.0D0*PI ANGL0049 AL=AL-AL1 ANGL0050 DOB1=(DOB(I,2)+DOB(I,3)/60.D0+DOB(I,4)/3600.D0)*PI/180.D0 ANGL0051 IF(AL.GE.0.0D0)GOTO1 ANGL0052 AL=AL+2.0D0*PI ANGL0053 IF((AL-DOB1).GT.DOB1)AL=AL-2.0D0*PI ANGL0054 1 W(I)=(AL-DOB1)*RO ANGL0055 C ADD CONTRIBUTION TO CONSTANT VECTOR ANGL0056 CALL WVEC(ICA,A,RU,W(I),P,N,NO,I,NOR) ANGL0057 C PRINT OBSERVATION INFORMATION AND MISCLOSURE IF ADJUSTMENT REQUESTED ANGL0058 2 IF(ITER.GT.0)GOTO4 ANGL0059 STD=DOBR(I,1) ANGL0060 IF(NCODE.EQ.1)GOTO3 ANGL0061 IDG=DOB(I,2) ANGL0062 IMN=DOB(I,3) ANGL0063 IDEG=DOBR(I,2) ANGL0064 IMIN=DOBR(I,3) ANGL0065 SEC=DOBR(I,4) ANGL0066 PRINT 101,CNAM(IFR),CNAM(ITO1),CNAM(ITO2),IDEG,IMIN,SEC ,STD,IDGANGL0067 @,IMN,DOB(I,4) ,W(I) ANGL0068 101 FORMAT(' ',7X,'ANGLE',9X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2,I6,I3, ANGL0069 @F6.2 ,F12.2,/) ANGL0070 GOTO4 ANGL0071 3 PRINT 102,CNAM(IFR),CNAM(ITO1),CNAM(ITO2), STD ANGL0072 102 FORMAT(' ',27X,'ANGLE',10X,A8,3X,A8,3X,A8,F9.2,/) ANGL0073 4 I=I+1 ANGL0074 RETURN ANGL0075 END ANGL0076 SUBROUTINE ASAZ(AP,I,J,GAZ,NSR) ASAZ0001 C***********************************************************************ASAZ0002 C* ASAZ0003 C* ASAZ COMPUTES THE APPROXIMATE GEODETIC AZIMUTH OF LINE I TO J FOR USASAZ0004 C* REDUCTION OF OBSERVATIONS TO ELLIPSOID ASAZ0005 C* ASAZ0006 C* ASAZ0007 C* INPUT: ASAZ0008 C* AP - DESCRIBED IN MAIN ASAZ0009 C* I - SEQUENCE NUMBER OF FIRST STATION ASAZ0010 C* J - SEQUENCE NUMBER OF SECOND STATION ASAZ0011 C* NSR - DESCRIBED IN MAIN ASAZ0012 C* ASAZ0013 C* OUTPUT: ASAZ0014 C* GAZ - COMPUTED APPROXIMATE GEODETIC AZIMUTH OF LINE I TO J (RAASAZ0015 C* ASAZ0016 C* ASAZ0017 C* WRITTEN BY: ASAZ0018 C* R.R. STEEVES, JUNE, 1978 ASAZ0019 C* ASAZ0020 C***********************************************************************ASAZ0021 IMPLICIT REAL*8(A-H,O-Z) ASAZ0022 DIMENSION AP(NSR,12) ASAZ0023 GAZ=DATAN2(AP(J,1)-AP(I,1),AP(J,2)-AP(I,2)) ASAZ0024 PI=3.141592653589793D0 ASAZ0025 IF(GAZ.LT.0.D0)GAZ=GAZ+2.D0*PI ASAZ0026 RO=3600.D0*180.D0/PI ASAZ0027 GAZ=GAZ+AP(I,12) ASAZ0028 IF(GAZ.LT.0.D0)GAZ=GAZ+2.D0*PI ASAZ0029 RETURN ASAZ0030 END ASAZ0031 SUBROUTINE AZIM(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, AZIM0001 @ITER,W,NOR,NSR,NR,CNAM,DOBR) AZIM0002 C***********************************************************************AZIM0003 C* AZIM0004 C* AZIM COMPUTES THE CONTRIBUTION OF AZIMUTH OBSERVATIONS TO THE NORMALAZIM0005 C* EQUATIONS AND CONSTANT VECTOR. AZIM0006 C* AZIM0007 C* AZIM0008 C* INPUT: AZIM0009 C* -ALL DESCRIBED IN MAIN AZIM0010 C* AZIM0011 C* AZIM0012 C* WRITTEN BY: AZIM0013 C* R.R. STEEVES, JUNE, 1976 AZIM0014 C* AZIM0015 C***********************************************************************AZIM0016 IMPLICIT REAL*8(A-H,O-Z) AZIM0017 DIMENSION IOB(NOR,4),DOB(NOR,4),AP(NSR,12),A(NOR,6),RU(N), AZIM0018 @ ICA(NOR,6),IB(N),RN(NR,NR) ,W(NO),CNAM(NSR),DOBR(NOR,4) AZIM0019 DIST(XI,YI,XJ,YJ)=DSQRT((XJ-XI)**2+(YJ-YI)**2) AZIM0020 PI=3.141592653589793D0 AZIM0021 RO=3600.0D0*180.D0/PI AZIM0022 IFR=IOB(I,2) AZIM0023 ITO=IOB(I,3) AZIM0024 SIJ=DIST(AP(IFR,1),AP(IFR,2),AP(ITO,1),AP(ITO,2)) AZIM0025 A(I,1)=(AP(IFR,2)-AP(ITO,2))/SIJ**2*RO AZIM0026 A(I,2)=(AP(ITO,1)-AP(IFR,1))/SIJ**2*RO AZIM0027 A(I,3)=-A(I,1) AZIM0028 A(I,4)=-A(I,2) AZIM0029 A(I,5)=0.D0 AZIM0030 A(I,6)=0.D0 AZIM0031 P=1.D0/DOBR(I,1)**2 AZIM0032 CALL NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) AZIM0033 IF(NCODE.EQ.1.AND.ITER.EQ.1)GOTO2 AZIM0034 IF(NCODE.EQ.1)GOTO1 AZIM0035 AL=DATAN2(AP(ITO,1)-AP(IFR,1),AP(ITO,2)-AP(IFR,2)) AZIM0036 IF(AL.LT.0.D0)AL=AL+2.D0*PI AZIM0037 W(I)=AL-(DOB(I,2)+DOB(I,3)/60.D0+DOB(I,4)/3600.D0)*PI/180.D0 AZIM0038 W(I)=W(I)*RO AZIM0039 CALL WVEC(ICA,A,RU,W(I),P,N,NO,I,NOR) AZIM0040 IF(ITER.GT.0)GOTO2 AZIM0041 IF(NCODE.EQ.1)GOTO1 AZIM0042 IDG=DOB(I,2) AZIM0043 IMN=DOB(I,3) AZIM0044 IDEG=DOBR(I,2) AZIM0045 IMIN=DOBR(I,3) AZIM0046 SEC=DOBR(I,4) AZIM0047 PRINT 101,CNAM(IFR),CNAM(IFR),CNAM(ITO),IDEG,IMIN,SEC,DOBR(I,1), AZIM0048 @ IDG ,IMN , DOB(I,4) ,W(I) AZIM0049 101 FORMAT(' ',7X,'AZIMUTH',7X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2,I6,I3, AZIM0050 @ F6.2 ,F12.2,/) AZIM0051 GOTO2 AZIM0052 1 PRINT 102,CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(I,1) AZIM0053 102 FORMAT(' ',27X,'AZIMUTH',8X,A8,3X,A8,3X,A8,F9.2,/) AZIM0054 2 I=I+1 AZIM0055 RETURN AZIM0056 END AZIM0057 SUBROUTINE CENERR(IOB,DOBR,NOR,AP,NSR,CENT,NO) CENERR01 C***********************************************************************CENERR02 C* CENERR03 C* CENERR ADDS CONTRIBUTION OF CENTERING ERRORS (IF SPECIFIED) TO STANDCENERR04 C* DEVIATIONS OF OBSERVATIONS. CENERR05 C* CENERR06 C* CENERR07 C* INPUT: CENERR08 C* -ALL DESCRIBED IN MAIN CENERR09 C* CENERR10 C* OUTPUT: CENERR11 C* -ALL DESCRIBED IN MAIN CENERR12 C* CENERR13 C* CENERR14 C* WRITTEN BY: CENERR15 C* R.R. STEEVES, AUG., 1978 CENERR16 C* CENERR17 C***********************************************************************CENERR18 IMPLICIT REAL*8(A-H,O-Z) CENERR19 DIMENSION AP(NSR,12),IOB(NOR,4),DOBR(NOR,4),CENT(4) CENERR20 RO=3600.D0*180.D0/3.141592653589793D0 CENERR21 DO 4 I=1,NO CENERR22 IA=IOB(I,2) CENERR23 IF=IOB(I,3) CENERR24 IT=IOB(I,4) CENERR25 SIJ=DSQRT((AP(IF,1)-AP(IA,1))**2+(AP(IF,2)-AP(IA,2))**2) CENERR26 IG=IABS(IOB(I,1)) CENERR27 GOTO(1,2,3,2),IG CENERR28 1 DOBR(I,1)=DSQRT(DOBR(I,1)**2+2.D0*CENT(1)**2) CENERR29 GOTO4 CENERR30 2 DOBR(I,1)=DSQRT(DOBR(I,1)**2+2.D0*(RO*CENT(IG)/SIJ)**2) CENERR31 GOTO4 CENERR32 3 SIK=DSQRT((AP(IT,1)-AP(IA,1))**2+(AP(IT,2)-AP(IA,2))**2) CENERR33 DOBR(I,1)=DSQRT(DOBR(I,1)**2+2.D0*(RO*CENT(3)/SIJ)**2+ CENERR34 @ 2.D0*(RO*CENT(3)/SIK)**2) CENERR35 4 CONTINUE CENERR36 RETURN CENERR37 END CENERR38 SUBROUTINE CHEK(N,NP,NB,NF,CNF,NFR,CPX,NPR,CBH,NBR,NO,N1,N2,N3,N4,CHEK0001 @ NZERO,ND,IDF) CHEK0002 C***********************************************************************CHEK0003 C* CHEK0004 C* CHEK CHECKS THAT ANY STATION WHICH IS FIXED, WEIGHTED OR HAS BLAHA CHEK0005 C* INFORMATION HAS ONLY ONE OF THESE OPTIONS. ALSO CHECKS FOR NEGATIVECHEK0006 C* DEGREES OF FREEDOM. CHEK0007 C* CHEK0008 C* CHEK0009 C* INPUT: CHEK0010 C* -ALL DESCRIBED IN MAIN CHEK0011 C* CHEK0012 C* OUTPUT: CHEK0013 C* -ALL DESCRIBED IN MAIN CHEK0014 C* CHEK0015 C* CHEK0016 C* WRITTEN BY: CHEK0017 C* R.R. STEEVES, JULY, 1978 CHEK0018 C* CHEK0019 C***********************************************************************CHEK0020 IMPLICIT REAL*8(A-H,O-Z) CHEK0021 DIMENSION CNF(NFR),CPX(NPR),CBH(NBR) CHEK0022 IF(NP.EQ.0.OR.NF.EQ.0)GOTO3 CHEK0023 DO 1 I=1,NF CHEK0024 DO 1 J=1,NP CHEK0025 IF(CNF(I).EQ.CPX(J))GOTO6 CHEK0026 1 CONTINUE CHEK0027 3 IF(NB.EQ.0.OR.NP.EQ.0)GOTO4 CHEK0028 DO 2 I=1,NP CHEK0029 DO 2 J=1,NB CHEK0030 IF(CPX(I).EQ.CBH(J))GOTO7 CHEK0031 2 CONTINUE CHEK0032 4 IF(NF.EQ.0.OR.NB.EQ.0)GOTO20 CHEK0033 DO 5 I=1,NF CHEK0034 DO 5 J=1,NB CHEK0035 IF(CNF(I).EQ.CBH(J))GOTO8 CHEK0036 5 CONTINUE CHEK0037 GOTO20 CHEK0038 6 PRINT101,CPX(J) CHEK0039 PRINT 102 CHEK0040 GOTO21 CHEK0041 7 PRINT103,CPX(I) CHEK0042 PRINT102 CHEK0043 GOTO21 CHEK0044 8 PRINT104,CNF(I) CHEK0045 PRINT102 CHEK0046 20 NP2=NP*2 CHEK0047 NN=N-NZERO CHEK0048 NS1=N1+N2+N3+N4+NP2 CHEK0049 NS2=NZERO+ND+NN CHEK0050 NS3=NS1-NS2 CHEK0051 IDF=NO+NP*2-N-ND CHEK0052 IF(IDF.GE.0)GOTO22 CHEK0053 PRINT105,IDF CHEK0054 PRINT106,N1,NZERO,N2,ND,N3,N4,NP2,NN,NS1,NS2,NS3 CHEK0055 21 STOP CHEK0056 101 FORMAT(' ','*** INPUT ERROR #011 *** STATION ',A8,'IS BOTH FIXED ACHEK0057 @ND WEIGHTED...') CHEK0058 102 FORMAT(' ','ONLY ONE OF THESE OPTIONS MAY BE CHOSEN FOR ANY ONE STCHEK0059 @ATION') CHEK0060 103 FORMAT(' ','*** INPUT ERROR #012 *** STATION ',A8,' IS BOTH WEIGHTCHEK0061 @ED AND BLAHA HELD...') CHEK0062 104 FORMAT(' ','*** INPUT ERROR #013 *** STATION ',A8,' IS BOTH FIXED CHEK0063 @AND BLAHA HELD...') CHEK0064 105 FORMAT(' ','*** INPUT ERROR #014 *** THE NUMBER OF DEGREES OF FREECHEK0065 @DOM IS ',I5,';MUST BE NON-NEGATIVE.') CHEK0066 106 FORMAT(' ',//,' ',3X,42('*'),/,' ',6X,'OBSERVATIONS',4X,'*',8X,'UNCHEK0067 @KNOWNS',/,' ',3X,42('*'),/,' ',3X,'DISTANCES',I8,' * ZERO ERRORCHEK0068 @',I9,/,' ',22X,'*',/,' ',3X,'DIRECTIONS',I7,' * ORIENTATION',I8CHEK0069 @,/,' ',22X,'*',/,' ',3X,'ANGLES',I11,' *',/,' ',22X,'*',/,' ',3X,CHEK0070 @'AZIMUTHS',I9,' *',/,' ',22X,'*',/,' ',3X,'COORDINATES',I6,' * CHEK0071 @ COORDINATES',I8,///,' ',3X,'TOTALS',I11,I25,3X,'-->',I10, CHEK0072 @ 2X,'DEGREES OF FREEDOM',///) CHEK0073 22 RETURN CHEK0074 END CHEK0075 SUBROUTINE CHKDEM(NS,NF,NFIX,NFR,NP,IPX,NPR,NB,IBH,NBR,NO,IOB,NOR,CHKDEM01 @CNAM,NSR,N1,N4) CHKDEM02 C***********************************************************************CHKDEM03 C* CHKDEM04 C* CHKDEM CHECKS THAT EACH FREE STATION IS AT LEAST UNIQUELY DETERMINEDCHKDEM05 C* IF NOT PROGRAM EXECUTION IS TERMINATED. A WARNING IS GIVEN IF A STACHKDEM06 C* IS DISCOVERED WHICH IS ONLY UNIQUELY DETERMINED. ALSO A CHECK IS MACHKDEM07 C* TO ASSURE THAT FIXED, WEIGHTED OR BLAHA STATIONS ARE TIED TO THE NETCHKDEM08 C* WORK. CHKDEM09 C* CHKDEM10 C* CHKDEM11 C* INPUT: CHKDEM12 C* -ALL DESCRIBED IN MAIN CHKDEM13 C* CHKDEM14 C* OUTPUT: CHKDEM15 C* -ALL DESCRIBED IN MAIN CHKDEM16 C* CHKDEM17 C* CHKDEM18 C* WRITTEN BY: CHKDEM19 C* R.R. STEEVES, AUG., 1978 CHKDEM20 C* CHKDEM21 C***********************************************************************CHKDEM22 IMPLICIT REAL*8(A-H,O-Z) CHKDEM23 DIMENSION NFIX(NFR),IPX(NPR),IBH(NBR),IOB(NOR,4),CNAM(NSR) CHKDEM24 NPC=0 CHKDEM25 NSTOP=0 CHKDEM26 NSUM=(NF+NP+NB)*2 CHKDEM27 IF(NSUM.EQ.0)GOTO20 CHKDEM28 IF(NSUM.GT.4)GOTO30 CHKDEM29 IF(NSUM.EQ.2.AND.N1.GT.0.AND.N4.GT.0)GOTO10 CHKDEM30 IF(NSUM.GE.4)GOTO10 CHKDEM31 IF(NSUM.EQ.2.AND.N1.EQ.0.AND.N4.EQ.0)GOTO21 CHKDEM32 IF(NSUM.EQ.2.AND.N1.EQ.0)GOTO22 CHKDEM33 IF(NSUM.EQ.2.AND.N4.EQ.0)GOTO23 CHKDEM34 10 DO 1 I=1,NS CHKDEM35 NDIR=0 CHKDEM36 NDIRT=0 CHKDEM37 NDIST=0 CHKDEM38 NAZM=0 CHKDEM39 NANG=0 CHKDEM40 IF(NF.EQ.0)GOTO2 CHKDEM41 DO 3 J=1,NF CHKDEM42 IF(I.EQ.NFIX(J))GOTO24 CHKDEM43 3 CONTINUE CHKDEM44 2 IF(NP.EQ.0)GOTO4 CHKDEM45 DO 5 J=1,NP CHKDEM46 IF(I.EQ.IPX(J))GOTO24 CHKDEM47 5 CONTINUE CHKDEM48 4 IF(NB.EQ.0)GOTO6 CHKDEM49 DO 7 J=1,NB CHKDEM50 IF(I.EQ.IBH(J))GOTO24 CHKDEM51 7 CONTINUE CHKDEM52 6 DO 8 J=1,NO CHKDEM53 IG=IABS(IOB(J,1)) CHKDEM54 IA=IOB(J,2) CHKDEM55 IF=IOB(J,3) CHKDEM56 IT=IOB(J,4) CHKDEM57 GOTO(11,12,13,14),IG CHKDEM58 11 IF(IA.EQ.I.OR.IF.EQ.I)NDIST=NDIST+1 CHKDEM59 GOTO9 CHKDEM60 12 IF(IA.EQ.I)NDIR=NDIR+1 CHKDEM61 IF(IF.EQ.I)NDIRT=NDIRT+1 CHKDEM62 GOTO9 CHKDEM63 13 IF(IA.EQ.I.OR.IF.EQ.I.OR.IT.EQ.I)NANG=NANG+1 CHKDEM64 GOTO9 CHKDEM65 14 IF(IA.EQ.I.OR.IF.EQ.I)NAZM=NAZM+1 CHKDEM66 9 NSUM=MAX0(NDIR-1,0)+NDIRT+NDIST+NAZM+NANG CHKDEM67 IF(NSUM.GT.2)GOTO1 CHKDEM68 8 CONTINUE CHKDEM69 NPC=NPC+1 CHKDEM70 IF(NPC.EQ.1)PRINT101 CHKDEM71 IF(NSUM.EQ.2)PRINT102,CNAM(I) CHKDEM72 IF(NSUM.LT.2)PRINT103,CNAM(I) CHKDEM73 IF(NSUM.LT.2)NSTOP=1 CHKDEM74 GOTO1 CHKDEM75 24 NSUM=0 CHKDEM76 DO 25 J=1,NO CHKDEM77 IA=IOB(J,2) CHKDEM78 IF=IOB(J,3) CHKDEM79 IT=IOB(J,4) CHKDEM80 IF(I.EQ.IA.OR.I.EQ.IF.OR.I.EQ.IT)NSUM=NSUM+1 CHKDEM81 IF(NSUM.GE.1)GOTO1 CHKDEM82 25 CONTINUE CHKDEM83 NSTOP=1 CHKDEM84 NPC=NPC+1 CHKDEM85 IF(NPC.EQ.1)PRINT101 CHKDEM86 PRINT104,CNAM(I) CHKDEM87 1 CONTINUE CHKDEM88 GOTO90 CHKDEM89 20 NSTOP=1 CHKDEM90 NPC=NPC+1 CHKDEM91 IF(NPC.EQ.1)PRINT101 CHKDEM92 PRINT105 CHKDEM93 GOTO10 CHKDEM94 21 NSTOP=1 CHKDEM95 NPC=NPC+1 CHKDEM96 IF(NPC.EQ.1)PRINT101 CHKDEM97 PRINT106 CHKDEM98 GOTO10 CHKDEM99 22 NSTOP=1 CHKDE100 NPC=NPC+1 CHKDE101 IF(NPC.EQ.1)PRINT101 CHKDE102 PRINT107 CHKDE103 GOTO10 CHKDE104 23 NSTOP=1 CHKDE105 NPC=NPC+1 CHKDE106 IF(NPC.EQ.1)PRINT101 CHKDE107 PRINT108 CHKDE108 GOTO10 CHKDE109 30 NPC=NPC+1 CHKDE110 IF(NPC.EQ.1)PRINT101 CHKDE111 PRINT109 CHKDE112 GOTO10 CHKDE113 90 IF(NSTOP.EQ.1)STOP CHKDE114 101 FORMAT('1') CHKDE115 102 FORMAT(' ','*** WARNING *** STATION ',A8,' IS ONLY UNIQUELY DETERMCHKDE116 @INED.',/) CHKDE117 103 FORMAT(' ','*** INPUT ERROR #031 *** STATION ',A8,' IS NOT DETERMCHKDE118 @INED; MORE OBSERVATIONS REQUIRED.') CHKDE119 104 FORMAT(' ','*** INPUT ERROR #032 FIXED WEIGHTED OR BLAHA STATION CHKDE120 @',A8,' IS NOT PROPERLY TIED TO NETWORK:',/,' ',10X, CHKDE121 @' MORE OBSERVATIONS ARE REQUIRED',/) CHKDE122 105 FORMAT(' ','*** INPUT ERROR #033 THERE IS NO POSITION CONSTRAINT: CHKDE123 @ MUST BE AT LEAST 1 FIXED,WEIGHTED OR BLAHA STATION',/) CHKDE124 106 FORMAT(' ','*** INPUT ERROR #034 THERE ARE NO ORIENTATION OR SCALCHKDE125 @E CONSTRAINTS: ',/,' ','WITH ONLY 1 FIXED,WEIGHTED OR BLAHA STATIOCHKDE126 @N BOTH A DISTANCE AND AN AZIMUTH OBSERVATION MUST BE GIVEN',/) CHKDE127 107 FORMAT(' ','*** INPUT ERROR #035 *** THERE IS NO SCALE CONSTRAINT:CHKDE128 @',/,' ','WITH ONLY 1 FIXED,WEIGHTED OR BLAHA STATION, AT LEAST 1 DCHKDE129 @ISTANCE OBSERVATION MUST BE GIVEN',/) CHKDE130 108 FORMAT(' ','*** INPUT ERROR #036 *** THERE IS NO ORIENTATION CONSTCHKDE131 @RAINT',/,' ','WITH ONLY 1 FIXED,WEIGHTED OR BLAHA STATION, AT LEASCHKDE132 @T ONE AZIMUTH OBSERVATION MUST BE GIVEN',/) CHKDE133 109 FORMAT(' ','*** WARNING *** MORE STATION CONSTRAINTS THAN THE MINICHKDE134 @MUM NECESSARY ARE BEING USED',/) CHKDE135 RETURN CHKDE136 END CHKDE137 SUBROUTINE CHKDIV(ITER,X,NINC,CERR,NSR,NR,NB,NF,NS,CONVG) CHKDIV01 C***********************************************************************CHKDIV02 C* CHKDIV03 C* CHKDIV CHECKS FOR SOLUTION DIVERGENCE BY DETERMINING IF THE ITERATIVCHKDIV04 C* CORRECTIONS INCREASE IN ABSOLUTE VALUE MORE THAN ONCE. THE PROGRAM CHKDIV05 C* TERMINATED IF DIVERGENCE IS DETECTED. CHKDIV06 C* CHKDIV07 C* CHKDIV08 C* INPUT: CHKDIV09 C* -ALL DESCRIBED IN MAIN CHKDIV10 C* CHKDIV11 C* OUTPUT: CHKDIV12 C* -ALL DESCRIBED IN MAIN CHKDIV13 C* CHKDIV14 C* CHKDIV15 C* WRITTEN BY: CHKDIV16 C* R.R. STEEVES, AUG., 1978 CHKDIV17 C* CHKDIV18 C***********************************************************************CHKDIV19 IMPLICIT REAL*8(A-H,O-Z) CHKDIV20 DIMENSION CERR(NR),X(NR) CHKDIV21 NC=(NS-NB-NF)*2 CHKDIV22 IF(ITER.EQ.0)NINC=0 CHKDIV23 IF(ITER.GT.0)GOTO1 CHKDIV24 DO 2 I=1,NC CHKDIV25 2 CERR(I)=DABS(X(I)) CHKDIV26 RETURN CHKDIV27 1 DO 3 I=1,NC CHKDIV28 IF(CERR(I).LT.DABS(X(I)).AND.DABS(X(I)).GT.CONVG)GOTO4 CHKDIV29 3 CONTINUE CHKDIV30 GOTO5 CHKDIV31 4 NINC=NINC+1 CHKDIV32 IF(NINC.EQ.2)GOTO6 CHKDIV33 5 DO 7 I=1,NC CHKDIV34 7 CERR(I)=DABS(X(I)) CHKDIV35 RETURN CHKDIV36 6 PRINT101 CHKDIV37 101 FORMAT(//,' ','*** ERROR #044 *** PROGRAM TERMINATED DUE TO SOLUTCHKDIV38 @ION DIVERGENCE ; CHECK INPUT DATA',/) CHKDIV39 STOP CHKDIV40 END CHKDIV41 SUBROUTINE CHKMIS(W,NOR,NO,WANGC,WDISC,IOB,DOB,CNAM,NSR,NUNIT) CHKMIS01 C***********************************************************************CHKMIS02 C* CHKMIS03 C* CHKMIS CHECKS FOR LARGE MISCLOSURES ON ZEROTH ITERATION; IF ANY ARE CHKMIS04 C* TECTED THIS INFORMATION IS PRINTED AND THE PROGRAM IS TERMINATED. CHKMIS05 C* CHKMIS06 C* CHKMIS07 C* INPUT: CHKMIS08 C* -ALL DESCRIBED IN MAIN CHKMIS09 C* CHKMIS10 C* OUTPUT: CHKMIS11 C* -ALL DESCRIBED IN MAIN CHKMIS12 C* CHKMIS13 C* CHKMIS14 C* WRITTEN BY: CHKMIS15 C* R.R. STEEVES, AUG, 1978 CHKMIS16 C* CHKMIS17 C***********************************************************************CHKMIS18 IMPLICIT REAL*8(A-H,O-Z) CHKMIS19 DIMENSION W(NOR),IOB(NOR,4),DOB(NOR,4),CNAM(NSR) CHKMIS20 DATA UM,UF/' METRES ',' FEET '/ CHKMIS21 U=UM CHKMIS22 IF(NUNIT.EQ.1)U=UF CHKMIS23 ICNT=0 CHKMIS24 DO 5 I=1,NO CHKMIS25 IG=IABS(IOB(I,1)) CHKMIS26 IA=IOB(I,2) CHKMIS27 IF=IOB(I,3) CHKMIS28 IT=IOB(I,4) CHKMIS29 GOTO(1,2,3,4),IG CHKMIS30 1 IF(DABS(W(I)).LE.WDISC)GOTO5 CHKMIS31 IF(ICNT.EQ.0)PRINT101,WDISC,U,WANGC CHKMIS32 ICNT=1 CHKMIS33 PRINT102,CNAM(IA),CNAM(IA),CNAM(IF),DOB(I,3),W(I),U CHKMIS34 GOTO5 CHKMIS35 2 IF(DABS(W(I)).LE.WANGC)GOTO5 CHKMIS36 IF(ICNT.EQ.0)PRINT101,WDISC,U,WANGC CHKMIS37 ICNT=1 CHKMIS38 IDEG=DOB(I,2) CHKMIS39 IMIN=DOB(I,3) CHKMIS40 PRINT103,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,DOB(I,4),W(I) CHKMIS41 GOTO5 CHKMIS42 3 IF(DABS(W(I)).LE.WANGC)GOTO5 CHKMIS43 IF(ICNT.EQ.0)PRINT101,WDISC,U,WANGC CHKMIS44 ICNT=1 CHKMIS45 IDEG=DOB(I,2) CHKMIS46 IMIN=DOB(I,3) CHKMIS47 PRINT104,CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN,DOB(I,4),W(I) CHKMIS48 GOTO5 CHKMIS49 4 IF(DABS(W(I)).LE.WANGC)GOTO5 CHKMIS50 IF(ICNT.EQ.0)PRINT101,WDISC,U,WANGC CHKMIS51 ICNT=1 CHKMIS52 IDEG=DOB(I,2) CHKMIS53 IMIN=DOB(I,3) CHKMIS54 PRINT105,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,DOB(I,4),W(I) CHKMIS55 5 CONTINUE CHKMIS56 IF(ICNT.EQ.1)STOP CHKMIS57 101 FORMAT('1',16X,'PROGRAM EXECUTION WAS TERMINATED DUE TO THE FOLLOWCHKMIS58 @ING UNACCEPTABLE MISCLOSURES',/,' ',16X,78('-'),/,' ',17X,'(CRITERCHKMIS59 @IA: DISTANCE ->',F10.3,A8,'; ANGULAR ->',F10.1,' SECONDS)',//, CHKMIS60 @' ',20X,12X,'AT',8X,'FROM',6X,'TO',9X,'OBSERVATION',5X,'MISCLOSURECHKMIS61 @',/) CHKMIS62 102 FORMAT(' ',20X,'DISTANCE',4X,3(A8,2X),F11.3,4X,F11.3,A8,/) CHKMIS63 103 FORMAT(' ',20X,'DIRECTION',3X,3(A8,2X),I4,I3,F5.1,2X,F11.1,2X,'SECCHKMIS64 @ONDS',/) CHKMIS65 104 FORMAT(' ',20X,'ANGLE',7X,3(A8,2X),I4,I3,F5.1,2X,F11.1,2X,'SECONDSCHKMIS66 @',/) CHKMIS67 105 FORMAT(' ',20X,'AZIMUTH',5X,3(A8,2X),I4,I3,F5.1,2X,F11.1,2X,'SECONCHKMIS68 @DS',/) CHKMIS69 RETURN CHKMIS70 END CHKMIS71 SUBROUTINE CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,IM,NZERO,NZ) CODE0001 C***********************************************************************CODE0002 C* CODE0003 C* CODE COMPUTES COLUMN CODES FOR THE DESIGN MATRIX A. CODE0004 C* CODE0005 C* CODE0006 C* INPUT: CODE0007 C* -ALL DESCRIBED IN MAIN CODE0008 C* CODE0009 C* CODE0010 C* WRITTEN BY: CODE0011 C* R.R. STEEVES, JUNE, 1978 CODE0012 C* CODE0013 C***********************************************************************CODE0014 IMPLICIT REAL*8(A-H,O-Z) CODE0015 DIMENSION DOB(NOR,4),IOB(NOR,4),FAC(5),ICA(NOR,6),IC(NSR,2) CODE0016 DO 20 I=1,NO CODE0017 IF(IM.EQ.2)GOTO18 CODE0018 DOB(I,1)=DOB(I,1)*FAC(IABS(IOB(I,1))) CODE0019 IF(IOB(I,1).EQ.1) DOB(I,2)=DOB(I,2)*FAC(5) CODE0020 18 ICA(I,1)=IC(IOB(I,2),1) CODE0021 ICA(I,2)=IC(IOB(I,2),2) CODE0022 ICA(I,3)=IC(IOB(I,3),1) CODE0023 ICA(I,4)=IC(IOB(I,3),2) CODE0024 IF(IOB(I,1).EQ.3)GOTO19 CODE0025 ICA(I,5)=0 CODE0026 IF(IOB(I,1).EQ.1.AND.NZERO.EQ.1)ICA(I,5)=NZ CODE0027 ICA(I,6)=0 CODE0028 GOTO20 CODE0029 19 ICA(I,5)=IC(IOB(I,4),1) CODE0030 ICA(I,6)=IC(IOB(I,4),2) CODE0031 20 CONTINUE CODE0032 RETURN CODE0033 END CODE0034 SUBROUTINE COL(NFIX,NF,IC,NS,NSR,NFR,NB,IBH,NBR) COL00001 C***********************************************************************COL00002 C* COL00003 C* COL COMPUTES COLUMN CODES FOR THE NORMAL EQUATIONS. COL00004 C* COL00005 C* COL00006 C* INPUT: COL00007 C* -ALL DESCRIBED IN MAIN COL00008 C* COL00009 C* COL00010 C* WRITTEN BY: COL00011 C* R.R. STEEVES, MAY, 1976 COL00012 C* COL00013 C***********************************************************************COL00014 DIMENSION NFIX(NFR),IC(NSR,2),IBH(NBR) COL00015 K=1 COL00016 DO 1 I=1,NS COL00017 IF(NB.EQ.0)GOTO5 COL00018 DO 6 J=1,NB COL00019 IF(I.EQ.IBH(J))GOTO4 COL00020 6 CONTINUE COL00021 5 IF(NF.EQ.0)GOTO2 COL00022 DO 3 J=1,NF COL00023 IF(I.EQ.NFIX(J))GOTO4 COL00024 3 CONTINUE COL00025 2 IC(I,1)=K COL00026 IC(I,2)=K+1 COL00027 K=K+2 COL00028 GOTO1 COL00029 4 IC(I,1)=0 COL00030 IC(I,2)=0 COL00031 1 CONTINUE COL00032 RETURN COL00033 END COL00034 SUBROUTINE DELQX(RN,NR,SBH,NB2R,A,ICA,NOR,NZERO,NB,N,IC,OX,IOB, DELQX001 @ DOB,IBH,NBR,NO,RU,ICP,AP,NSR,IB,WX,CNAM,DOBR,NS,W,CBH,NPR,NP2R, DELQX002 @ NFR,FAC,NFIX,NF,B) DELQX003 C***********************************************************************DELQX004 C* DELQX005 C* DELQX COMPUTES AND ADDS CONTRIBUTION TO INVERSE OF NORMAL EQUATIONS DELQX006 C* FOR THE CASE WITH BLAHA STATIONS. DELQX007 C* DELQX008 C* DELQX009 C* INPUT: DELQX010 C* -ALL DESCRIBED IN MAIN DELQX011 C* DELQX012 C* DELQX013 C* WRITTEN BY: DELQX014 C* R.R. STEEVES, JULY, 1978 DELQX015 C* DELQX016 C***********************************************************************DELQX017 IMPLICIT REAL*8(A-H,O-Z) DELQX018 INTEGER*4 R1,S1 DELQX019 DIMENSION RN(NR,NR),SBH(NB2R,NB2R),A(NOR,6),ICA(NOR,6),IC(NSR,2), DELQX020 @ IOB(NOR,4),DOB(NOR,4),IBH(NBR),RU(NR),ICP(NR),AP(NSR,12), DELQX021 @ CBH(NBR),W(NOR), AA(20,6),P(20),NFIX(NFR),FAC(5), DELQX022 @ OX(NPR,2),IB(NR),WX(NP2R),CNAM(NSR),DOBR(NOR,4),U(20,20), DELQX023 @ B(NOR,6) DELQX024 NB2=NB*2 DELQX025 C PUT ZERO ERROR AT END DELQX026 NN=N+NB2-1 DELQX027 NZ=NN+1 DELQX028 NM=N DELQX029 N1=N-NZERO DELQX030 IF(NZERO.EQ.0)GOTO4 DELQX031 DO 1 I=1,N1 DELQX032 RN(I,NZ)=RN(I,NM) DELQX033 RN(I,NM)=0.D0 DELQX034 1 CONTINUE DELQX035 RN(NZ,NZ)=RN(NM,NM) DELQX036 RN(NM,NM)=0.D0 DELQX037 DO 2 I=NM,NN DELQX038 RN(I,NZ)=0.D0 DELQX039 2 CONTINUE DELQX040 C CLEAR NEW COLUMNS DELQX041 4 IF(NZERO.EQ.0)NM=NM+1 DELQX042 IF(NZERO.EQ.0)NN=NN+1 DELQX043 NSZ=NN+NZERO DELQX044 DO 5 I=1,NN DELQX045 DO 5 J=NM,NN DELQX046 IF(J.LT.I)GOTO5 DELQX047 RN(I,J)=0.D0 DELQX048 5 CONTINUE DELQX049 C UPDATE IC AND ICA DELQX050 CALL COL(NFIX,NF,IC,NS,NSR,NFR,0,IBH,NBR) DELQX051 CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,2,NZERO,NZ) DELQX052 C ADD SBH TO RN DELQX053 DO 6 I=1,NSZ DELQX054 6 IB(I)=1 DELQX055 CALL XOBS(1,RN,RU,NN,SBH,NB,IBH,ICP,AP,OX,IB,NS,IC,WX,NR,NP2R, DELQX056 @ NB2R,NSR,CNAM,NPR,NBR) DELQX057 C REPLACE A BY PA IN B DELQX058 MAX=NM-1 DELQX059 I=1 DELQX060 10 IF(IOB(I,1).EQ.2)GOTO20 DELQX061 DO 11 J=1,6 DELQX062 B(I,J)=A(I,J)/DOBR(I,1)**2 DELQX063 11 CONTINUE DELQX064 GOTO40 DELQX065 20 II=I+20 DELQX066 DO 21 J=I,II DELQX067 M=J DELQX068 IF(IOB(J,1).EQ.-2)GOTO22 DELQX069 21 CONTINUE DELQX070 22 NUM=M-I+1 DELQX071 DO 25 J=I,M DELQX072 K=J-I+1 DELQX073 25 P(K)=1.D0/DOBR(J,1)**2 DELQX074 SUM=0.D0 DELQX075 DO 26 J=1,NUM DELQX076 26 SUM=SUM+P(J) DELQX077 DO 27 J=1,NUM DELQX078 DO 27 K=1,NUM DELQX079 U(J,K)=-P(J)*P(K)/SUM DELQX080 IF(J.EQ.K)U(J,K)=U(J,K)+P(K) DELQX081 27 CONTINUE DELQX082 DO 28 L1=1,NUM DELQX083 DO 28 L2=1,6 DELQX084 SUM=0.D0 DELQX085 DO 29 K=1,NUM DELQX086 KK=K+I-1 DELQX087 SUM=SUM+A(KK,L2)*U(L1,K) DELQX088 29 CONTINUE DELQX089 AA(L1,L2)=SUM DELQX090 28 CONTINUE DELQX091 DO 30 L1=1,NUM DELQX092 II=L1+I-1 DELQX093 DO 30 L2=1,6 DELQX094 B(II,L2)=AA(L1,L2) DELQX095 30 CONTINUE DELQX096 I=I+NUM-1 DELQX097 40 I=I+1 DELQX098 IF(I.LE.NO)GOTO10 DELQX099 DO 45 I=2,NB2 DELQX100 K=I-1 DELQX101 DO 45 J=2,K DELQX102 SBH(I,J)=SBH(J,I) DELQX103 45 CONTINUE DELQX104 C COMPUTE AND ADD DQX TO RN DELQX105 DO 90 I=1,N1 DELQX106 DO 90 J=I,N1 DELQX107 C I,J OF DQX DELQX108 SUMDQ=0.D0 DELQX109 DO 80 J1=1,NO DELQX110 C I,J1 OF MBTD DELQX111 SUMBD=0.D0 DELQX112 DO 41 K=1,NO DELQX113 C K,I OF BM DELQX114 CALL ELEBM(K,I,SBM,ICA,B,NOR,RN,NR) DELQX115 C K,J1 OF D DELQX116 CALL ELEMD(K,J1,SD,ICA,A,NOR,SBH,NB2R,MAX,NZ) DELQX117 SUMBD=SUMBD+SBM*SD DELQX118 41 CONTINUE DELQX119 C J1,J OF BM DELQX120 CALL ELEBM(J1,J,SBM,ICA,B,NOR,RN,NR) DELQX121 SUMDQ=SUMDQ+SUMBD*SBM DELQX122 80 CONTINUE DELQX123 IF(I.EQ.J)GOTO81 DELQX124 RN(J,I)=SUMDQ DELQX125 GOTO90 DELQX126 81 RU(I)=SUMDQ DELQX127 90 CONTINUE DELQX128 DO 100 I=1,N1 DELQX129 DO 100 J=I,N1 DELQX130 IF(I.EQ.J)GOTO101 DELQX131 RN(I,J)=RN(I,J)+RN(J,I) DELQX132 RN(J,I)=RN(I,J) DELQX133 GOTO100 DELQX134 101 RN(I,I)=RN(I,I)+RU(I) DELQX135 100 CONTINUE DELQX136 IF(NZERO.EQ.0)GOTO110 DELQX137 DO 120 I=1,N1 DELQX138 RN(NM,I)=RN(I,NZ) DELQX139 120 RN(I,NM)=RN(I,NZ) DELQX140 RN(NM,NM)=RN(NZ,NZ) DELQX141 110 CALL COL(NFIX,NF,IC,NS,NSR,NFR,NB,IBH,NBR) DELQX142 CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,2,NZERO,N) DELQX143 RETURN DELQX144 END DELQX145 SUBROUTINE DIRN(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, DIRN0001 @ ITER,W,NOR,NSR,NR,CNAM,DOBR) DIRN0002 C***********************************************************************DIRN0003 C* DIRN0004 C* DIRN COMPUTES THE CONTRIBUTION OF DIRECTION OBSERVATIONS TO THE NORMDIRN0005 C* EQUATIONS AND CONSTANT VECTOR. ORIENTATION UNKNOWNS ARE ELIMINATED.DIRN0006 C* DIRN0007 C* DIRN0008 C* INPUT: DIRN0009 C* -ALL DESCRIBED IN MAIN DIRN0010 C* DIRN0011 C* DIRN0012 C* WRITTEN BY: DIRN0013 C* R.R. STEEVES, JUNE, 1978 DIRN0014 C* DIRN0015 C***********************************************************************DIRN0016 IMPLICIT REAL*8(A-H,O-Z) DIRN0017 DIMENSION IOB(NOR,4),DOB(NOR,4),AP(NSR,12),A(NOR,6),RU(N), DIRN0018 @ ICA(NOR,6),IB(N),RN(NR,NR) ,P(20),W(NO),U(20,20),CNAM(NSR) DIRN0019 @ ,DOBR(NOR,4) DIRN0020 DIST(XI,YI,XJ,YJ)=DSQRT((XJ-XI)**2+(YJ-YI)**2) DIRN0021 II=I+20 DIRN0022 DO 1 J=I,II DIRN0023 M=J DIRN0024 IF(IOB(J,1).EQ.-2.OR.IABS(IOB(J,1)).NE.2)GOTO2 DIRN0025 1 CONTINUE DIRN0026 2 NUM=M-I+1 DIRN0027 IF(IABS(IOB(M,1)).NE.2)NUM=NUM-1 DIRN0028 IF(IABS(IOB(M,1)).NE.2)IOB(M-1,1)=-2 DIRN0029 PI=3.141592653589793D0 DIRN0030 RO=3600.D0*180.D0/PI DIRN0031 DO 5 J=I,M DIRN0032 IFR=IOB(J,2) DIRN0033 ITO=IOB(J,3) DIRN0034 SIJ=DIST(AP(IFR,1),AP(IFR,2),AP(ITO,1),AP(ITO,2)) DIRN0035 A(J,1)=(AP(IFR,2)-AP(ITO,2))/SIJ**2*RO DIRN0036 A(J,2)=(AP(ITO,1)-AP(IFR,1))/SIJ**2*RO DIRN0037 A(J,3)=-A(J,1) DIRN0038 A(J,4)=-A(J,2) DIRN0039 A(J,5)=0.D0 DIRN0040 A(J,6)=0.D0 DIRN0041 K=J-I+1 DIRN0042 P(K)=1.D0/DOBR(J,1)**2 DIRN0043 IF(NCODE.EQ.1.AND.ITER.EQ.1)GOTO5 DIRN0044 IF(NCODE.EQ.1)GOTO4 DIRN0045 IF(J.GT.I)GOTO3 DIRN0046 D1=(DOB(J,2)+DOB(J,3)/60.D0+DOB(J,4)/3600.D0)*PI/180.D0 DIRN0047 Z=DATAN2(AP(ITO,1)-AP(IFR,1),AP(ITO,2)-AP(IFR,2)) DIRN0048 IF(Z.LT.0.D0)Z=Z+2.D0*PI DIRN0049 3 AL=DATAN2(AP(ITO,1)-AP(IFR,1),AP(ITO,2)-AP(IFR,2)) DIRN0050 IF(AL.LT.0.D0)AL=AL+2.D0*PI DIRN0051 IF(AL.LT.Z)AL=AL+2.D0*PI DIRN0052 W(J)=AL-Z-(DOB(J,2)+DOB(J,3)/6D1+DOB(J,4)/36D2)*PI/18D1+D1 DIRN0053 W(J)=W(J)*RO DIRN0054 IF(ITER.GT.0)GOTO5 DIRN0055 IF(NCODE.EQ.1)GOTO4 DIRN0056 IDG=DOB(J,2) DIRN0057 IMN=DOB(J,3) DIRN0058 IDEG=DOBR(J,2) DIRN0059 IMIN=DOBR(J,3) DIRN0060 SEC=DOBR(J,4) DIRN0061 PRINT 101,K,CNAM(IFR),CNAM(IFR),CNAM(ITO),IDEG,IMIN,SEC, DIRN0062 @ DOBR(J,1),IDG,IMN,DOB(J,4),W(J) DIRN0063 101 FORMAT(' ',7X,'DIRECTION',I3,2X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2, DIRN0064 @ I6,I3,F6.2, F12.2,/) DIRN0065 GOTO5 DIRN0066 4 PRINT 102,K,CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(J,1) DIRN0067 102 FORMAT(' ',27X,'DIRECTION',I3,3X,A8,3X,A8,3X,A8,F9.2,/) DIRN0068 5 CONTINUE DIRN0069 SUM=0.D0 DIRN0070 DO 6 J=1,NUM DIRN0071 6 SUM=SUM+P(J) DIRN0072 DO 7 J=1,NUM DIRN0073 DO 7 K=1,NUM DIRN0074 U(J,K)=-P(J)*P(K)/SUM DIRN0075 IF(J.EQ.K)U(J,K)=U(J,K)+P(K) DIRN0076 7 CONTINUE DIRN0077 DO 8 J=I,M DIRN0078 DO 8 K=I,M DIRN0079 DO 8 L1=1,4 DIRN0080 DO 8 L2=1,4 DIRN0081 IF(ICA(J,L1).GT.ICA(K,L2))GOTO8 DIRN0082 IF(ICA(J,L1).EQ.0.OR.ICA(K,L2).EQ.0)GOTO8 DIRN0083 RN(ICA(J,L1),ICA(K,L2))=RN(ICA(J,L1),ICA(K,L2))+A(J,L1)*A(K,L2)* DIRN0084 @ U(J-I+1,K-I+1) DIRN0085 IF(ICA(J,L1).LT.IB(ICA(K,L2)))IB(ICA(K,L2))=ICA(J,L1) DIRN0086 8 CONTINUE DIRN0087 IF(NCODE.EQ.1)GOTO10 DIRN0088 DO 9 J=I,M DIRN0089 DO 9 K=1,NUM DIRN0090 DO 9 L=1,4 DIRN0091 IF(ICA(J,L).EQ.0)GOTO9 DIRN0092 RU(ICA(J,L))=RU(ICA(J,L))+A(J,L)*U(J-I+1,K)*W(K+I-1) DIRN0093 9 CONTINUE DIRN0094 10 I=I+NUM DIRN0095 RETURN DIRN0096 END DIRN0097 SUBROUTINE DIST(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, DIST0001 @ NZERO,ITER,W,NOR,NSR,NR,ZER,CNAM,DOBR) DIST0002 C***********************************************************************DIST0003 C* DIST0004 C* DIST COMPUTES THE CONTRIBUTION OF DISTANCE OBSERVATIONS TO THE NORMADIST0005 C* EQUATIONS AND CONSTANT VECTOR. DIST0006 C* DIST0007 C* DIST0008 C* INPUT: DIST0009 C* -ALL DESCRIBED IN MAIN DIST0010 C* DIST0011 C* DIST0012 C* WRITTEN BY: DIST0013 C* R.R. STEEVES, JUNE, 1976 DIST0014 C* DIST0015 C***********************************************************************DIST0016 IMPLICIT REAL*8(A-H,O-Z) DIST0017 DIMENSION IOB(NOR,4),DOB(NOR,4),AP(NSR,12),A(NOR,6),ICA(NOR,6), DIST0018 @IB(N),RN(NR,NR) ,RU(N),W(NO),CNAM(NSR),DOBR(NOR,4) DIST0019 DISE(XI,YI,XJ,YJ)=DSQRT((XJ-XI)**2+(YJ-YI)**2) DIST0020 IFR=IOB(I,2) DIST0021 ITO=IOB(I,3) DIST0022 SIJ=DISE(AP(IFR,1),AP(IFR,2),AP(ITO,1),AP(ITO,2)) DIST0023 A(I,1)=(AP(IFR,1)-AP(ITO,1))/SIJ DIST0024 A(I,2)=(AP(IFR,2)-AP(ITO,2))/SIJ DIST0025 A(I,3)=-A(I,1) DIST0026 A(I,4)=-A(I,2) DIST0027 A(I,5)=0.D0 DIST0028 A(I,6)=0.D0 DIST0029 IF(NZERO.EQ.0)GOTO1 DIST0030 A(I,5)=-1.0D0 DIST0031 ICA(I,5)=N DIST0032 1 P=1.D0/DOBR(I,1)**2 DIST0033 CALL NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) DIST0034 IF(NCODE.EQ.1)GOTO4 DIST0035 W(I)=SIJ-DOB(I,3)-ZER DIST0036 CALL WVEC(ICA,A,RU,W(I),P,N,NO,I,NOR) DIST0037 4 IF(ITER.GT.0)GOTO3 DIST0038 STD=DOBR(I,1) DIST0039 IF(NCODE.EQ.1)GOTO2 DIST0040 PRINT 101,CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(I,3),STD,DOB(I,3), DIST0041 @W(I) DIST0042 101 FORMAT(' ',7X,'DISTANCE',6X,A8,2X,A8,2X,A8,F12.3,F10.3,F14.3, DIST0043 @F13.3,/) DIST0044 GOTO3 DIST0045 2 PRINT 102,CNAM(IFR),CNAM(IFR),CNAM(ITO),STD DIST0046 102 FORMAT(' ',27X,'DISTANCE',7X,A8,3X,A8,3X,A8,F9.3,/) DIST0047 3 I=I+1 DIST0048 RETURN DIST0049 END DIST0050 SUBROUTINE DMSRAD(IDEG,IMIN,SEC,RAD) DMSRAD01 C***********************************************************************DMSRAD02 C* DMSRAD03 C* THIS ROUTINE CONVERTS AN ANGLE FROM DEGREES,MINUTES AND SECONDSDMSRAD04 C* TO RADIANS. DMSRAD05 C* DMSRAD06 C* DMSRAD07 C* INPUT: DMSRAD08 C* IDEG-DEGREES DMSRAD09 C* IMIN-MINUTES DMSRAD10 C* SEC -SECONDS DMSRAD11 C* DMSRAD12 C* OUTPUT: DMSRAD13 C* RAD -THE ANGLE IN RADIANS DMSRAD14 C* DMSRAD15 C* DMSRAD16 C* WRITTEN BY: DMSRAD17 C* G. BOWIE, JUNE, 1977 DMSRAD18 C* MODIFIED BY: DMSRAD19 C* R.R. STEEVES, JUNE, 1978 DMSRAD20 C* DMSRAD21 C***********************************************************************DMSRAD22 IMPLICIT REAL *8(A-H,O-Z) DMSRAD23 DEG=IABS(IDEG)+IABS(IMIN)/60.D0+DABS(SEC)/3600.D0 DMSRAD24 RAD=DEG*3.141592653589793D0/180.D0 DMSRAD25 RAD=RAD*ISIGN(1,IDEG) DMSRAD26 IF(IDEG.EQ.0)RAD=RAD*ISIGN(1,IMIN) DMSRAD27 IF(IDEG.EQ.0.AND.IMIN.EQ.0)RAD=RAD*DSIGN(1.D0,SEC) DMSRAD28 RETURN DMSRAD29 END DMSRAD30 SUBROUTINE ELEBM(K,I,SBM,ICA,B,NOR,RN,NR) ELEBM001 C***********************************************************************ELEBM002 C* ELEBM003 C* ELEBM COMPUTES PART OF THE CORRECTION TO THE COVARIANCE MATRIX WHEN ELEBM004 C* BLAHA STATIONS ARE USED. ELEBM005 C* ELEBM006 C* ELEBM007 C* WRITTEN BY: ELEBM008 C* R.R. STEEVES, JULY, 1978 ELEBM009 C* ELEBM010 C***********************************************************************ELEBM011 IMPLICIT REAL*8(A-H,O-Z) ELEBM012 DIMENSION ICA(NOR,6),B(NOR,6),RN(NR,NR) ELEBM013 SBM=0.D0 ELEBM014 DO 1 J=1,6 ELEBM015 IF(ICA(K,J).EQ.0)GOTO1 ELEBM016 II=MIN0(I,ICA(K,J)) ELEBM017 JJ=MAX0(I,ICA(K,J)) ELEBM018 SBM=SBM+B(K,J) *RN(II,JJ) ELEBM019 1 CONTINUE ELEBM020 RETURN ELEBM021 END ELEBM022 SUBROUTINE ELEMD(L,J1,SD,ICA,A,NOR,SBH,NB2R,MAX,NZ) ELEMD001 C***********************************************************************ELEMD002 C* ELEMD003 C* ELEMD COMPUTES PART OF THE CORRECTION TO THE COVARIANCE MATRIX WHEN ELEMD004 C* BLAHA STATIONS ARE USED. ELEMD005 C* ELEMD006 C* ELEMD007 C* WRITTEN BY: ELEMD008 C* R.R. STEEVES, JULY, 1978 ELEMD009 C* ELEMD010 C***********************************************************************ELEMD011 IMPLICIT REAL*8(A-H,O-Z) ELEMD012 INTEGER R1,S1 ELEMD013 DIMENSION ICA(NOR,6),A(NOR,6),SBH(NB2R,NB2R) ELEMD014 SD=0.D0 ELEMD015 DO 60 R1=1,6 ELEMD016 DO 60 S1=1,6 ELEMD017 IF(ICA(L,R1).GT.MAX.AND.ICA(L,R1).NE.NZ.AND.ICA(J1,S1).GT.MAX ELEMD018 @ .AND.ICA(J1,S1).NE.NZ)SD=SD+A(L,R1)*A(J1,S1)* ELEMD019 @ SBH(ICA(L,R1)-MAX,ICA(J1,S1)-MAX) ELEMD020 60 CONTINUE ELEMD021 RETURN ELEMD022 END ELEMD023 SUBROUTINE ELIPS(QXX,QXY,QYY,A,B,C,PHI) ELIPS001 C***********************************************************************ELIPS002 C* ELIPS003 C* ELIPS COMPUTES THE SEMI-MAJOR AND SEMI-MINOR AXES AND THE ORIENTATIOELIPS004 C* (AZIMUTH OF THE MAJOR AXIS) OF THE ERROR ELLIPSE SPECIFIED BY QXX, QELIPS005 C* QXY AND THE FACTOR C. ELIPS006 C* ELIPS007 C* ELIPS008 C* INPUT: ELIPS009 C* QXX,QXY,QYY- ELEMENTS OF THE 2 BY 2 COVARIANCE MATRIX OF THE VARIELIPS010 C* FOR WHICH AN ERROR ELLIPSE IS REQUIRED ELIPS011 C* C- FACTOR FOR THE ELLIPSE IN RAISING IT TO A SPECIFIC ELIPS012 C* PROBABILITY LEVEL (COMPUTED IN ERREL) ELIPS013 C* ELIPS014 C* OUTPUT: ELIPS015 C* A,B- SEMI-MAJOR AND SEMI-MINOR AXES OF THE ELLIPSE ELIPS016 C* PHI- AZIMUTH OF THE MAJOR AXIS (IN RADIANS) ELIPS017 C* ELIPS018 C* ELIPS019 C* WRITTEN BY: ELIPS020 C* R.R. STEEVES, APRIL, 1976 ELIPS021 C* ELIPS022 C***********************************************************************ELIPS023 IMPLICIT REAL*8(A-H,O-Z) ELIPS024 P1=(QXX+QYY)/2.D0 ELIPS025 P2=DSQRT((QXX-QYY)**2/4.0D0+QXY**2) ELIPS026 A=DSQRT(P1+P2)*C ELIPS027 B=DSQRT(P1-P2)*C ELIPS028 PI=3.141592653589793D0 ELIPS029 IF(QXX.LT.1.D0-20.AND.QYY.LT.1.D0-20)PHI=0.D0 ELIPS030 IF(QXX.LT.1.D0-20.AND.QYY.LT.1.D0-20)GOTO1 ELIPS031 PHI=-0.5D0*DATAN2(-2.D0*QXY,QYY-QXX) ELIPS032 IF(PHI.LT.0.D0)PHI=PHI+2.D0*PI ELIPS033 1 RETURN ELIPS034 END ELIPS035 SUBROUTINE ELTSP(PHI,ELAM,E,A,C1,C2,R,CHI,SLAM,ESK) ELTSP001 C***********************************************************************ELTSP002 C* ELTSP003 C* THIS ROUTINE TRANSFORMS ELLIPSOIDAL COORDINATES PHI,ELAM TO ELTSP004 C* SPHERICAL (CONFORMAL SPHERE) COORDINATES CHI,SLAM AND COMPUTES ELTSP005 C* THE CORRESPONDING POINT SCALE FACTOR ESK (ELLIPSOID TO SPHERE). ELTSP006 C* THE POINT SCALE FACTOR AT THE ORIGIN OF THIS CONFORMAL PROJECTIONELTSP007 C* IS UNITY. ELTSP008 C* ELTSP009 C* INPUT: ELTSP010 C* PHI - ELLIPSOIDAL LATITUDE OF THE POINT, IN RADIANS. ELTSP011 C* ELAM - ELLIPSOIDAL LONGITUDE OF THE POINT, IN RADIANS. ELTSP012 C* (POSITIVE EAST OF GREENWICH). ELTSP013 C* E - FIRST ECCENTRICITY OF THE ELLIPSOID (COMPUTED IN ELTSP014 C* SUBROUTINE STGINL). ELTSP015 C* A - SEMI-MAJOR AXES OF THE REFERENCE ELLIPSOID. ELTSP016 C* C1 - CONSTANT COMPUTED IN STGINL. ELTSP017 C* C2 - CONSTANT COMPUTED IN STGINL. ELTSP018 C* R - RADIUS OF THE CONFORMAL SPHERE (COMPUTED IN STGINL). ELTSP019 C* ELTSP020 C* OUTPUT: ELTSP021 C* CHI - SPHERICAL LATITUDE OF THE POINT, IN RADIANS. ELTSP022 C* SLAM - SPHERICAL LONGITUDE OF THE POINT, IN RADIANS. ELTSP023 C* ESK - POINT SCALE FACTOR AT THE POINT,FROM THE ELLIPSOID ELTSP024 C* TO THE SPHERE. ELTSP025 C* ELTSP026 C* ELTSP027 C* WRITTEN BY: ELTSP028 C* R.R. STEEVES, JULY, 1977 ELTSP029 C* ELTSP030 C***********************************************************************ELTSP031 IMPLICIT REAL*8(A-H,O-Z) ELTSP032 SP=DSIN(PHI) ELTSP033 PI4=3.141592653589793D0/4.D0 ELTSP034 CHI=DATAN(C2*(DTAN(PI4+PHI/2.D0)*((1.D0-E*SP)/(1.D0+E*SP))**(E/2.DELTSP035 1 0))**C1) ELTSP036 CHI=2.D0*(CHI-PI4) ELTSP037 SLAM=C1*ELAM ELTSP038 RN=A/DSQRT(1.D0-E**2*SP**2) ELTSP039 ESK=C1*R*DCOS(CHI)/RN/DCOS(PHI) ELTSP040 RETURN ELTSP041 END ELTSP042 SUBROUTINE ERREL(RN,NR,N,IC,NS,NELPS,NSIMU,NVARF,AP,NSR,A,NOR, ERREL001 @ CERR,ALPHA,IDF,NF,NB,CNAM,VARF,NMULT,NCODE,NSTAN,NUNIT,ICER,TL, ERREL002 @CNF,NFR,CPX,NPR,PX,NPXR,FAC,X,D, IOB,DOB,CIO,NO,CENT,CBH,NBR, ERREL003 @BH,NBHR, NPRCX,NABST) ERREL004 C***********************************************************************ERREL005 C* ERREL006 C* ERREL COMPUTES STATION AND RELATIVE ELLIPSES AND PRINTS THEM. ERREL007 C* ERREL008 C* ERREL009 C* INPUT: ERREL010 C* -ALL DESCRIBED IN MAIN ERREL011 C* ERREL012 C* OUTPUT: ERREL013 C* -ALL DESCRIBED IN MAIN ERREL014 C* ERREL015 C* ERREL016 C* WRITTEN BY: ERREL017 C* R.R. STEEVES, AUG., 1978 ERREL018 C* ERREL019 C***********************************************************************ERREL020 IMPLICIT REAL*8(A-H,O-Z) ERREL021 REAL*4 FLOAT,DF,RALP,RX,SNGL ERREL022 DIMENSION RN(NR,NR),IC(NSR,2),AP(NSR,12),A(NOR,6),CERR(NSR), ERREL023 @ CNAM(NSR),NCOL(4),Q(10),ICER(NSR),CNF(NFR),CPX(NPR),PX(NPXR), ERREL024 @FAC(5),X(NR),D(NR),IOB(NOR,4),DOB(NOR,4),CIO(NOR,3),CENT(4), ERREL025 @CBH(NBR),BH(NBHR),TL(10) ERREL026 ALPH=1.D0-ALPHA/100.D0 ERREL027 PI=3.141592653589793D0 ERREL028 RO=3600.D0/PI*180.D0 ERREL029 DATA UF,UM,VKN,VUN,WAS,WASN/'(FEET) ','(METRES)','KNOWN) ',ERREL030 @ 'UNKNOWN)',' WAS ','WAS NOT '/ ERREL031 IF(IDF.EQ.0.AND.NVARF.EQ.0)NSTAN=2 ERREL032 IF(NUNIT.EQ.0)UNIT=UM ERREL033 IF(NUNIT.EQ.1)UNIT=UF ERREL034 IF(NVARF.EQ.0)VKNO=VUN ERREL035 IF(NVARF.EQ.1)VKNO=VKN ERREL036 IF(NMULT.EQ.0)WMUL=WASN ERREL037 IF(NMULT.EQ.1)WMUL=WAS ERREL038 IF(NSTAN.EQ.2.AND.NELPS.LT.2)PRINT101,UNIT ERREL039 IF(NSTAN.NE.2.AND.NELPS.LT.2)PRINT102,ALPHA,UNIT ERREL040 NSTA=NS-NB ERREL041 IF(NSTAN.EQ.2)GOTO3 ERREL042 IF(NVARF.EQ.0)GOTO1 ERREL043 RALP=SNGL(ALPHA/100.D0) ERREL044 CALL MDCHI(RALP,2.0,RX,IER) ERREL045 FAK=DSQRT(DBLE(RX)) ERREL046 GOTO2 ERREL047 1 CALL F2DI(ALPH,IDF,XX) ERREL048 FAK=DSQRT(2.D0*XX) ERREL049 GOTO2 ERREL050 3 FAK=1.D0 ERREL051 GOTO4 ERREL052 2 IF(NELPS.LT.2)PRINT103,VKNO,FAK ERREL053 4 IF(NELPS.LT.2.AND.IDF.GT.0.AND.NCODE.EQ.2)PRINT104,WMUL,VARF ERREL054 IF(NELPS.GT.1)GOTO20 ERREL055 PRINT105 ERREL056 SUMA=0.D0 ERREL057 DO 5 I=1,NSTA ERREL058 IF(IC(I,1).EQ.0)GOTO5 ERREL059 QXX=RN(IC(I,1),IC(I,1)) ERREL060 QYY=RN(IC(I,2),IC(I,2)) ERREL061 QXY=RN(IC(I,1),IC(I,2)) ERREL062 CALL ELIPS(QXX,QXY,QYY,AX,BX,FAK,PHI) ERREL063 CALL RADMS(PHI,IDP,IMP,SP) ERREL064 IP=SP ERREL065 AR=AX*BX*PI ERREL066 PRINT106,CNAM(I),AX,BX,IDP,IMP,IP,AR ERREL067 SUMA=SUMA+AR ERREL068 5 CONTINUE ERREL069 PRINT107,SUMA ERREL070 20 IF(NELPS.EQ.1)GOTO30 ERREL071 NSREL=0 ERREL072 DO 8 I=1,NS ERREL073 IF(IC(I,1).NE.0)NSREL=NSREL+1 ERREL074 IF(NSREL.GT.1)GOTO9 ERREL075 8 CONTINUE ERREL076 GOTO30 ERREL077 9 IF(NSTAN.EQ.2)PRINT108,UNIT ERREL078 IF(NSTAN.NE.2)PRINT109,ALPHA,UNIT ERREL079 IF(NSTAN.NE.2)PRINT103,VKNO,FAK ERREL080 IF(IDF.GT.0.AND.NCODE.EQ.2)PRINT104,WMUL,VARF ERREL081 PRINT110 ERREL082 NS1=NSTA-1 ERREL083 DO 6 I=1,NS1 ERREL084 K=I+1 ERREL085 NCOL(1)=IC(I,1) ERREL086 NCOL(2)=IC(I,2) ERREL087 DO 6 J=K,NSTA ERREL088 NCOL(3)=IC(J,1) ERREL089 NCOL(4)=IC(J,2) ERREL090 IF(NCOL(1).EQ.0.OR .NCOL(3).EQ.0)GOTO6 ERREL091 DO 7 L=1,10 ERREL092 7 Q(L)=0.D0 ERREL093 KI=1 ERREL094 DO 47 II=1,4 ERREL095 KK=II+1 ERREL096 IF(NCOL(II).NE.0)Q(KI)=RN(NCOL(II),NCOL(II)) ERREL097 KI=KI+1 ERREL098 IF(II.EQ.4)GOTO47 ERREL099 DO 45 JJ=KK,4 ERREL100 IF(NCOL(II).NE.0.AND.NCOL(JJ).NE.0)Q(KI)=RN(NCOL(II),NCOL(JJ)) ERREL101 45 KI=KI+1 ERREL102 47 CONTINUE ERREL103 QXX=Q(8)-2.D0*Q(3)+Q(1) ERREL104 QXY=Q(9)-Q(6)-Q(4)+Q(2) ERREL105 QYY=Q(10)-2.D0*Q(7)+Q(5) ERREL106 CALL ELIPS(QXX,QXY,QYY,AX,BX,FAK,PHI) ERREL107 CALL RADMS(PHI,IDP,IMP,SP) ERREL108 IP=SP ERREL109 SIJ=DSQRT((AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2) ERREL110 IPR=SIJ/AX ERREL111 CALL SDADIS(I,J,IC,NSR,RN,NR,SIJ,AP,STDIS) ERREL112 CALL SDAAZM(I,J,IC,NSR,RN,NR,SIJ,AP,STDAZ) ERREL113 PRINT111,CNAM(I),CNAM(J),AX,BX,IDP,IMP,IP,SIJ,IPR,STDIS,STDAZ ERREL114 6 CONTINUE ERREL115 30 IF(NSIMU.EQ.0)RETURN ERREL116 IF(IDF.EQ.0)RETURN ERREL117 NRCOD=2 ERREL118 29 CALL READ(TL,1,NCODE,1,1,NSTAN,0,NUNIT,NELPS,1,1,1,1,0,NMULT,1, ERREL119 @CNF,NFR,1,1,CPX,NPR,PX,NPXR,ALPHA,FAC,CNAM,NSR,AP,NS,X,D,NR,IOB, ERREL120 @NOR,DOB,CIO,NO,1,N,1,1.D0,CENT,1,1,1,1,1,1,CBH,BH,NBR,NBHR, ERREL121 @1,1,1,1,1,CERR,NSIMU,1,0,0,0,0,NPRCX,0,1,1,NVARF,0,NRCOD,1.D0, ERREL122 @1.D0,NABST) ERREL123 IF(NRCOD.EQ.3)RETURN ERREL124 CALL MAKICE(ICER,CERR,CNAM,NSR,NS,NSTA) ERREL125 IF(NSTA.EQ.0)GOTO29 ERREL126 IF(NSTAN.EQ.2)PRINT201,UNIT ERREL127 IF(NSTAN.NE.2)PRINT202,ALPHA,UNIT ERREL128 IF(NVARF.EQ.0)GOTO31 ERREL129 RALP=SNGL(1.D0-ALPH/DFLOAT(NSTA)) ERREL130 CALL MDCHI(RALP,2.0,RX,IER) ERREL131 FAK=DSQRT(DBLE(RX)) ERREL132 GOTO32 ERREL133 31 ALPS=ALPH/DFLOAT(NSTA) ERREL134 CALL F2DI(ALPS,IDF,XX) ERREL135 FAK=DSQRT(2.D0*XX) ERREL136 32 IF(NCODE.EQ.2)PRINT104,WMUL,VARF ERREL137 PRINT209,VKNO,FAK ERREL138 PRINT105 ERREL139 SUMA=0.D0 ERREL140 DO 35 I=1,NSTA ERREL141 IN=ICER(I) ERREL142 IF(IC(I,1).EQ.0)GOTO35 ERREL143 QXX=RN(IC(IN,1),IC(IN,1)) ERREL144 QYY=RN(IC(IN,2),IC(IN,2)) ERREL145 QXY=RN(IC(IN,1),IC(IN,2)) ERREL146 CALL ELIPS(QXX,QXY,QYY,AX,BX,FAK,PHI) ERREL147 CALL RADMS(PHI,IDP,IMP,SP) ERREL148 IP=SP ERREL149 AR=AX*BX*PI ERREL150 PRINT106,CNAM(IN),AX,BX,IDP,IMP,IP,AR ERREL151 SUMA=SUMA+AR ERREL152 35 CONTINUE ERREL153 PRINT107,SUMA ERREL154 IF(NSTA.EQ.1)GOTO29 ERREL155 IF(NSTAN.EQ.2)PRINT207,UNIT ERREL156 IF(NSTAN.NE.2)PRINT208,ALPHA,UNIT ERREL157 IF(NCODE.EQ.2)PRINT104,WMUL,VARF ERREL158 PRINT209,VKNO,FAK ERREL159 PRINT205 ERREL160 NS1=NSTA-1 ERREL161 DO 36 I=1,NS1 ERREL162 IN=ICER(I) ERREL163 K=I+1 ERREL164 NCOL(1)=IC(IN,1) ERREL165 NCOL(2)=IC(IN,2) ERREL166 DO 36 J=K,NSTA ERREL167 JN=ICER(J) ERREL168 NCOL(3)=IC(JN,1) ERREL169 NCOL(4)=IC(JN,2) ERREL170 IF(NCOL(1).EQ.0.OR .NCOL(3).EQ.0)GOTO36 ERREL171 DO 37 L=1,10 ERREL172 37 Q(L)=0.D0 ERREL173 KI=1 ERREL174 DO 57 II=1,4 ERREL175 KK=II+1 ERREL176 IF(NCOL(II).NE.0)Q(KI)=RN(NCOL(II),NCOL(II)) ERREL177 KI=KI+1 ERREL178 IF(II.EQ.4)GOTO57 ERREL179 DO 55 JJ=KK,4 ERREL180 IF(NCOL(II).NE.0.AND.NCOL(JJ).NE.0)Q(KI)=RN(NCOL(II),NCOL(JJ)) ERREL181 55 KI=KI+1 ERREL182 57 CONTINUE ERREL183 QXX=Q(8)-2.D0*Q(3)+Q(1) ERREL184 QXY=Q(9)-Q(6)-Q(4)+Q(2) ERREL185 QYY=Q(10)-2.D0*Q(7)+Q(5) ERREL186 CALL ELIPS(QXX,QXY,QYY,AX,BX,FAK,PHI) ERREL187 CALL RADMS(PHI,IDP,IMP,SP) ERREL188 IP=SP ERREL189 SIJ=DSQRT((AP(JN,1)-AP(IN,1))**2+(AP(JN,2)-AP(IN,2))**2) ERREL190 IPR=SIJ/AX ERREL191 PRINT206,CNAM(IN),CNAM(JN),AX,BX,IDP,IMP,IP,SIJ,IPR ERREL192 36 CONTINUE ERREL193 GOTO29 ERREL194 101 FORMAT('1',32X,'STATION STANDARD CONFIDENCE ELLIPSES ',A8,/,' ', ERREL195 @ 32X,36('-'),//) ERREL196 102 FORMAT('1',32X,'STATION',F7.3,' % CONFIDENCE ELLIPSES ',A8,/,' ', ERREL197 @ 32X,36('-'),//) ERREL198 103 FORMAT(' ',4X,'FACTOR USED FOR OBTAINING THESE ELLIPSES FROM STANDERREL199 @ARD ELLIPSES: (VARIANCE FACTOR ',A8,' =',F9.4,/) ERREL200 104 FORMAT(' ',4X,'(COVARIANCE MATRIX OF PARAMETERS ',A8,'MULTIPLIED BERREL201 @Y THE ESTIMATED VARIANCE FACTOR (',F12.6,' )).',//) ERREL202 105 FORMAT(' ',10X,'STATION',3X,'SEMI-MAJOR AXIS',3X,'SEMI-MINOR AXIS'ERREL203 @,3X,'AZIMUTH OF SEMI-MAJOR AXIS',3X,'AREA OF ELLIPSE',/) ERREL204 106 FORMAT(' ',10X,A8,F12.4,6X,F12.4,7X,I9,I4,I4,13X,D12.5,/) ERREL205 107 FORMAT(//,' ',33X,'TOTAL AREA OF STATION ELLIPSES =',D12.5) ERREL206 108 FORMAT('1',32X,'RELATIVE STANDARD CONFIDENCE ELLIPSES ',A8,/,' ', ERREL207 @32X,37('-'),//) ERREL208 109 FORMAT('1',32X,'RELATIVE',F7.3,' % CONFIDENCE ELLIPSES ',A8,/, ERREL209 @' ',32X,37('-'),//) ERREL210 110 FORMAT(' ',2X,44X,'AZIMUTH',31X,'STD.DEV.',7X,'STD.DEV.',/,' ', ERREL211 @2X,'FROM',5X,'TO',7X,'SEMI-MAJOR',3X,'SEMI-MINOR',4X,'MAJOR',6X, ERREL212 @'DISTANCE',3X,'PRECISION',4X,'ADJ.DISTANCE',3X,'ADJ.AZIMUTH',/) ERREL213 111 FORMAT(' ',2X,A8,1X,A8,1X,F8.4,5X,F8.4,2X,I5,I3,I3,1X,F11.4,3X, ERREL214 @'1:',I8,2X,F9.4,6X,F8.2,/) ERREL215 201 FORMAT('1',27X,'SIMULTANEOUS STATION STANDARD CONFIDENCE ELLIPSES ERREL216 @',A8,/,' ',27X,49('-'),//) ERREL217 202 FORMAT('1',27X,'SIMULTANEOUS STATION',F7.3,' % CONFIDENCE ELLIPSESERREL218 @ ',A8,/,' ',27X,49('-'),//) ERREL219 205 FORMAT(' ',16X,44X,'AZIMUTH',/,' ',16X,'FROM',5X,'TO', 7X,'SEMI-MAERREL220 @JOR',3X,'SEMI-MINOR',4X,'MAJOR',6X,'DISTANCE',3X,'PRECISION',/) ERREL221 206 FORMAT(' ',16X,A8,1X,A8,F9.4,5X,F8.4,I7,I3,I3,1X,F11.4,3X,'1:', ERREL222 @I8,/) ERREL223 207 FORMAT('1',27X,'SIMULTANEOUS RELATIVE STANDARD CONFIDENCE ELLIPSESERREL224 @ ',A8,/,' ',27X,50('-'),//) ERREL225 208 FORMAT('1',27X,'SIMULTANEOUS RELATIVE',F7.3,' % CONFIDENCE ELLIPSEERREL226 @S ',A8,/,' ',27X,50('-'),//) ERREL227 209 FORMAT(' ',19X,'FACTOR FOR OBTAINING THESE ELLIPSES (VARIANCE FACTERREL228 @OR ',A8, '=',F8.3,//) ERREL229 END ERREL230 SUBROUTINE FILAP(AP,NSR,NPROJ,NUNIT,AA,BB,NS,RP,RL,XO,YO,X1,Y1, FILAP001 @ Z1,R1,RKO) FILAP002 C***********************************************************************FILAP003 C* FILAP004 C* FILAP COMPUTES ELLIPSOIDAL COORDINATES OF STATIONS, RADII OF CURVATUFILAP005 C* OF ELLIPSOID AT STATIONS AND THE POINT SCALE FACTOR AND MERIDIAN FILAP006 C* CONVERGENCE FOR EACH STATION IF A SPECIFIC MAP-PROJECTION IS REQUESTFILAP007 C* ALL THIS INFORMATION IS STORED, ALONG WIGH APPROXIMATE COORDINATES, FILAP008 C* HEIGHTS AND DEFLECTION COMPONENTS, IN THE MATRIX AP. FILAP009 C* FILAP010 C* FILAP011 C* INPUT: FILAP012 C* -ALL DESCRIBED IN MAIN FILAP013 C* FILAP014 C* OUTPUT: FILAP015 C* AA,BB- SEMI MAJOR AND SEMI MINOR AXES OF THE REFERENCE ELLIPSOIFILAP016 C* AP,RL- ELLIPSOIDAL COORDINATES OF THE ORIGIN OF THE MAP PROJECTFILAP017 C* USED. FILAP018 C* XO,YO- GRID COORDINATES OF THE ORIGIN OF THE PROJECTION FILAP019 C* X1,Y1,Z1-TRANSLATION COMPONENTS FROM THE GEOCENTRE TO THE CENTRE FILAP020 C* OF THE REFERENCE ELLIPSOID FILAP021 C* R1- RADIUS OF THE STEREOGRAPHIC CONFORMAL SPHERE (IF THIS FILAP022 C* PROJECTION IS USED) FILAP023 C* RKO- SCALE FACTOR AT THE ORIGIN OF THE MAP PROJECTION FILAP024 C* FILAP025 C* NOTE: ALL ITEMS IN THE OUTPUT LIST ABOVE ARE ASSIGNED VALUES IFILAP026 C* ROUTINE. FILAP027 C* FILAP028 C* FILAP029 C* WRITTEN BY: FILAP030 C* R.R. STEEVES, JULY, 1978 FILAP031 C* FILAP032 C***********************************************************************FILAP033 IMPLICIT REAL*8(A-H,O-Z) FILAP034 DIMENSION AP(NSR,12) FILAP035 EN(PHI)=AA/DSQRT(1.D0-ESQ*DSIN(PHI)**2) FILAP036 EM(PHI)=AA*(1.D0-ESQ)/DSQRT((1.D0-ESQ*DSIN(PHI)**2)**3) FILAP037 FAK=1.D0 FILAP038 IF(NUNIT.EQ.1)FAK=0.3048D0 FILAP039 AA=6378206.4D0/FAK FILAP040 BB=6356583.8D0/FAK FILAP041 X1=-15.D0/FAK FILAP042 Y1=150.D0/FAK FILAP043 Z1=180.D0/FAK FILAP044 ESQ=(AA**2-BB**2)/AA**2 FILAP045 RP=0.D0 FILAP046 GOTO( 5,10,15,20,25),NPROJ FILAP047 5 CALL DMSRAD(46,30,0.D0,RP) FILAP048 CALL DMSRAD(-66,30,0.D0,RL) FILAP049 IF(NUNIT.EQ.1)GOTO6 FILAP050 XO=300000.D0 FILAP051 YO=800000.D0 FILAP052 GOTO7 FILAP053 6 XO=1000000.D0 FILAP054 YO=1000000.D0 FILAP055 7 RKO=0.999912D0 FILAP056 GOTO30 FILAP057 10 CALL DMSRAD(47,15,0.D0,RP) FILAP058 CALL DMSRAD(-63,0,0.D0,RL) FILAP059 IF(NUNIT.EQ.1)GOTO11 FILAP060 XO=700000.D0 FILAP061 YO=400000.D0 FILAP062 GOTO12 FILAP063 11 XO=1000000.D0 FILAP064 YO=1000000.D0 FILAP065 12 RKO=0.999912D0 FILAP066 GOTO30 FILAP067 15 GOTO30 FILAP068 20 CALL DMSRAD(-61,30,0.D0,RL) FILAP069 IF(NUNIT.EQ.1)GOTO21 FILAP070 XO=4500000.D0 FILAP071 GOTO22 FILAP072 21 XO=1000000.D0 FILAP073 22 RKO=0.9999D0 FILAP074 GOTO30 FILAP075 25 CALL DMSRAD(-64,30,0.D0,RL) FILAP076 RP=0.D0 FILAP077 IF(NUNIT.EQ.1)GOTO26 FILAP078 XO=5500000.D0 FILAP079 GOTO27 FILAP080 26 XO=1000000.D0 FILAP081 27 RKO=0.9999D0 FILAP082 30 IF(NPROJ.LT.3)CALL STGINL(RP,RL,AA,BB,R,C1,C2,E,CHIO,SLAMO) FILAP083 IF(NPROJ.LT.3)R1=R FILAP084 DO 40 I=1,NS FILAP085 IF(NPROJ.GT.3)GOTO31 FILAP086 CALL PLTSP(AP(I,1),AP(I,2),XO,YO,RKO,R,CHIO,SLAMO,CHI,SLAM) FILAP087 CALL SPTEL(CHI,SLAM,C1,C2,E,PHI,ELAM) FILAP088 CALL ELTSP(PHI,ELAM,E,AA,C1,C2,R,CHI,SLAM,ESK) FILAP089 CALL SPTPL(CHI,SLAM,XO,YO,RKO,CHIO,SLAMO,R,X,Y,SPK,C) FILAP090 SF=ESK*SPK FILAP091 GOTO32 FILAP092 31 CALL TMXYPL(AP(I,1),AP(I,2),AA,BB,RKO,XO,RL,PHI,ELAM) FILAP093 DLAM=ELAM-RL FILAP094 CALL TMSFMC(PHI,DLAM,RKO,AA,BB,SF,C) FILAP095 32 AP(I,11)=SF FILAP096 AP(I,9)=PHI FILAP097 AP(I,10)=ELAM FILAP098 AP(I,7)=EN(PHI) FILAP099 AP(I,8)=EM(PHI) FILAP100 AP(I,12)=C FILAP101 40 CONTINUE FILAP102 RETURN FILAP103 END FILAP104 SUBROUTINE FILDOR(IOB,DOB,DOBR,NO,NOR,NCENT,AP,NSR,CENT) FILDOR01 C***********************************************************************FILDOR02 C* FILDOR03 C* FILDOR COMPUTES STANDARD DEVIATIONS OF OBSERVATIONS AND STORES THEM FILDOR04 C* IN DOBR. FILDOR05 C* FILDOR06 C* FILDOR07 C* INPUT: FILDOR08 C* -ALL DESCRIBED IN MAIN FILDOR09 C* FILDOR10 C* FILDOR11 C* WRITTEN BY: FILDOR12 C* R.R. STEEVES, JULY, 1978 FILDOR13 C* FILDOR14 C***********************************************************************FILDOR15 IMPLICIT REAL*8(A-H,O-Z) FILDOR16 DIMENSION IOB(NOR,4),DOB(NOR,4),DOBR(NOR,4),AP(NSR,12),CENT(4) FILDOR17 DO 3 I=1,NO FILDOR18 IF(IOB(I,1).EQ.1)GOTO2 FILDOR19 DOBR(I,1)=DOB(I,1) FILDOR20 DO 1 J=2,4 FILDOR21 DOBR(I,J)=DOB(I,J) FILDOR22 1 CONTINUE FILDOR23 GOTO3 FILDOR24 2 DOBR(I,3)=DOB(I,3) FILDOR25 IA=IOB(I,2) FILDOR26 IF=IOB(I,3) FILDOR27 SIJ=DSQRT((AP(IF,1)-AP(IA,1))**2+(AP(IF,2)-AP(IA,2))**2) FILDOR28 DOBR(I,1)=DSQRT(DOB(I,1)**2+(DOB(I,2)*SIJ*1.D-6)**2) FILDOR29 3 CONTINUE FILDOR30 IF(NCENT.EQ.0)GOTO4 FILDOR31 CALL CENERR(IOB,DOBR,NOR,AP,NSR,CENT,NO) FILDOR32 4 CONTINUE FILDOR33 RETURN FILDOR34 END FILDOR35 SUBROUTINE FORMPX(OX,AP,NPR,NSR,NP,NP2,SPX,NP2R,PX,NPXR,NCOV,IB, FORMPX01 @ NR,RU,D,IPX,X,CONVG,CNAM,NS,IOB,NOR,IC,ICA,W,CPX,WX,NO,IPB) FORMPX02 C***********************************************************************FORMPX03 C* FORMPX04 C* FORMPX FORMS THE A PRIORI WEIGHT OR COVARIANCE MATRIX FOR WEIGHTED OFORMPX05 C* BLAHA STATIONS FROM THE VECTOR OF ELEMENTS (PX) READ. IT ALSO STOREFORMPX06 C* COORDINATES OF WEIGHTED STATIONS FOR USE IN COMPUTING THE CORRESPONDFORMPX07 C* MISCLOSURES. ALSO ECHOES THE FORMED MATRIX. FORMPX08 C* FORMPX09 C* FORMPX10 C* INPUT: FORMPX11 C* -ALL DESCRIBED IN MAIN FORMPX12 C* FORMPX13 C* OUTPUT: FORMPX14 C* SPX- THE A PRIORI WEIGHT OR COVARIANCE MATRIX FORMPX15 C* FORMPX16 C* FORMPX17 C* WRITTEN BY: FORMPX18 C* R.R. STEEVES, JUNE, 1976 FORMPX19 C* FORMPX20 C***********************************************************************FORMPX21 IMPLICIT REAL*8(A-H,O-Z) FORMPX22 DIMENSION OX(NPR,2),AP(NSR,12),SPX(NP2R,NP2R),PX(NPXR),IB(NR), FORMPX23 @ RU(NR),D(NR),IPX(NPR),X(NR),CNAM(NSR),IOB(NOR,4),IC(NSR,2), FORMPX24 @ ICA(NOR,6),W(NOR),CPX(NPR),WX(NP2R) FORMPX25 IF(NCOV.EQ.0.AND.IPB.EQ.1)ICODE=24 FORMPX26 IF(NCOV.EQ.1.AND.IPB.EQ.1)ICODE=25 FORMPX27 IF(NCOV.EQ.0.AND.IPB.EQ.2)ICODE=27 FORMPX28 IF(NCOV.EQ.1.AND.IPB.EQ.2)ICODE=26 FORMPX29 IF(IPB.EQ.2)GOTO6 FORMPX30 C RETAIN THE COORDINATES OF WEIGHTED STATIONS FORMPX31 DO 1 I=1,NP FORMPX32 OX(I,1)=AP(IPX(I),1) FORMPX33 OX(I,2)=AP(IPX(I),2) FORMPX34 1 CONTINUE FORMPX35 6 K=0 FORMPX36 DO 2 I=1,NP2 FORMPX37 DO 2 J=I,NP2 FORMPX38 K=K+1 FORMPX39 SPX(J,I)=PX(K) FORMPX40 2 SPX(I,J)=PX(K) FORMPX41 C ECHO THE FORMED A PRIORI MATRIX FORMPX42 CALL PRAR(SPX,NP2R,NP2R,NP2,NP2,ICODE,CNAM,NS,0,IOB,NOR,IC,NSR,ICAFORMPX43 @ ,RU,W,CPX,NP,WX,NR,NP2R,NPR,NO) FORMPX44 C CHECK FOR ZERO DIAGONAL ELEMENTS FORMPX45 DO 3 I=1,NP2 FORMPX46 IF(SPX(I,I).NE.0.D0)GOTO3 FORMPX47 PRINT101 FORMPX48 STOP FORMPX49 3 CONTINUE FORMPX50 101 FORMAT(' ','*** INPUT ERROR #009 *** IN INPUT OF A PRIORI INFORMAFORMPX51 @TION MATRIX ELEMENTS; ZERO DIAGONAL ELEMENT ENCOUNTERED.') FORMPX52 IF(NCOV.EQ.0.AND.IPB.EQ.2)GOTO5 FORMPX53 IF(NCOV.EQ.1.AND.IPB.EQ.1)GOTO5 FORMPX54 DO 4 I=1,NP2 FORMPX55 4 IB(I)=1 FORMPX56 C INVERT A PRIORI MATRIX IF NECESSARY FORMPX57 CALL XSIN(SPX,NP2,1,0,RU,D,IID,IB,X,NP2R,CONVG,0,0,CNAM,NS,IOB,NORFORMPX58 @ ,IC,NSR,ICA,RU,W,CPX,NP,WX,NP2R,NPR,NO,0,0,IPB) FORMPX59 5 RETURN FORMPX60 END FORMPX61 SUBROUTINE FPLAT(A,B,Y,PHI1) FPLAT001 C***********************************************************************FPLAT002 C* FPLAT003 C* THIS ROUTINE COMPUTES THE FOOT-POINT LATITUDE REQUIRED IN FPLAT004 C* TRANSFORMING TRANSVERSE MERCATOR PLANE COORDINATES X,Y TO FPLAT005 C* ELLIPSOIDAL COORDINATES. FPLAT006 C* FPLAT007 C* FPLAT008 C* INPUT: FPLAT009 C* A - SEMI-MAJOR AXES OF THE REFERENCE ELLIPSOID. FPLAT010 C* B - SEMI-MINOR AXES OF THE REFERENCE ELLIPSOID. FPLAT011 C* Y - NORTHING OF THE POINT FOR WHICH THE FOOT-POINT FPLAT012 C* LATITUDE IS TO BE COMPUTED. FPLAT013 C* FPLAT014 C* OUTPUT: FPLAT015 C* PHI1 - FOOT-POINT LATITUDE IN RADIANS. FPLAT016 C* FPLAT017 C* FPLAT018 C* WRITTEN BY: FPLAT019 C* R.R. STEEVES, JUNE, 1977 FPLAT020 C* FPLAT021 C***********************************************************************FPLAT022 IMPLICIT REAL*8(A-Z) FPLAT023 F(PHI)=A*(A0*PHI-A2*DSIN(2.D0*PHI)+A4*DSIN(4.D0*PHI)-A6*DSIN(6.D0*FPLAT024 1 PHI)+A8*DSIN(8.D0*PHI))-Y FPLAT025 FP(PHI)=A*(A0-2.D0*A2*DCOS(2.D0*PHI)+4.D0*A4*DCOS(4.D0*PHI)-6.D0* FPLAT026 1 A6*DCOS(6.D0*PHI)+8.D0*A8*DCOS(8.D0*PHI)) FPLAT027 E2=(A*A-B*B)/(A*A) FPLAT028 E4=E2*E2 FPLAT029 E6=E4*E2 FPLAT030 E8=E6*E2 FPLAT031 A0=1.D0-E2/4.D0-3.D0*E4/64.D0-5.D0*E6/256.D0-175.D0*E8/16384.D0 FPLAT032 A2=3.D0/8.D0*(E2+E4/4.D0+15.D0*E6/128.D0-455.D0*E8/4096.D0) FPLAT033 A4=15.D0/256.D0*(E4+3.D0*E6/4.D0-77.D0*E8/128.D0) FPLAT034 A6=35.D0/3072.D0*(E6-41.D0*E8/32.D0) FPLAT035 A8=-315.D0*E8/131072.D0 FPLAT036 PHI1=Y/A FPLAT037 1 DPHI=F(PHI1)/FP(PHI1) FPLAT038 PHI1=PHI1-DPHI FPLAT039 IF(DABS(DPHI).LT.1.D-11)GOTO 2 FPLAT040 GO TO 1 FPLAT041 2 CONTINUE FPLAT042 RETURN FPLAT043 END FPLAT044 SUBROUTINE F2DI(ALPHA,IDF,X) F2DI0001 C***********************************************************************F2DI0002 C* F2DI0003 C* F2DI COMPUTES THE INVERSE F-DISTRIBUTION PROBLEM FOR 2 DEGREES OF FRF2DI0004 C* DOM IN THE NUMERATOR F2DI0005 C* F2DI0006 C* F2DI0007 C* INPUT: F2DI0008 C* ALPHA- SUCH THAT THE PROBABILITY OF AN F RANDOM VARIABLE (WITH F2DI0009 C* AND IDF DEGREES OF FREEDOM) BEING GREATER THAN X IS ALPHF2DI0010 C* IDF- DEGREES OF FREEDOM IN DENOMINATOR F2DI0011 C* F2DI0012 C* OUTPUT: F2DI0013 C* X- SEE DESCRIPTION OF ALPHA ABOVE F2DI0014 C* F2DI0015 C* F2DI0016 C* WRITTEN BY: F2DI0017 C* R.R. STEEVES, AUG., 1978 F2DI0018 C* F2DI0019 C***********************************************************************F2DI0020 IMPLICIT REAL*8(A-H,O-Z) F2DI0021 R=DFLOAT(IDF) F2DI0022 X=(R/(ALPHA**(2.D0/R))-R)/2.D0 F2DI0023 RETURN F2DI0024 END F2DI0025 SUBROUTINE GODFIT(V,NOR,VCLS,JCODE,NO,IOB,NVARF,ALPH,NV) GODFIT01 C***********************************************************************GODFIT02 C* GODFIT03 C* GODFIT FERFORMS THE CHI-SQUARE GOODNESS OF FIT TEST ON STANDARDIZED GODFIT04 C* RESIDUALS AND PLOTS THE CORRESPONDING HISTOGRAMS. GODFIT05 C* GODFIT06 C* WRITTEN BY: GODFIT07 C* R.R. STEEVES, AUG, 1978 GODFIT08 C* GODFIT09 C***********************************************************************GODFIT10 IMPLICIT REAL*8(A-H,O-Z) GODFIT11 INTEGER HVEC(20) GODFIT12 REAL*4 SNGL,FLOAT,X,AREA GODFIT13 DIMENSION AREA(20),IVEC(7),V(NV) ,VCLS(NOR),NHVEC(20),NCNT(6,11), GODFIT14 @ IOB(NOR,4) GODFIT15 DATA NCNT/1,1,1,1,1,1,3,4,5,6,8,11,5,6,9,11,14,21,7,8,13,16,21,0,9GODFIT16 @,10,17,21,0,0,11,12,21,0,0,0,13,14,0,0,0,0,15,16,0,0,0,0,17,18,0,0GODFIT17 @,0,0,19,21,0,0,0,0,21,0,0,0,0,0/ GODFIT18 DATA AREA/0.000003,0.000028,0.000201,0.001117,0.004860,0.016540, GODFIT19 @ 0.044057,0.091848,0.149882,0.191462,0.191462,0.149882,0.091848, GODFIT20 @0.044057,0.016540,0.004860,0.001117,0.000201,0.000028,0.000003/ GODFIT21 DATA IVEC/20,10,9,5,4,3,2/ GODFIT22 K=1 GODFIT23 C SELECT THE SET OF RESIDUALS TO BE CONSIDERED GODFIT24 IF(JCODE.EQ.3)GOTO1 GODFIT25 IF(JCODE.EQ.2)GOTO2 GODFIT26 DO 3 J=1,NO GODFIT27 IF(IOB(J,1).NE.1)GOTO3 GODFIT28 VCLS(K)=V(J) GODFIT29 K=K+1 GODFIT30 3 CONTINUE GODFIT31 GOTO5 GODFIT32 2 DO 4 J=1,NO GODFIT33 IF(IOB(J,1).EQ.1)GOTO4 GODFIT34 VCLS(K)=V(J) GODFIT35 K=K+1 GODFIT36 4 CONTINUE GODFIT37 GOTO5 GODFIT38 1 DO 6 J=1,NO GODFIT39 VCLS(J)=V(J) GODFIT40 6 CONTINUE GODFIT41 K=NO+1 GODFIT42 5 NRES=K-1 GODFIT43 C SORT THE RESIDUALS INTO ORDER OF INCREASING MAGNITUDE GODFIT44 CALL SORT(VCLS,NOR,NRES) GODFIT45 DO 8 J=1,20 GODFIT46 8 HVEC(J)=0 GODFIT47 X=-4.5D0 GODFIT48 J=1 GODFIT49 C PLACE RESIDUALS INTO CORRECT HISTOGRAM INTERVALS GODFIT50 DO 9 K=1,20 GODFIT51 10 IF(VCLS(J).GT.X.AND.K.LT.20)GOTO11 GODFIT52 HVEC(K)=HVEC(K)+1 GODFIT53 J=J+1 GODFIT54 IF(J.GT.NRES)GOTO7 GODFIT55 GOTO10 GODFIT56 11 X=X+0.5D0 GODFIT57 9 CONTINUE GODFIT58 C DETERMINE INTERVALS WITH EXPECTED FREQUENCE OF AT LEAST 5 GODFIT59 7 DO 20 N=1,7 GODFIT60 DO 29 K=1,20 GODFIT61 29 NHVEC(K)=0 GODFIT62 NI=IVEC(N) GODFIT63 DO 28 K=1,NI GODFIT64 IF(N.EQ.1)ISUM=HVEC(K) GODFIT65 IF(N.EQ.1)GOTO28 GODFIT66 IFR=NCNT(N-1,K) GODFIT67 ITO=NCNT(N-1,K+1)-1 GODFIT68 ISUM=0 GODFIT69 DO 30 J=IFR,ITO GODFIT70 30 ISUM=ISUM+HVEC(J) GODFIT71 28 NHVEC(K)=ISUM GODFIT72 NI1=NI-1 GODFIT73 MINIX=0 GODFIT74 DO 21 K=1,NI1 GODFIT75 AR=0.D0 GODFIT76 IF(N.EQ.1)AR=AREA(K) GODFIT77 IF(N.EQ.1)GOTO57 GODFIT78 IFR=NCNT(N-1,K) GODFIT79 ITO=NCNT(N-1,K+1)-1 GODFIT80 DO 58 J=IFR,ITO GODFIT81 58 AR=AR+AREA(J) GODFIT82 57 NEX=AR*NRES GODFIT83 IF(NEX.GE.5)MINIX=K GODFIT84 IF(MINIX.NE.0)GOTO62 GODFIT85 21 CONTINUE GODFIT86 GOTO20 GODFIT87 62 MINIA=0 GODFIT88 DO 63 K=1,NI1 GODFIT89 IF(NHVEC(K).NE.0.OR.NHVEC(NI+1-K).NE.0)MINIA=K GODFIT90 IF(MINIA.NE.0)GOTO64 GODFIT91 63 CONTINUE GODFIT92 64 IF(MINIA.GE.MINIX)GOTO27 GODFIT93 20 CONTINUE GODFIT94 NDF=0 GODFIT95 NUMI=0 GODFIT96 GOTO200 GODFIT97 27 MINI=MINIX GODFIT98 MAXI=NI-MINI+1 GODFIT99 NUMI=MAXI-MINI+1 GODFI100 NTHETA=0 GODFI101 IF(NVARF.EQ.0)NTHETA=1 GODFI102 NDF=NUMI-1-NTHETA GODFI103 IF(NDF.LE.0)GOTO200 GODFI104 C PERFORM CHI-SQUARE GOODNESS OF FIT TEST GODFI105 STRT=-5.0 GODFI106 DO 35 I=1,MINI GODFI107 IF(I.EQ.MINI)GOTO35 GODFI108 IF(N.EQ.1)GOTO36 GODFI109 IFR=NCNT(N-1,I) GODFI110 ITO=NCNT(N-1,I+1)-1 GODFI111 STRT=STRT+(ITO-IFR+1)*0.5D0 GODFI112 GOTO35 GODFI113 36 STRT=STRT+0.5D0 GODFI114 35 CONTINUE GODFI115 PRINT101 GODFI116 IF(JCODE.EQ.1)PRINT102 GODFI117 IF(JCODE.EQ.2)PRINT103 GODFI118 IF(JCODE.EQ.3)PRINT104 GODFI119 PRINT105,NUMI GODFI120 PRINT106,NDF GODFI121 PRINT107 GODFI122 PRINT108 GODFI123 CHISQ=0.D0 GODFI124 DO 37 I=MINI,MAXI GODFI125 IF(N.EQ.1)GOTO38 GODFI126 AR=0.D0 GODFI127 IFR=NCNT(N-1,I) GODFI128 ITO=NCNT(N-1,I+1)-1 GODFI129 DO 39 K=IFR,ITO GODFI130 39 AR=AR+AREA(K) GODFI131 FIN=(ITO-IFR+1)*0.5D0+STRT GODFI132 GOTO40 GODFI133 38 AR=AREA(I) GODFI134 FIN=STRT+0.5D0 GODFI135 40 NEXP=NRES*AR GODFI136 NOBS=NHVEC(I) GODFI137 NDIF=NOBS-NEXP GODFI138 NDIF2=NDIF**2 GODFI139 CONT=DFLOAT(NDIF2)/DFLOAT(NEXP) GODFI140 CHISQ=CHISQ+CONT GODFI141 PRINT109,STRT,FIN,NOBS,NEXP,NDIF,NDIF2,CONT GODFI142 STRT=FIN GODFI143 37 CONTINUE GODFI144 PRINT110,CHISQ GODFI145 P=SNGL(ALPH/100.D0) GODFI146 DF=FLOAT(NDF) GODFI147 X=SNGL(0.D0) GODFI148 CALL MDCHI(P,DF,X,IER) GODFI149 PRINT111,ALPH,X GODFI150 IPASS=0 GODFI151 IF(SNGL(CHISQ).LE.X)IPASS=1 GODFI152 IF(IPASS.EQ.1)PRINT112,CHISQ,X GODFI153 IF(IPASS.EQ.0)PRINT113,CHISQ,X GODFI154 PRINT114 GODFI155 IF(NUMI.LT.9)PRINT119,NUMI GODFI156 CALL PLOT(NI,NHVEC) IF(JCODE.EQ.1)PRINT115 GODFI158 IF(JCODE.EQ.2)PRINT116 GODFI159 IF(JCODE.EQ.3)PRINT117 GODFI160 IF(NUMI.LT.9)PRINT121 GODFI161 200 IF(NUMI.GE.9)GOTO210 GODFI162 CALL PLOT(20,HVEC) IF(JCODE.EQ.1)PRINT115 GODFI164 IF(JCODE.EQ.2)PRINT116 GODFI165 IF(JCODE.EQ.3)PRINT117 GODFI166 IF(NDF.LE.0)PRINT118,NDF GODFI167 210 RETURN GODFI168 101 FORMAT('1',38X,'CHI-SQUARE GOODNESS OF FIT TEST',/,' ',38X, GODFI169 @ 31('-'),/) GODFI170 102 FORMAT(' ',35X,'ON THE STANDARDIZED DISTANCE RESIDUALS',//) GODFI171 103 FORMAT(' ',26X,'ON THE STANDARDIZED DIRECTION, ANGLE AND AZIMUTH RGODFI172 @ESIDUALS',//) GODFI173 104 FORMAT(' ',28X,'ON THE STANDARDIZED RESIDUALS (ALL RESIDUALS INCLUGODFI174 @DED)',//) GODFI175 105 FORMAT(' ',41X,'THE NUMBER OF CLASSES IS',I3) GODFI176 106 FORMAT(' ',28X,'THE NUMBER OF DEGREES OF FREEDOM FOR THE TEST IS',GODFI177 @ I6,//) GODFI178 107 FORMAT(' ',28X,'SUMMARY OF THE COMPUTATION OF THE CHI-SQUARE STATIGODFI179 @STIC',/,' ',28X,54('-'),/) GODFI180 108 FORMAT(' ',9X,'CLASS INTERVAL',3X,'OBSERVED FREQ.(O)',3X, GODFI181 @'EXPECTED FREQ.(E)',5X,'(O-E)',5X,'(O-E)**2',5X,'(O-E)**2/E') GODFI182 109 FORMAT(' ',10X,'(',F4.1,' ,',F4.1,')',5X,I8,11X,I9,11X,I6,5X,I7, GODFI183 @6X,F9.2) GODFI184 110 FORMAT(' ',91X,8('-'),//,' ',56X,'TOTAL (CHI-SQUARE STATISTIC) -->GODFI185 @',F11.2,/) GODFI186 111 FORMAT(' ',19X,'THE CHI-SQUARE CRITICAL VALUE AT THE',F7.3,' % CONGODFI187 @FIDENCE LEVEL IS -->',F11.2,///) GODFI188 112 FORMAT(' ',39X,F7.2,' IS LESS THAN ',F7.2,////,' ',47X,'THE TEST GODFI189 @PASSES',/,' ',47X,15('-'),/) GODFI190 113 FORMAT(' ',39X,F6.2,' IS GREATER THAN ',F6.2,////,' ',47X,'THE TEGODFI191 @ST FAILS',/,' ',47X,14('-'),/) GODFI192 114 FORMAT(' ',41X,'(SEE HISTOGRAM ON NEXT PAGE)',/) GODFI193 115 FORMAT(/,' ',31X,'HISTOGRAM OF THE STANDARDIZED DISTANCE RESIDUALSGODFI194 *',/,' ',31X,48('-')) GODFI195 116 FORMAT(/,' ',22X,'HISTOGRAM OF THE STANDARDIZED DIRECTION, ANGLE AGODFI196 @ND AZIMUTH RESIDUALS',/,' ',22X,68('-')) GODFI197 117 FORMAT(/,' ',24X,'HISTOGRAM OF THE STANDARDIZED RESIDUALS (ALL RESGODFI198 @IDUALS INCLUDED)',/,' ',24X,64('-')) GODFI199 118 FORMAT(' ',4X,'THE CHI-SQUARE GOODNESS OF FIT TEST WAS NOT PERFORMGODFI200 @ED SINCE THE DEGREES OF FREEDOM OF THE TEST WAS',I4) GODFI201 119 FORMAT(' ',4X,'NOTE: THE HISTOGRAM IS FIRST PLOTTED WITH ',I1, GODFI202 @' CLASSES (THAT USED IN THE GOODNESS OF FIT TEST); THEN WITH',/, GODFI203 @' ',10X,'20 CLASSES SO THAT A MORE DETAILED REPRESENTATION OF THE GODFI204 @ACTUAL RESIDUAL DISTRIBUTION IS GIVEN.') GODFI205 121 FORMAT(' ','(WITH CLASSES AS USED IN THE GOODNESS OF FIT TEST; A MGODFI206 @ORE DETAILED REPRESENTATION IS PLOTTED ON THE NEXT PAGE)') GODFI207 END GODFI208 SUBROUTINE GVERT(AP,NSR,AA,BB,XO,YO,ZO,VERT,I,J) GVERT001 C***********************************************************************GVERT002 C* GVERT003 C* GVERT COMPUTES THE ZENITHAL ANGLE FROM STATION I TO STATION J (SEQUGVERT004 C* NUMBERS) FROM THE COMPUTED LATITUDES AND LONGITUDES AND THE HEIGHTS GVERT005 C* STATIONS I AND J. USED IN REDUCING OBSERVATIONS FROM TERRAIN TO GVERT006 C* ELLEPSOID. GVERT007 C* GVERT008 C* GVERT009 C* INPUT: GVERT010 C* AP,NSR- DESCRIBED IN MAIN GVERT011 C* AA,BB- SEMI MAJOR AND SEMI MINOR AXES OF REFERENCE ELLIPSOID GVERT012 C* XO,YO,ZO-TRANSLATION COMPONENTS FROM GEOCENTRIC TO REFERENCE GVERT013 C* ELLIPSOID GVERT014 C* GVERT015 C* OUTPUT: GVERT016 C* VERT- COMPUTED ZENITHAL ANGLE FROM I TO J GVERT017 C* GVERT018 C* GVERT019 C* WRITTEN BY: GVERT020 C* R.R. STEEVES, JUNE, 1678 GVERT021 C* GVERT022 C***********************************************************************GVERT023 IMPLICIT REAL*8(A-H,O-Z) GVERT024 DIMENSION AP(NSR,12) GVERT025 HI=AP(I,3)+AP(I,4) GVERT026 HJ=AP(J,3)+AP(J,4) GVERT027 C COMPUTE GEOCENTRIC COORDINATES GVERT028 CALL PLHXYZ(AP(I,9),AP(I,10),HI,XO,YO,ZO,AA,BB,XI,YI,ZI) GVERT029 CALL PLHXYZ(AP(J,9),AP(J,10),HJ,XO,YO,ZO,AA,BB,XJ,YJ,ZJ) GVERT030 DX=XJ-XI GVERT031 DY=YJ-YI GVERT032 DZ=ZJ-ZI GVERT033 SP=DSIN(AP(I,9)) GVERT034 CP=DCOS(AP(I,9)) GVERT035 SL=DSIN(AP(I,10)) GVERT036 CL=DCOS(AP(I,10)) GVERT037 C COMPUTE LOCAL GEODETIC COORDINATE DIFFERENCES GVERT038 DXL=-DX*SP*CL-DY*SP*SL+DZ*CP GVERT039 DYL=-DX*SL+DY*CL GVERT040 DZL=DX*CP*CL+DY*CP*SL+DZ*SP GVERT041 DIST=DSQRT(DXL**2+DYL**2+DZL**2) GVERT042 C COMPUTE ZENITHAL ANGLE GVERT043 VERT=DARCOS(DZL/DIST) GVERT044 RETURN GVERT045 END GVERT046 SUBROUTINE INERR(NO,IOB,DOB,ID,NS,NCODE,NOR) INERR001 C***********************************************************************INERR002 C* INERR003 C* INERR PERFORMS SOME CHECKS ON INPUT DATA. ERROR MESSAGES ARE PRINTEINERR004 C* WHEN INVALID DATA ARE INCOUNTERED. INERR005 C* INERR006 C* INERR007 C* INPUT: INERR008 C* -ALL DESCRIBED IN MAIN INERR009 C* INERR010 C* OUTPUT: INERR011 C* ID- RETURNS 1 IF AN INPUT ERROR WAS DETECTED; 0 IF NOT INERR012 C* INERR013 C* INERR014 C* WRITTEN BY: INERR015 C* R.R. STEEVES, JUNE, 1978 INERR016 C* INERR017 C***********************************************************************INERR018 IMPLICIT REAL*8(A-H,O-Z) INERR019 DIMENSION IOB(NOR,4),DOB(NOR,4) INERR020 DO 18 I=1,NO INERR021 K=IOB(I,1) INERR022 C CHECK OBSERVATION CODE INERR023 IF(K.LE.4.AND.K.GE.-2.AND.K.NE.0.AND.K.NE.-1)GOTO12 INERR024 PRINT 110,I INERR025 ID=1 INERR026 C CHECK FOR ZERO STANDARD DEVIATIONS INERR027 12 IF(DOB(I,1).NE.0.0D0)GOTO14 INERR028 IF(DOB(I,2).NE.0.D0.AND.IOB(I,1).EQ.1)GOTO14 INERR029 PRINT 112,I INERR030 14 K=IOB(I,1) INERR031 IF(K.EQ.1.OR.K.EQ.2.OR.K.EQ.3.OR.K.EQ.4.OR.K.EQ.-2)GOTO15 INERR032 ID=1 INERR033 GOTO18 INERR034 15 IF(K.EQ.-2)K=2 INERR035 GOTO(16,17,17,17),K INERR036 C CHECK FOR ZERO DISTANCE OBSERVATION IF ADJUSTMENT REQUESTED INERR037 16 IF(NCODE.EQ.2.AND.DOB(I,3).NE.0.0D0)GOTO18 INERR038 IF(NCODE.EQ.1)GOTO18 INERR039 PRINT 113,I INERR040 C CHECK VALIDITY OF ANGULAR OBSERVATIONS IF ADJUSTMENT REQUESTED INERR041 ID=1 INERR042 GOTO18 INERR043 17 IF(NCODE.EQ.2.AND.DOB(I,2).GE.0.0D0.AND.DOB(I,2).LT.360.0D0.AND. INERR044 @ DOB(I,3).GE.0.0D0.AND.DOB(I,3).LE.59.D0.AND.DOB(I,4).GE.0.0D0.ANDINERR045 @.DOB(I,4).LT.60.D0)GOTO18 INERR046 IF(NCODE.EQ.1)GOTO18 INERR047 PRINT 114,I INERR048 ID=1 INERR049 18 CONTINUE INERR050 110 FORMAT(' ','*** INPUT ERROR #016 *** CODE FOR OBSERVATION NO. ', INERR051 @I4,' IS NOT ACCEPTABLE, MUST BE 1,2,3,4 OR -2') INERR052 112 FORMAT(' ','*** INPUT ERROR #017 *** OBSERVATION NO. ',I4,' HAS BEINERR053 @EN GIVEN A ZERO STANDARD DEVIATION: CHECK INPUT FACTORS,IF ANY.') INERR054 113 FORMAT(' ','*** INPUT ERROR #018 *** DISTANCE OBSERVATION NO. ', INERR055 @I4,' IS ZERO') INERR056 114 FORMAT(' ','*** INPUT ERROR #019 *** OBSERVATION NO. ',I4,' HAS DEINERR057 @GREES,MINUTES OR SECONDS OUT OF ACCEPTABLE RANGE.') INERR058 RETURN INERR059 END INERR060 SUBROUTINE LPRNT(NVAL,MAX,PLOTV,RVEC,WINT,N,KK) LPRNT001 C***********************************************************************LPRNT002 C* LPRNT003 C* LPRNT CONTROLS THE LINE SPACING FOR THE NORMAL-HISTOGRAM PLOT PRINTILPRNT004 C* LPRNT005 C* WRITTEN BY: LPRNT006 C* LAURIE PACH, JULY, 1978 LPRNT007 C* LPRNT008 C***********************************************************************LPRNT009 INTEGER WINT,PLOTV,SV,RVEC LPRNT010 DIMENSION PLOTV(110),SV(22),RVEC(WINT) LPRNT011 DATA SV/' ',' ',' ',' ','R','E','L','A','T','I','V','E',' ','F', LPRNT012 @ 'R','E','Q','U','E','N','C','Y'/ LPRNT013 B=.3 LPRNT014 C=.2 LPRNT015 D=.1 LPRNT016 DO 2 I=1,100 LPRNT017 DO 3 N=1,WINT LPRNT018 IF(RVEC(N).EQ.MAX)RETURN LPRNT019 3 CONTINUE LPRNT020 N=N-1 LPRNT021 IF(NVAL.EQ.MAX)RETURN LPRNT022 PRINT101,(PLOTV(L),L=1,110) LPRNT023 IF(MAX.EQ.25)PRINT113,B LPRNT024 IF(MAX.EQ.17)PRINT113,C LPRNT025 IF(MAX.EQ.9)PRINT113,D LPRNT026 MAX=MAX-1 LPRNT027 IF(MAX.GT.32.OR.KK.EQ.23)GOTO2 LPRNT028 PRINT114,SV(KK) LPRNT029 KK=KK+1 LPRNT030 2 CONTINUE LPRNT031 101 FORMAT(' ',6X,110A1) LPRNT032 113 FORMAT('+',3X,F3.1,'-') LPRNT033 114 FORMAT('+',1X,A1) LPRNT034 RETURN LPRNT035 END LPRNT036 SUBROUTINE MAKICE(ICER,CERR,CNAM,NSR,NS,NSTA) MAKICE01 C***********************************************************************MAKICE02 C* MAKICE03 C* MAKICE FORMS A VECTOR OF SEQUENCE NUMBERS (ICER) FOR STATIONS IN A MAKICE04 C* SET FOR SIMULTANEOUS ELLIPSES. CHECKS SET OF NAMES FOR DUPLICATION MAKICE05 C* OR EXISTANCE. MAKICE06 C* MAKICE07 C* MAKICE08 C* INPUT: MAKICE09 C* -ALL DESCRIBED IN MAIN MAKICE10 C* MAKICE11 C* OUTPUT: MAKICE12 C* -ALL DESCRIBED IN MAIN MAKICE13 C* MAKICE14 C* MAKICE15 C* WRITTEN BY: MAKICE16 C* R.R. STEEVES, AUG., 1978 MAKICE17 C* MAKICE18 C***********************************************************************MAKICE19 IMPLICIT REAL*8(A-H,O-Z) MAKICE20 DIMENSION ICER(NSR),CERR(NSR),CNAM(NSR) MAKICE21 DATA BLNK/' '/ MAKICE22 NSTA=0 MAKICE23 DO 1 J=1,NSR MAKICE24 IF(CERR(J).EQ.BLNK)GOTO2 MAKICE25 IF(J.EQ.1)GOTO3 MAKICE26 K=J-1 MAKICE27 DO 4 L=1,K MAKICE28 IF(CERR(J).EQ.CERR(L))GOTO5 MAKICE29 4 CONTINUE MAKICE30 3 DO 6 L=1,NS MAKICE31 IF(CERR(J).EQ.CNAM(L))GOTO7 MAKICE32 6 CONTINUE MAKICE33 PRINT101,CERR(J) MAKICE34 101 FORMAT(' ','*** INPUT ERROR #042 *** STATION NAME ',A8,'READ' , ' MAKICE35 @IN A SET FOR SIMULTANEOUS ELLIPSES',/,' ',10X,'IS NOT ONE OF THOSEMAKICE36 @ IN THE NETWORK.',/) MAKICE37 STOP MAKICE38 5 PRINT102,CERR(L) MAKICE39 102 FORMAT(' ','*** INPUT ERROR #043 ***STATION NAME ',A8,' APPEARS ATMAKICE40 @ LEAST TWICE IN A SET FOR SIMULTANEOUS ELLIPSES',/) MAKICE41 STOP MAKICE42 7 ICER(J)=L MAKICE43 NSTA=NSTA+1 MAKICE44 1 CONTINUE MAKICE45 2 RETURN MAKICE46 END MAKICE47 SUBROUTINE MULCX(VARF,RN,NR,N) MULCX001 C***********************************************************************MULCX002 C* MULCX003 C* MULCX MULTIPLIES THE ELEMENTS OF THE INVERSE OF NORMAL EQUATIONS BY MULCX004 C* THE VARIANCE FACTOR. MULCX005 C* MULCX006 C* MULCX007 C* INPUT: MULCX008 C* VARF- ESTIMATED VARIANCE FACTOR. MULCX009 C* OTHERS- DESCRIBED IN MAIN. MULCX010 C* MULCX011 C* MULCX012 C* WRITTEN BY: MULCX013 C* R.R. STEEVES, AUG, 1978 MULCX014 C* MULCX015 C***********************************************************************MULCX016 IMPLICIT REAL*8(A-H,O-Z) MULCX017 DIMENSION RN(NR,NR) MULCX018 DO 1 I=1,N MULCX019 DO 1 J=1,N MULCX020 1 RN(I,J)=RN(I,J)*VARF MULCX021 RETURN MULCX022 END MULCX023 SUBROUTINE NAMC(NSR,NOR,NO,NS,NP,NFIX,IPX,CIO,CNAM,CNF,CPX,IOB,NF,NAMC0001 @ NPR,NFR,IBH,CBH,NBR,NB) NAMC0002 C***********************************************************************NAMC0003 C* NAMC0004 C* NAMC GENERATES SEQUENCE NUMBERS FOR CODING OF STATION NAMES. IT ALSNAMC0005 C* CHECKS FOR CORRESPONDENCE OF STATION NAMES USED IN SEPARATE PARTS OFNAMC0006 C* INPUT DATA. NAMC0007 C* NAMC0008 C* NAMC0009 C* INPUT: NAMC0010 C* - ALL DESCRIBED IN MAIN NAMC0011 C* NAMC0012 C* OUTPUT: NAMC0013 C* NFIX - SEQUENCE NUMBERS FOR FIXED STATIONS NAMC0014 C* IPX- SEQUENCE NUMBERS FOR WEIGHTED STATIONS NAMC0015 C* IOB - SEQUENCE NUMBERS FOR OBSERVATION STATIONS NAMC0016 C* IBH - SEQUENCE NUMBERS FOR BLAHA STATIONS NAMC0017 C* NAMC0018 C* NAMC0019 C* WRITTEN BY: NAMC0020 C* R.R. STEEVES, MAY, 1978 NAMC0021 C* NAMC0022 C***********************************************************************NAMC0023 IMPLICIT REAL*8(A-H,O-Z) NAMC0024 REAL*8 BLNK/' '/ NAMC0025 DIMENSION NFIX(NFR),IPX(NPR),CIO(NOR,3),CNAM(NSR),CNF(NFR), NAMC0026 @ CPX(NPR),IOB(NOR,4),IBH(NBR),CBH(NBR) NAMC0027 IF(NP.EQ.0)GOTO20 NAMC0028 C ASSIGN SEQUENCE NUMBERS TO WEIGHTED STATIONS IF ANY NAMC0029 DO 3 I=1,NP NAMC0030 J=1 NAMC0031 1 IF(CPX(I).NE.CNAM(J))GOTO2 NAMC0032 IPX(I)=J NAMC0033 GOTO3 NAMC0034 2 IF(J.EQ.NS)GOTO4 NAMC0035 J=J+1 NAMC0036 GOTO1 NAMC0037 3 CONTINUE NAMC0038 GOTO20 NAMC0039 4 PRINT 101 NAMC0040 STOP NAMC0041 20 IF(NB.EQ.0)GOTO5 NAMC0042 C ASSIGN SEQUENCE NUMBERS TO BLAHA STATIONS IF ANY NAMC0043 DO 23 I=1,NB NAMC0044 J=1 NAMC0045 21 IF(CBH(I).NE.CNAM(J))GOTO22 NAMC0046 IBH(I)=J NAMC0047 GOTO23 NAMC0048 22 IF(J.EQ.NS)GOTO24 NAMC0049 J=J+1 NAMC0050 GOTO21 NAMC0051 23 CONTINUE NAMC0052 GOTO5 NAMC0053 24 PRINT 201 NAMC0054 STOP NAMC0055 C ASSIGN SEQUENCE NUMBERS TO FIXED STATIONS IF ANY NAMC0056 5 IF(NF.EQ.0)GOTO10 NAMC0057 DO 8 I=1,NF NAMC0058 J=1 NAMC0059 6 IF(CNF(I).NE.CNAM(J))GOTO7 NAMC0060 NFIX(I)=J NAMC0061 GOTO8 NAMC0062 7 IF(J.EQ.NS)GOTO9 NAMC0063 J=J+1 NAMC0064 GOTO6 NAMC0065 8 CONTINUE NAMC0066 GOTO10 NAMC0067 9 PRINT 102 NAMC0068 STOP NAMC0069 C CHECK THAT OBSERVATION STATION NAMES EXIST IN STATION NAMES READ NAMC0070 10 DO 13 I=1,NO NAMC0071 DO 13 J=1,3 NAMC0072 K=1 NAMC0073 11 IF(J.EQ.3.AND.IOB(I,1).NE.3)IOB(I,4)=0 NAMC0074 IF(J.EQ.3.AND.IOB(I,1).NE.3)GOTO13 NAMC0075 IF(CIO(I,J).EQ.CNAM(K))GOTO12 NAMC0076 K=K+1 NAMC0077 IF(K.GT.NS)GOTO14 NAMC0078 GOTO11 NAMC0079 12 IOB(I,J+1)=K NAMC0080 13 CONTINUE NAMC0081 GOTO15 NAMC0082 14 PRINT 103,I,CIO(I,J) NAMC0083 STOP NAMC0084 15 NUM=NS-1 NAMC0085 C CHECK THAT STATIONS ALL HAVE DIFFERENT NAMES OR THAT A STATION NAME DONAMC0086 C NOT CONSIST OF ALL BLANKS. NAMC0087 DO 16 I=1,NUM NAMC0088 M=I+1 NAMC0089 DO 16 J=M,NS NAMC0090 IF(CNAM(I).NE.CNAM(J))GOTO16 NAMC0091 PRINT 104,I,J,CNAM(I) NAMC0092 STOP NAMC0093 16 CONTINUE NAMC0094 DO 17 I=1,NS NAMC0095 IF(CNAM(I).NE.BLNK)GOTO17 NAMC0096 PRINT 105,I NAMC0097 STOP NAMC0098 17 CONTINUE NAMC0099 101 FORMAT(' ','*** INPUT ERROR #045 *** STATION NAME REFERENCED AS WNAMC0100 @EIGHTED WAS NOT FOUND AMONG THOSE INPUT WITH APPROXIMATE COORDINATNAMC0101 @ES') NAMC0102 102 FORMAT(' ','*** INPUT ERROR #047 *** STATION NAME REFERENCED AS BNAMC0103 @EING HELD FIXED WAS NOT FOUND AMONG THOSE INPUT WITH APPROXIMATE',NAMC0104 @/,' ',21X,'COORDINATES') NAMC0105 103 FORMAT(' ','*** INPUT ERROR #048 *** OBSERVATION NO. ',I4,' REFERNAMC0106 @ENCES STATIONS ',A8,',WHICH CANNOT BE FOUND AMONG THOSE INPUT WITHNAMC0107 @',/,' ',21X,'THE APPROXIMATE COORDINATES') NAMC0108 104 FORMAT(' ','*** INPUT ERROR #049 *** STATIONS ',I4,' AND ',I4, NAMC0109 @' (AS THEY WERE READ IN) HAVE SAME NAME, NAMELY:',A8) NAMC0110 105 FORMAT(' ','*** INPUT ERROR #050 *** STATION NO. ',I4,'AS IT WAS NAMC0111 @READ IN) HAS NO NAME') NAMC0112 201 FORMAT(' ','*** INPUT ERROR #046 *** STATION NAME REFERENCED AS HNAMC0113 @AVING BLAHA INFORMATION WAS NOT FOUND AMONG THOSE WITH APPROXIMATENAMC0114 @',/,' ',21X,'COORDINATES') NAMC0115 RETURN NAMC0116 END NAMC0117 SUBROUTINE NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) NORM0001 C***********************************************************************NORM0002 C* NORM0003 C* NORM SEQUENTIALLY ADDS CONTRIBUTION OF DISTANCE, ANGLE AND AZIMUTH NORM0004 C* OBSERVATIONS TO THE NORMAL EQUATIONS NORM0005 C* NORM0006 C* NORM0007 C* INPUT: NORM0008 C* -ALL DESCRIBED IN MAIN NORM0009 C* NORM0010 C* NORM0011 C* WRITTEN BY: NORM0012 C* R.R. STEEVES, JUNE, 1976 NORM0013 C* NORM0014 C***********************************************************************NORM0015 IMPLICIT REAL*8(A-H,O-Z) NORM0016 DIMENSION ICA(NOR,6),A(NOR,6),RN(NR,NR),IB(N) NORM0017 DO 1 L=1,6 NORM0018 DO 1 M=1,6 NORM0019 IF(ICA(I,L).GT.ICA(I,M))GOTO1 NORM0020 IF(ICA(I,L).EQ.0.OR.ICA(I,M).EQ.0)GOTO1 NORM0021 RN(ICA(I,L),ICA(I,M))=RN(ICA(I,L),ICA(I,M))+A(I,L)*A(I,M)*P NORM0022 IF(ICA(I,L).LT.IB(ICA(I,M)))IB(ICA(I,M))=ICA(I,L) NORM0023 1 CONTINUE NORM0024 RETURN NORM0025 END NORM0026 SUBROUTINE NORVEC(IOB,DOB,N,SPX,NP,IPX,ICP,RN,RU,A,ICA,AP,IC,IB, NORVEC01 @ NO,NS,NCODE,OX,NZERO,W,WX,NPR,NOR,NP2R,NR,NSR,ITER,ZER,CNAM,DOBR,NORVEC02 @NFAC,FAC) NORVEC03 C***********************************************************************NORVEC04 C* NORVEC05 C* NORVEC CONTROLS COMPUTATIONS IN FORMING THE NORMAL EQUATIONS AND THENORVEC06 C* CONSTANT VECTOR. IT ALSO CHECKS FOR VALID DIRECTION BUNDLE. ALSO NORVEC07 C* PRINTS MISCLOSURES ON THE ZEROTH ITERATION. NORVEC08 C* NORVEC09 C* NORVEC10 C* INPUT: NORVEC11 C* -ALL DESCRIBED IN MAIN NORVEC12 C* NORVEC13 C* OUTPUT: NORVEC14 C* -ALL DESCRIBED IN MAIN NORVEC15 C* NORVEC16 C* NORVEC17 C* WRITTEN BY: NORVEC18 C* R.R. STEEVES, JUNE, 1978 NORVEC19 C* NORVEC20 C***********************************************************************NORVEC21 IMPLICIT REAL*8(A-H,O-Z) NORVEC22 DIMENSION IOB(NOR, 4),DOB(NOR,4),SPX(NP2R,NP2R),IPX(NPR),ICP(NR),NORVEC23 @ RN(NR,NR),RU(NR),A(NOR,6),ICA(NOR,6),AP(NSR,12),IC(NSR,2),IB(NR),NORVEC24 @ OX(NPR,2),W(NOR),WX(NP2R),CNAM(NSR),DOBR(NOR,4),FAC(5) NORVEC25 IF(ITER.GT.0)GOTO8 NORVEC26 IF(NFAC.EQ.1)PRINT169,FAC(1),FAC(5),(FAC(I),I=2,4) NORVEC27 IF(NFAC.EQ.0)PRINT107 NORVEC28 107 FORMAT('1') NORVEC29 IF(NCODE.EQ.2)PRINT104 NORVEC30 IF(NCODE.EQ.1)PRINT105 NORVEC31 IF(NCODE.EQ.1)PRINT106 NORVEC32 IF(NCODE.EQ.2)PRINT102 NORVEC33 8 I=1 NORVEC34 C CHECK FOR DIRECTION BUNDLES OF ONE DIRECTION ONLY NORVEC35 1 IF(IOB(I,1).EQ.-2.OR.(IABS(IOB(I+1,1)).NE.2.AND.IOB(I,1).EQ.2)) @PRINT 101,I IF(IOB(I,1).EQ.-2.OR.(IABS(IOB(I+1,1)).NE.2.AND.IOB(I,1).EQ.2)) @STOP IG=IOB(I,1) NORVEC38 GOTO(2,3,4,5),IG NORVEC39 C ADD TO NORMAL AND CONSTANT VECTOR FOR DISTANCE OBSERVATIONS NORVEC40 2 CALL DIST(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS,NZERO, NORVEC41 @ ITER,W,NOR,NSR,NR,ZER,CNAM,DOBR) NORVEC42 GOTO6 NORVEC43 C ADD TO NORMAL AND CONSTANT VECTOR FOR DIRECTION OBSERVATIONS NORVEC44 3 CALL DIRN(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS,ITER,W, NORVEC45 @ NOR,NSR,NR,CNAM,DOBR) NORVEC46 GOTO6 NORVEC47 C ADD TO NORMAL AND CONSTANT VECTOR FOR ANGLE OBSERVATIONS NORVEC48 4 CALL ANGL(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS,ITER,W, NORVEC49 @ NOR,NSR,NR,CNAM,DOBR) NORVEC50 GOTO6 NORVEC51 C ADD TO NORMAL AND CONSTANT VECTOR FOR AZIMUTH OBSERVATIONS NORVEC52 5 CALL AZIM(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS,ITER,W, NORVEC53 @ NOR,NSR,NR,CNAM,DOBR) NORVEC54 6 IF(I.LE.NO)GOTO1 NORVEC55 IF(NP.EQ.0)GOTO7 NORVEC56 C ADD TO NORMAL AND CONSTANT VECTOR FOR WEIGHTED STATIONS NORVEC57 CALL XOBS(NCODE,RN,RU,N,SPX,NP,IPX,ICP,AP,OX,IB,NS,IC,WX,NR,NP2R, NORVEC58 @ NP2R,NSR,CNAM,NPR,NPR) NORVEC59 101 FORMAT(' ','*** INPUT ERROR #008 *** OBSERVATION NO. ',I4,' IS FIRNORVEC60 @ST AND POSSIBLY THE ONLY DIRECTION IN A BUNDLE,SHOULD HAVE CODE 2 NORVEC61 @NOT -2') NORVEC62 102 FORMAT(' ',21X,'AT',8X,'FROM',6X,'TO',10X,'OBSERVED',4X,'STD.DEV',NORVEC63 @3X,'REDUCED OBS', 3X,'MISCLOSURE',/) NORVEC64 104 FORMAT(' ',17X,'SUMMARY OF INPUT OBSERVATIONS, REDUCED OBSERVATIONNORVEC65 @S AND INITIAL MISCLOSURES:',/,' ',17X,75('-'),//) NORVEC66 105 FORMAT(' ',25X,'SUMMARY OF INPUT OBSERVATIONS AND THEIR STANDARD DNORVEC67 @EVIATIONS:',/,' ',25X,60('-'),//) NORVEC68 106 FORMAT(' ',42X,'AT',9X,'FROM',7X,'TO',8X,'STD.DEV',/) NORVEC69 169 FORMAT('1',15X,12('*'),' FACTORS FOR INPUT STANDARD DEVIATIONS OF NORVEC70 @OBSERVATIONS ',13('*'),/,' ',15X,'(DIST=',D10.3,' ,',D10.3,' ; DIRNORVEC71 @=',D10.3,' ; ANG=',D10.3,' ; AZ =',D10.3,')',/) NORVEC72 7 RETURN NORVEC73 END NORVEC74 SUBROUTINE PBLANK(PLOTV) PBLANK01 C***********************************************************************PBLANK02 C* PBLANK03 C* PBLANK CLEARS (SETS ELEMENTS TO BLANKS) VECTOR PLOTV, WHICH IS PBLANK04 C* USED IN SUBROUTINE PLOT. PBLANK05 C* PBLANK06 C* PBLANK07 C* WRITTEN BY: PBLANK08 C* LAURIE PACH, JULY, 1978 PBLANK09 C* PBLANK10 C***********************************************************************PBLANK11 INTEGER PLOTV PBLANK12 DIMENSION PLOTV(110) PBLANK13 DATA BLNK/' '/ PBLANK14 DO 1 I=1,110 PBLANK15 PLOTV(I)=BLNK PBLANK16 1 CONTINUE PBLANK17 RETURN PBLANK18 END PBLANK19 SUBROUTINE PLHXYZ(PHI,RLAM,H,XO,YO,ZO,A,B,X,Y,Z) PLHXYZ01 C***********************************************************************PLHXYZ02 C* PLHXYZ03 C* THIS ROUTINE COMPUTES THE CARTESIAN COORDINATES X,Y,Z GIVEN THEPLHXYZ04 C* ELLIPSOIDAL COORDINATES PHI,RLAM,H. PLHXYZ05 C* PLHXYZ06 C* PLHXYZ07 C* INPUT: PLHXYZ08 C* PHI-ELLIPSOIDAL LATITUDE IN RADIANS. PLHXYZ09 C* RLAM-ELLIPSOIDAL LONGITUDE IN RADIANS. PLHXYZ10 C* (POSITIVE EAST OF GREENWICH) PLHXYZ11 C* H-ELLIPSOIDAL HEIGHT IN METRES. PLHXYZ12 C* XO,YO,ZO-TRANSLATION COMPONENTS FROM THE ORIGIN OF THE PLHXYZ13 C* CARTESIAN COORDINATE SYTEM (X,Y,Z)TO THE CENTER PLHXYZ14 C* OF THE REFERENCE ELLIPSOID. (IN METRES.) PLHXYZ15 C* A,B-SEMI-MAJOR AND SEMI-MINOR AXES OF THE REFERENCE PLHXYZ16 C* ELLIPSOID IN METRES. PLHXYZ17 C* PLHXYZ18 C* OUTPUT: PLHXYZ19 C* X,Y,Z-CARTESIAN COORDINATES OF THE POINT IN METRES. PLHXYZ20 C* PLHXYZ21 C* PLHXYZ22 C* WRITTEN BY: PLHXYZ23 C* R.R. STEEVES, JUNE, 1977 PLHXYZ24 C* PLHXYZ25 C***********************************************************************PLHXYZ26 IMPLICIT REAL*8(A-Z) PLHXYZ27 E2=(A*A-B*B)/(A*A) PLHXYZ28 SP=DSIN(PHI) PLHXYZ29 CP=DCOS(PHI) PLHXYZ30 N=A/DSQRT(1.D0-E2*SP**2) PLHXYZ31 X=XO+(N+H)*CP*DCOS(RLAM) PLHXYZ32 Y=YO+(N+H)*CP*DSIN(RLAM) PLHXYZ33 Z=ZO+(N*(1.D0-E2)+H)*SP PLHXYZ34 RETURN PLHXYZ35 END PLHXYZ36 SUBROUTINE PLOT(WINT,HVEC) C***********************************************************************PLOT0002 C* PLOT0003 C* PLOT PLOTS THE STANDARD NORMAL CURVE OVERLAYED WITH THE HISTOGRAM OFPLOT0004 C* STANDARD RESIDUALS. PLOT0005 C* PLOT0006 C* PLOT0007 C* INPUT: PLOT0008 C* WINT- NUMBER OF HISTOGRAM INTERVALS PLOT0009 C* HVEC- VECTOR CONTAINING THE NUMBER OF RESIDUALS IN EACH HISTOGPLOT0010 C* INTERVAL PLOT0011 C* PLOT0012 C* PLOT0013 C* WRITTEN BY: PLOT0014 C* LAURIE PACH, JULY, 1978 PLOT0015 C* PLOT0016 C***********************************************************************PLOT0017 INTEGER WINT,NVEC,RVEC,HVEC,STAR,HLINE,VLINE,PLOTV,PLOTL,PLOTH PLOT0018 DIMENSION PLOTV(110),NVEC(53),PLOTL(110),PLOTH(110),RVEC(20), PLOT0019 @ HVEC(20) PLOT0020 DATA STAR,HLINE,VLINE/'.','-','|'/ PLOT0021 DATA NVEC/22*0,4*1,2,2,3,4,4,5,6,8,9,10,12,14,16,17,19,21,23,25, PLOT0022 @27,28,29,31,31,32,32,32,31/ PLOT0023 MAX=50 PLOT0024 A=.4 PLOT0025 K=2 PLOT0026 I=52 PLOT0027 NUMR=0 PLOT0028 KK=1 PLOT0029 NVAL=32 PLOT0030 NFLG=0 PLOT0031 IF(WINT.EQ.20)INT=5 PLOT0032 IF(WINT.EQ.10.OR.WINT.EQ.9)INT=10 PLOT0033 IF(WINT.EQ.2)INT=50 PLOT0034 IF(WINT.EQ.3)INT=30 PLOT0035 IF(WINT.EQ.5)INT=20 PLOT0036 IF(WINT.EQ.4)INT=25 PLOT0037 WIDF=10./FLOAT(INT) CALL PBLANK(PLOTV) PLOT0038 CALL PBLANK(PLOTH) PLOT0039 CALL PBLANK(PLOTL) PLOT0040 DO 2 JJ=1,WINT PLOT0041 NUMR=NUMR+HVEC(JJ) PLOT0042 2 CONTINUE PLOT0043 DO 33 JJ=1,WINT PLOT0044 RVEC(JJ)=(80*HVEC(JJ)/NUMR)*WIDF+.5 33 CONTINUE PLOT0046 PRINT103 PLOT0047 DO 29 JJ=1,50 PLOT0048 DO 28 N=1,WINT PLOT0049 IF(RVEC(N).GE.MAX)GOTO19 PLOT0050 28 CONTINUE PLOT0051 PRINT104 PLOT0052 IF(N.EQ.(WINT+1))N=WINT PLOT0053 IF(MAX.EQ.32)GOTO21 PLOT0054 MAX=MAX-1 PLOT0055 29 CONTINUE PLOT0056 19 RVEC(N)=0 PLOT0057 MM=(INT*(N-1))+1 PLOT0058 IF(WINT.EQ.9.OR.WINT.EQ.3)MM=(INT*(N-1))+6 PLOT0059 PLOTL(MM)=VLINE PLOT0060 III=INT-1 PLOT0061 DO 12 JJ=1,III PLOT0062 PLOTH(JJ+MM)=HLINE PLOT0063 12 CONTINUE PLOT0064 PLOTL(MM+INT)=VLINE PLOT0065 DO 32 N=1,WINT PLOT0066 IF(RVEC(N).EQ.MAX.OR.RVEC(N).GT.50)GOTO19 PLOT0067 32 CONTINUE PLOT0068 IF(NFLG.EQ.1)GOTO25 PLOT0069 PRINT101,(PLOTH(L),L=1,110) PLOT0070 CALL PBLANK(PLOTH) PLOT0071 CALL LPRNT(NVAL,MAX,PLOTL,RVEC,WINT,N,KK) PLOT0072 IF(RVEC(N).EQ.MAX.AND.MAX.NE.32)GOTO19 PLOT0073 21 DO 31 L=2,100 PLOT0074 PLOTV(I)=STAR PLOT0075 IF(NVEC(I).NE.NVEC(I-1))GOTO4 PLOT0076 K=K+1 PLOT0077 I=I-1 PLOT0078 31 CONTINUE PLOT0079 4 I=I-1 PLOT0080 NFLG=1 PLOT0081 IF(RVEC(N).EQ.MAX)GOTO19 PLOT0082 25 DO 26 L=1,110 PLOT0083 IF(PLOTH(L).EQ.HLINE)GOTO36 PLOT0084 26 CONTINUE PLOT0085 GOTO38 PLOT0086 36 DO 39 L=1,110 PLOT0087 IF(PLOTH(L).EQ.HLINE)PLOTV(L)=PLOTH(L) PLOT0088 39 CONTINUE PLOT0089 38 CALL PBLANK(PLOTH) PLOT0090 11 PRINT102,(PLOTV(L),L=1,110) PLOT0091 IF(MAX.EQ.32)PRINT113,A PLOT0092 IF(I.EQ.1)GOTO20 PLOT0093 NVAL=NVEC(I) PLOT0094 IF(NVAL.EQ.0)GOTO20 PLOT0095 CALL PBLANK(PLOTV) PLOT0096 DO 37 L=1,110 PLOT0097 IF(PLOTL(L).EQ.VLINE)PLOTV(L)=PLOTL(L) PLOT0098 37 CONTINUE PLOT0099 CALL LPRNT(NVAL,MAX,PLOTV,RVEC,WINT,N,KK) PLOT0100 CALL PBLANK(PLOTV) PLOT0101 DO 3 L=2,100 PLOT0102 PLOTV(I)=STAR PLOT0103 PLOTV(I+K)=STAR PLOT0104 K=K+2 PLOT0105 IF(I.EQ.1)GOTO11 PLOT0106 IF(NVEC(I).NE.NVEC(I-1))GOTO4 PLOT0107 I=I-1 PLOT0108 3 CONTINUE PLOT0109 GOTO4 PLOT0110 20 PRINT111 PLOT0111 PRINT112 PLOT0112 IF(WINT.EQ.20)PRINT107,(HVEC(L),L=1,20) PLOT0113 IF(WINT.EQ.10)PRINT106,(HVEC(L),L=1,10) PLOT0114 IF(WINT.EQ.4)PRINT108,(HVEC(L),L=1,4) PLOT0115 IF(WINT.EQ.2)PRINT109,(HVEC(L),L=1,2) PLOT0116 IF(WINT.EQ.9)PRINT116,(HVEC(L),L=1,9) PLOT0117 IF(WINT.EQ.5)PRINT114,(HVEC(L),L=1,5) PLOT0118 IF(WINT.EQ.3)PRINT115,(HVEC(L),L=1,3) PLOT0119 101 FORMAT(' ',6X,110A1) PLOT0120 102 FORMAT('+',6X,110A1) PLOT0121 103 FORMAT('1') PLOT0122 104 FORMAT(' ') PLOT0123 106 FORMAT(' ',8X,10(I4,6X),/) PLOT0124 107 FORMAT(' ',7X,20(I4,1X),/) PLOT0125 108 FORMAT(' ',15X,I4,3(21X,I4),/) PLOT0126 109 FORMAT(' ',34X,I4,36X,I4,/) PLOT0127 111 FORMAT(' ',6X,20('|----'),'|') PLOT0128 112 FORMAT(' ',5X,'-5',8X,'-4',8X,'-3',8X,'-2',8X,'-1',9X,'0',9X,'1' ,PLOT0129 @ 9X,'2',9X,'3',9X,'4',9X,'5',/) PLOT0130 113 FORMAT('+',3X,F3.1,'-') PLOT0131 114 FORMAT(' ',13X,I4,4(16X,I4),/) PLOT0132 115 FORMAT(' ',23X,3(I4,26X),/) PLOT0133 116 FORMAT(' ',14X,9(I4,6X),/) PLOT0134 RETURN PLOT0135 END PLOT0136 SUBROUTINE PLTSP (X,Y,XO,YO,KO,R,CHIO,SLAMO,CHI,SLAM) PLTSP001 C***********************************************************************PLTSP002 C* PLTSP003 C* THIS ROUTINE TRANSFORMS STEREOGRAPHIC GRID COORDINATES X,Y TO PLTSP004 C* SPHERICAL COORDINATES CHI,SLAM. PLTSP005 C* PLTSP006 C* PLTSP007 C* INPUT: PLTSP008 C* X - STEREOGRAPHIC GRID EASTING. PLTSP009 C* Y - STEREOGRAPHIC GRID NORTHING. PLTSP010 C* XO - FALSE EASTING. PLTSP011 C* YO - FALSE NORTHING. PLTSP012 C* KO - POINT SCALE FACTOR AT THE ORIGIN (FROM SPHERE TO PLTSP013 C* PLANE). PLTSP014 C* R - RADIUS OF THE SPHERE. PLTSP015 C* CHIO - SPHERICAL LATITUDE OF THE ORIGIN, IN RADIANS. PLTSP016 C* SLAMO - SPHERICAL LONGITUDE OF THE ORIGIN, IN RADIANS. PLTSP017 C* (POSITIVE EAST OF GREENWICH.) PLTSP018 C* PLTSP019 C* OUTPUT: PLTSP020 C* CHI - SPHERICAL LATITUDE OF THE POINT, IN RADIANS. PLTSP021 C* SLAM - SPHERICAL LONGITUDE OF THE POINT, IN RADIANS. PLTSP022 C* PLTSP023 C* PLTSP024 C* WRITTEN BY: PLTSP025 C* R.R. STEEVES, JULY, 1977 PLTSP026 C* PLTSP027 C***********************************************************************PLTSP028 IMPLICIT REAL*8(A-H,O-Z) PLTSP029 REAL*8 KO,K PLTSP030 XX=(X-XO)/KO PLTSP031 YY=(Y-YO)/KO PLTSP032 S=DSQRT(XX**2+YY**2) PLTSP033 DEL=2.D0*DATAN(S/2.D0/R) PLTSP034 CB=1.D0 PLTSP035 IF(S.GT.1.D-50)CB=XX/S PLTSP036 SB=0.D0 PLTSP037 IF(S.GT.1.D-50)SB=YY/S PLTSP038 CD=DCOS(DEL) PLTSP039 SD=DSIN(DEL) PLTSP040 CHI=DARSIN(DSIN(CHIO)*CD+DCOS(CHIO)*SD*SB) PLTSP041 SLAM=SLAMO+DARSIN(CB*SD/DCOS(CHI)) PLTSP042 RETURN PLTSP043 END PLTSP044 SUBROUTINE PRAR(ARRAY,RDIM,CDIM,R,C,ICODE,CNAM,NS,ITER, PRAR0001 @ IOB,NOR,IC,NSR,ICA,RU,W,CPX,NP,WX,NR,NP2R,NPR,NO) PRAR0002 C***********************************************************************PRAR0003 C* PRAR0004 C* PRAR PRINTS VARIOUS INTERMEDIATE RESULTS ON REQUEST. PRAR0005 C* PRAR0006 C* PRAR0007 C* INPUT: PRAR0008 C* ARRAY- MATRIX OR VECTOR TO BE PRINTED PRAR0009 C* RDIM- ROW DIMENSIONS OF ARRAY PRAR0010 C* CDIM- COLUMN DIMENSIONS OF ARRAY PRAR0011 C* R,C- ROW AND COLUMN SIZES OF ACTUAL MATRIX OR VECTOR TO BE PRPRAR0012 C* ICODE- CODE OF MATRIX OR VECTOR TO BE PRINTED. EACH CODE FOLLOWPRAR0013 C* = 1- DESIGN MATRIX A PRAR0014 C* =21- NORMAL EQUATIONS PRAR0015 C* =22- CHOLESKI SQUARE ROOT PRAR0016 C* =23- INVERSE OF NORMAL EQUATIONS (COVARIANCE MATRIX OF PARAMEPRAR0017 C* =24- COVARIANCE MATRIX OF WEIGHTED STATIONS PRAR0018 C* =25- WEIGHT MATRIX OF WEIGHTED STATIONS PRAR0019 C* =26- BLAHA WEIGHT MATRIX PRAR0020 C* =27- BLAHA COVARIANCE MATRIX PRAR0021 C* = 3- CONSTANT VECTOR PRAR0022 C* = 4- MISCLOSURE VECTOR PRAR0023 C* OTHERS- DESCRIBED IN MAIN PRAR0024 C* PRAR0025 C* PRAR0026 C* OUTPUT: PRAR0027 C* PRINTED MATRIX OR VECTOR ACCORDING TO ICODE. PRAR0028 C* PRAR0029 C* PRAR0030 C* WRITTEN BY: PRAR0031 C* LAURIE PACH, JUNE, 1978 PRAR0032 C* PRAR0033 C***********************************************************************PRAR0034 IMPLICIT REAL*8(A-H,O-Z) PRAR0035 INTEGER ROW,R,C,RDIM,CDIM,FLAG,IVC(200) PRAR0036 DIMENSION ARRAY(RDIM,CDIM),CNAM(NSR),IOB(NOR,4),IC(NSR,2),ICA(NOR PRAR0037 @,6),RU(NR),W(NOR),WX(NP2R),CPX(NPR),LCC(6) PRAR0038 DATA FB,BL/'FIXED',' '/ PRAR0039 IF(ICODE.EQ.1)PRINT10,ITER PRAR0040 IF(ICODE.EQ.21)PRINT11,ITER PRAR0041 IF(ICODE.EQ.22)PRINT14,ITER PRAR0042 IF(ICODE.EQ.23)PRINT15 PRAR0043 IF(ICODE.EQ.3)PRINT12,ITER PRAR0044 IF(ICODE.EQ.4)PRINT13,ITER PRAR0045 IF(ICODE.EQ.24)PRINT64 PRAR0046 IF(ICODE.EQ.25)PRINT65 PRAR0047 IF(ICODE.EQ.26)PRINT118 PRAR0048 IF(ICODE.EQ.27)PRINT119 PRAR0049 M=1 PRAR0050 DO 41 N=1,NS PRAR0051 IF(IC(N,1).EQ.0)GOTO41 PRAR0052 IVC(M)=N PRAR0053 M=M+1 PRAR0054 41 CONTINUE PRAR0055 NC=M-1 PRAR0056 C PRAR0057 IF(ICODE.NE.1)GOTO60 PRAR0058 N=1 PRAR0059 DO 20 ROW=1,R PRAR0060 FB1=BL PRAR0061 IF(IC(IOB(ROW,2),1).EQ.0)FB1=FB PRAR0062 FB2=BL PRAR0063 IF(IC(IOB(ROW,3),1).EQ.0)FB2=FB PRAR0064 FB3=BL PRAR0065 IF(IOB(ROW,1).NE.3)GOTO32 PRAR0066 IF(IC(IOB(ROW,4),1).EQ.0)FB3=FB PRAR0067 32 ID=IOB(ROW,1) PRAR0068 IF(ID.EQ.1)PRINT25,CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2 PRAR0069 IF(ID.EQ.1.AND.ICA(ROW,5).NE.0)PRINT26 PRAR0070 IF(IABS(ID).EQ.2)PRINT27,N,CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)), PRAR0071 @ FB2 PRAR0072 IF(ID.EQ.2)N=N+1 PRAR0073 IF(ID.EQ.-2)N=1 PRAR0074 IF(ID.EQ.3)PRINT28,CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2,CNAM PRAR0075 @ (IOB(ROW,4)),FB3 PRAR0076 IF(ID.EQ.4)PRINT29,CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2 PRAR0077 I=ROW PRAR0078 ID1=4 PRAR0079 IF(IOB(I,1).EQ.1.AND.ICA(I,5).NE.0)ID1=5 PRAR0080 IF(IOB(I,1).EQ.3)ID1=6 PRAR0081 PRINT 30,(ARRAY(ROW,L),L=1,ID1) PRAR0082 PRINT 31 PRAR0083 20 CONTINUE PRAR0084 RETURN PRAR0085 60 IF(ICODE.NE.21.AND.ICODE.NE.22.AND.ICODE.NE.23)GOTO70 PRAR0086 I=1 PRAR0087 LL=0 PRAR0088 IF(((C/2)*2).NE.C)LL=1 PRAR0089 J=1 PRAR0090 FLAG=0 PRAR0091 7 K=J+49 PRAR0092 N=0 PRAR0093 NCC=0 PRAR0094 C1=0 PRAR0095 6 IF(N+3.GT.NC)GOTO16 PRAR0096 IF(FLAG.EQ.0)GOTO38 PRAR0097 PRINT23,CNAM(IVC(N+1)),CNAM(IVC(N+2)),CNAM(IVC(N+3)) PRAR0098 PRINT95 PRAR0099 DO 210 L=1,6 PRAR0100 210 LCC(L)=NCC+L PRAR0101 PRINT110,(LCC(L),L=1,6) PRAR0102 42 DO 5 I=J,K PRAR0103 PRINT3,I,(ARRAY(I,C1+L),L=1,6) PRAR0104 IF(I.EQ.R)GOTO4 PRAR0105 5 CONTINUE PRAR0106 4 C1=C1+6 PRAR0107 N=N+3 PRAR0108 NCC=NCC+6 PRAR0109 GOTO6 PRAR0110 16 IF(N+3-NC.EQ.1)GOTO8 PRAR0111 IF(N+3-NC.EQ.2)GOTO9 PRAR0112 IF(LL.EQ.1)GOTO104 PRAR0113 IF(N.EQ.NC.AND.I.EQ.R)RETURN PRAR0114 J=J+50 PRAR0115 GOTO7 PRAR0116 8 IF(FLAG.EQ.0)GOTO43 PRAR0117 PRINT2,CNAM(IVC(N+1)),CNAM(IVC(N+2)) PRAR0118 IF(LL.EQ.1)PRINT101 PRAR0119 PRINT96 PRAR0120 DO 211 L=1,4 PRAR0121 211 LCC(L)=NCC+L PRAR0122 PRINT111,(LCC(L),L=1,4) PRAR0123 46 DO 17 I=J,K PRAR0124 PRINT18,I,(ARRAY(I,C1+L),L=1,4) PRAR0125 IF(LL.EQ.1)PRINT98,ARRAY(I,C1+5) PRAR0126 IF(I.EQ.R)RETURN PRAR0127 17 CONTINUE PRAR0128 J=J+50 PRAR0129 GOTO7 PRAR0130 43 PRINT44,CNAM(IVC(N+1)),CNAM(IVC(N+2)) PRAR0131 IF(LL.EQ.1)PRINT101 PRAR0132 PRINT96 PRAR0133 DO 212 L=1,4 PRAR0134 212 LCC(L)=NCC+L PRAR0135 PRINT111,(LCC(L),L=1,4) PRAR0136 FLAG=1 PRAR0137 GOTO46 PRAR0138 9 IF(FLAG.EQ.0)GOTO47 PRAR0139 PRINT19,CNAM(IVC(N+1)) PRAR0140 IF(LL.EQ.1)PRINT102 PRAR0141 PRINT97 PRAR0142 DO 213 L=1,2 PRAR0143 213 LCC(L)=NCC+L PRAR0144 PRINT112,(LCC(L),L=1,2) PRAR0145 49 DO 200 I=J,K PRAR0146 PRINT37,I,ARRAY(I,C1+1),ARRAY(I,C1+2) PRAR0147 IF(LL.EQ.1)PRINT99,ARRAY(I,C1+3) PRAR0148 IF(I.EQ.R)RETURN PRAR0149 200 CONTINUE PRAR0150 J=J+50 PRAR0151 GOTO7 PRAR0152 47 PRINT48,CNAM(IVC(N+1)) PRAR0153 PRINT97 PRAR0154 DO 214 L=1,2 PRAR0155 214 LCC(L)=NCC+6 PRAR0156 PRINT112,(LCC(L),L=1,2) PRAR0157 FLAG=1 PRAR0158 GOTO49 PRAR0159 104 PRINT103 PRAR0160 DO 105 I=J,K PRAR0161 PRINT 106,I,ARRAY(I,C1+1) PRAR0162 IF(I.EQ.R)RETURN PRAR0163 105 CONTINUE PRAR0164 J=J+50 PRAR0165 GOTO7 PRAR0166 38 PRINT39,CNAM(IVC(N+1)),CNAM(IVC(N+2)),CNAM(IVC(N+3)) PRAR0167 PRINT95 PRAR0168 DO 215 L=1,6 PRAR0169 215 LCC(L)=L+NCC PRAR0170 PRINT110,(LCC(L),L=1,6) PRAR0171 FLAG=1 PRAR0172 GOTO42 PRAR0173 C PRAR0174 70 IF(ICODE.NE.3)GOTO80 PRAR0175 PRINT50 PRAR0176 I1=1 PRAR0177 DO 51 I=1,NC PRAR0178 PRINT52,I,CNAM(IVC(I)),RU(I1),RU(I1+1) PRAR0179 I1=I1+2 PRAR0180 51 CONTINUE PRAR0181 RETURN PRAR0182 80 IF(ICODE.NE.4)GOTO90 PRAR0183 I=1 PRAR0184 PRINT53 PRAR0185 DO 54 J=1,NO PRAR0186 IF(IOB(J,1).EQ.1)PRINT55,CNAM(IOB(J,2)),CNAM(IOB(J,2)), PRAR0187 @CNAM(IOB(J,3)),W(J) PRAR0188 IF(IOB(J,1).EQ.3)PRINT56,CNAM(IOB(J,2)),CNAM(IOB(J,3)), PRAR0189 @ CNAM(IOB(J,4)),W(J) PRAR0190 IF(IOB(J,1).EQ.4)PRINT57,CNAM(IOB(J,2)),CNAM(IOB(J,2)), PRAR0191 @ CNAM(IOB(J,3)),W(J) PRAR0192 IF(IOB(J,1).EQ.2.OR.IOB(J,1).EQ.-2)GOTO58 PRAR0193 GOTO54 PRAR0194 58 PRINT59,I,CNAM(IOB(J,2)),CNAM(IOB(J,2)),CNAM(IOB(J,3)),W(J) PRAR0195 I=I+1 PRAR0196 IF(IOB(J,1).EQ.-2)I=1 PRAR0197 54 CONTINUE PRAR0198 K=2*NP PRAR0199 J=1 PRAR0200 IF(NP.EQ.0)RETURN PRAR0201 DO 61 I=1,K,2 PRAR0202 PRINT62,CPX(J),WX(I) PRAR0203 PRINT63,WX(I+1) PRAR0204 J=J+1 PRAR0205 61 CONTINUE PRAR0206 RETURN PRAR0207 90 IF(ICODE.NE.24.AND.ICODE.NE.25.AND.ICODE.NE.26.AND.ICODE.NE.27) PRAR0208 @GOTO100 PRAR0209 I=1 PRAR0210 J=1 PRAR0211 FLAG=0 PRAR0212 66 K=J+49 PRAR0213 N=0 PRAR0214 NCC=0 PRAR0215 C1=0 PRAR0216 67 IF(N+3.GT.NP)GOTO68 PRAR0217 IF(FLAG.EQ.0)GOTO69 PRAR0218 PRINT 71,CPX(N+1),CPX(N+2),CPX(N+3) PRAR0219 PRINT95 PRAR0220 DO 216 L=1,6 PRAR0221 216 LCC(L)=L+NCC PRAR0222 PRINT110,(LCC(L),L=1,6) PRAR0223 72 DO 75 I=J,K PRAR0224 PRINT 73,I,(ARRAY(I,C1+L),L=1,6) PRAR0225 IF(I.EQ.R)GOTO74 PRAR0226 75 CONTINUE PRAR0227 74 C1=C1+6 PRAR0228 N=N+3 PRAR0229 NCC=NCC+6 PRAR0230 GOTO67 PRAR0231 68 IF(N+3-NP.EQ.1)GOTO76 PRAR0232 IF(N+3-NP.EQ.2)GOTO77 PRAR0233 IF(N.EQ.NP.AND.I.EQ.R)RETURN PRAR0234 J=J+50 PRAR0235 GOTO66 PRAR0236 76 IF(FLAG.EQ.0)GOTO83 PRAR0237 PRINT78,CPX(N+1),CPX(N+2) PRAR0238 PRINT96 PRAR0239 DO 217 L=1,6 PRAR0240 217 LCC(L)=L+NCC PRAR0241 PRINT111,(LCC(L),L=1,6) PRAR0242 79 DO 81 I=J,K PRAR0243 PRINT82,I,(ARRAY(I,C1+L),L=1,4) PRAR0244 IF(I.EQ.R)RETURN PRAR0245 81 CONTINUE PRAR0246 J=J+50 PRAR0247 GOTO66 PRAR0248 83 PRINT84,CPX(N+1),CPX(N+2) PRAR0249 PRINT96 PRAR0250 DO 218 L=1,4 PRAR0251 218 LCC(L)=L+NCC PRAR0252 PRINT111,(LCC(L),L=1,4) PRAR0253 FLAG=1 PRAR0254 GOTO79 PRAR0255 77 IF(FLAG.EQ.0)GOTO85 PRAR0256 PRINT86,CPX(N+1) PRAR0257 PRINT97 PRAR0258 DO219 L=1,2 PRAR0259 219 LCC(L)=L+NCC PRAR0260 PRINT112,(LCC(L),L=1,2) PRAR0261 87 DO 88 I=J,K PRAR0262 PRINT89,I,ARRAY(I,C1+1),ARRAY(I,C1+2) PRAR0263 IF(I.EQ.R)RETURN PRAR0264 88 CONTINUE PRAR0265 J=J+50 PRAR0266 GOTO66 PRAR0267 85 PRINT91,CPX(N+1) PRAR0268 PRINT97 PRAR0269 DO 220 L=1,2 PRAR0270 220 LCC(L)=L+NCC PRAR0271 PRINT112,(LCC(L),L=1,2) PRAR0272 FLAG=1 PRAR0273 GOTO87 PRAR0274 69 PRINT92,CPX(N+1),CPX(N+2),CPX(N+3) PRAR0275 PRINT95 PRAR0276 DO 221 L=1,6 PRAR0277 221 LCC(L)=L+NCC PRAR0278 PRINT110,(LCC(L),L=1,6) PRAR0279 FLAG=1 PRAR0280 GOTO72 PRAR0281 2 FORMAT('1',7X,2(10('#'),1X,A8,1X,10('#'),4X)) PRAR0282 3 FORMAT(' ',1X,I3,2X,3(D15.8,1X,D15.8,3X)) PRAR0283 10 FORMAT('1',39X,'DESIGN MATRIX A (ITERATION #',I3,')',/,' ',39X, PRAR0284 @ 32('-'),//) PRAR0285 11 FORMAT('1',35X,'NORMAL EQUATION MATRIX (ITERATION #',I3,')',/, PRAR0286 @ ' ',35X,39('-'),/) PRAR0287 12 FORMAT('1',34X,'CONSTANT VECTOR ELEMENTS (ITERATION #',I3,')', PRAR0288 @ /,' ',34X,41('-'),//) PRAR0289 13 FORMAT('1',33X,'MISCLOSURE VECTOR ELEMENTS (ITERATION #',I3,')', PRAR0290 @ /,' ',33X,43('-'),//) PRAR0291 14 FORMAT('1',36X,'CHOLESKI SQUARE ROOT (ITERATION #',I3,')',/, PRAR0292 @ ' ',36X,37('-'),/) PRAR0293 15 FORMAT('1',37X,'COVARIANCE MATRIX OF THE PARAMETERS',/,38X,35('-')PRAR0294 @,//) PRAR0295 18 FORMAT(' ',1X,I3,2X,2(D15.8,1X,D15.8,3X)) PRAR0296 19 FORMAT('1',7X,10('#'),1X,A8,1X,10('#')) PRAR0297 23 FORMAT('1',7X,3(10('#'),1X,A8,1X,10('#'),4X),//) PRAR0298 25 FORMAT(' ','DISTANCE',6X,A8,4X,'(X,Y)',2X,A5,9X,A8,4X,'(X,Y)', PRAR0299 @ 2X,A5,9X) PRAR0300 26 FORMAT('+',80X,'ZERO ERROR') PRAR0301 27 FORMAT(' ','DIRECTION',I3,2X,A8,4X,'(X,Y)',2X,A5,9X,A8,4X,'(X,Y)',PRAR0302 @ 2X,A5,9X) PRAR0303 28 FORMAT(' ','ANGLE',9X,A8,4X,'(X,Y)',2X,A5,9X,A8,4X,'(X,Y)',2X,A5, PRAR0304 @ 9X,A8,4X,'(X,Y)',2X,A5,9X) PRAR0305 29 FORMAT(' ','AZIMUTH',7X,A8,4X,'(X,Y)',2X,A5,9X,A8,4X,'(X,Y)', PRAR0306 @ 2X,A5,9X) PRAR0307 30 FORMAT(' ',10X,3(3X,D14.7,2X,D14.7)) PRAR0308 31 FORMAT(' ',/) PRAR0309 37 FORMAT(' ',1X,I3,2X,D15.8,1X,D15.8) PRAR0310 39 FORMAT(' ',7X,3(10('#'),1X,A8,1X,10('#'),4X),//) PRAR0311 44 FORMAT(' ',7X,2(10('#'),1X,A8,1X,10('#'),4X)) PRAR0312 48 FORMAT(' ',7X,10('#'),1X,A8,1X,10('#'),//) PRAR0313 50 FORMAT(' ',32X,'STATION',12X,'(X)',14X,'(Y)',/) PRAR0314 52 FORMAT(' ',28X,I3,1X,A8,5X,D15.8,3X,D15.8,/) PRAR0315 53 FORMAT(' ',38X,'AT',9X,'FROM',7X,'TO',10X,'MISCLOSURE',//) PRAR0316 55 FORMAT(' ',24X,'DISTANCE',6X,A8,3X,A8,3X,A8,3X,D15.8,/) PRAR0317 56 FORMAT(' ',24X,'ANGLE',9X,A8,3X,A8,3X,A8,3X,D15.8,/) PRAR0318 57 FORMAT(' ',24X,'AZIMUTH',7X,A8,3X,A8,3X,A8,3X,D15.8,/) PRAR0319 59 FORMAT(' ',24X,'DIRECTION ',I2,2X,A8,3X,A8,3X,A8,3X,D15.8,/) PRAR0320 62 FORMAT(' ',24X,'COORDINATES',3X,A8,1X,18('.'),'(X)',3X,D15.8) PRAR0321 63 FORMAT(' ',65X,'(Y)',3X,D15.8,/) PRAR0322 64 FORMAT('1',42X,'A PRIORI COVARIANCE MATRIX',/,' ',42X,26('-'),/) PRAR0323 65 FORMAT('1',44X,'A PRIORI WEIGHT MATRIX',/,' ',44X,22('-'),/) PRAR0324 71 FORMAT('1',7X,3(10('#'),1X,A8,1X,10('#'),4X),//) PRAR0325 73 FORMAT(' ',1X,I3,2X,3(D15.8,1X,D15.8,3X)) PRAR0326 78 FORMAT('1',7X,2(10('#'),1X,A8,1X,10('#'),4X)) PRAR0327 82 FORMAT(' ',1X,I3,2X,2(D15.8,1X,D15.8,3X)) PRAR0328 84 FORMAT(' ',7X,2(10('#'),1X,A8,1X,10('#'),4X),//) PRAR0329 86 FORMAT('1',7X,10('#'),1X,A8,1X,10('#')) PRAR0330 89 FORMAT(' ',1X,I3,2X,D15.8,1X,D15.8) PRAR0331 91 FORMAT(' ',7X,10('#'),1X,A8,1X,10('#'),//) PRAR0332 92 FORMAT(' ',7X,3(10('#'),1X,A8,1X,10('#'),4X),//) PRAR0333 95 FORMAT(' ',13X,3('X',14X,'Y',18X),/) PRAR0334 96 FORMAT(' ',/,' ',13X,2('X',14X,'Y',18X),/) PRAR0335 97 FORMAT(' ',/,' ',13X,'X',14X,'Y',/) PRAR0336 98 FORMAT('+',74X,D15.8) PRAR0337 99 FORMAT('+',40X,D15.8) PRAR0338 101 FORMAT('+',75X,'# ZERO ERROR #') PRAR0339 102 FORMAT('+',40X,'# ZERO ERROR #') PRAR0340 103 FORMAT('1',7X,'# ZERO ERROR #',//) PRAR0341 106 FORMAT(' ',1X,I3,2X,D15.8) PRAR0342 110 FORMAT(' ',9X,3('(COL',I4,')',7X,'(COL',I4,')',8X),/) PRAR0343 111 FORMAT(' ',9X,2('(COL',I4,')',7X,'(COL',I4,')',8X),/) PRAR0344 112 FORMAT(' ',9X,'(COL',I4,')',7X,'(COL',I4,')',/) PRAR0345 118 FORMAT('1',45X,'BLAHA WEIGHT MATRIX',/,' ',45X,19('-'),/) PRAR0346 119 FORMAT('1',43X,'BLAHA COVARIANCE MATRIX',/,' ',43X,23('-'),/) PRAR0347 100 RETURN PRAR0348 END PRAR0349 SUBROUTINE PRES(IDF,S0,NO,IOB,DOB,ZER,V,NV,CNAM,NSR,DOBR,NOR, PRES0001 @ NSRES) PRES0002 C***********************************************************************PRES0003 C* PRES0004 C* PRES COMPUTES ADUSTED OBSERVATIONS AND APPROXIMATE STANDARD DEVIATIOPRES0005 C* OF RESIDUALS IF REQUESTED. ALSO PRINTS THIS INFORMATION. STANDARDIZPRES0006 C* RESIDUALS. PRES0007 C* PRES0008 C* PRES0009 C* INPUT: PRES0010 C* -ALL DESCRIBED IN MAIN PRES0011 C* PRES0012 C* PRES0013 C* WRITTEN BY: PRES0014 C* R.R. STEEVES, JULY, 1978 PRES0015 C* PRES0016 C***********************************************************************PRES0017 IMPLICIT REAL*8(A-H,O-Z) PRES0018 DIMENSION IOB(NOR,4),DOB(NOR,4),DOBR(NOR,4),V(NV),CNAM(NSR) PRES0019 PI2=2.D0*3.141592653589793D0 PRES0020 RO=1296.D3/PI2 PRES0021 I=1 PRES0022 FACV=1.0D0 PRES0023 IF(NSRES.EQ.1)FACV=DSQRT(S0/NO) PRES0024 PRINT 109 PRES0025 PRINT 104 PRES0026 16 IFR=IOB(I,2) PRES0027 IT1=IOB(I,3) PRES0028 IT2=IOB(I,4) PRES0029 IDEG=DOB(I,2) PRES0030 IMIN=DOB(I,3) PRES0031 SEC=DOB(I,4) PRES0032 IG=IOB(I,1) PRES0033 GOTO(17,18,21,22),IG PRES0034 17 ADJ=DOB(I,3)+V(I)+ZER PRES0035 STD=DOBR(I,1) PRES0036 DOB(I,1)=FACV*STD PRES0037 PRINT 105,I,CNAM(IFR),CNAM(IFR),CNAM(IT1), DOB(I,3) , STD, PRES0038 @V(I),DOB(I,1),ADJ PRES0039 GOTO23 PRES0040 18 J=1 PRES0041 19 IDEG=DOB(I,2) PRES0042 IMIN=DOB(I,3) PRES0043 IFR=IOB(I,2) PRES0044 IT1=IOB(I,3) PRES0045 SEC=DOB(I,4) PRES0046 IF(J.NE.1)GOTO31 PRES0047 IDA=DOB(I,2) PRES0048 IMA=DOB(I,3) PRES0049 SA=DOB(I,4) PRES0050 V1=V(I) PRES0051 GOTO32 PRES0052 31 ADJ=V(I)-V1 PRES0053 CALL DMSRAD(IDEG,IMIN,SEC,RA) PRES0054 RA=RA+ADJ/RO PRES0055 IF(RA.LT.0.D0)RA=RA+PI2 PRES0056 CALL RADMS(RA,IDA,IMA,SA) PRES0057 32 CONTINUE PRES0058 STD=DOBR(I,1) PRES0059 DOB(I,1)=FACV*STD PRES0060 PRINT106,I,J,CNAM(IFR),CNAM(IFR),CNAM(IT1),IDEG,IMIN,SEC, PRES0061 @STD,V(I),DOB(I,1),IDA,IMA,SA PRES0062 IF(IOB(I,1).EQ.-2)GOTO23 PRES0063 I=I+1 PRES0064 J=J+1 PRES0065 GOTO19 PRES0066 21 ADJ=V(I) PRES0067 STD=DOBR(I,1) PRES0068 DOB(I,1)=FACV*STD PRES0069 CALL DMSRAD(IDEG,IMIN,SEC,RA) PRES0070 RA=RA+ADJ/RO PRES0071 IF(RA.LT.0.D0)RA=RA+PI2 PRES0072 CALL RADMS(RA,IDA,IMA,SA) PRES0073 PRINT107,I,CNAM(IFR),CNAM(IT1),CNAM(IT2),IDEG,IMIN,SEC, PRES0074 @ STD,V(I),DOB(I,1),IDA,IMA,SA PRES0075 GOTO23 PRES0076 22 ADJ=V(I) PRES0077 STD=DOBR(I,1) PRES0078 DOB(I,1)=FACV*STD PRES0079 CALL DMSRAD(IDEG,IMIN,SEC,RA) PRES0080 RA=RA+ADJ/RO PRES0081 IF(RA.LT.0.D0)RA=RA+PI2 PRES0082 CALL RADMS(RA,IDA,IMA,SA) PRES0083 PRINT108,I,CNAM(IFR),CNAM(IFR),CNAM(IT1),IDEG,IMIN,SEC, PRES0084 @STD,V(I),DOB(I,1),IDA,IMA,SA PRES0085 23 I=I+1 PRES0086 IF(I.LE.NO)GOTO16 PRES0087 104 FORMAT(' ',20X,'AT',8X,'FROM',6X,'TO',9X,'REDUCED OBS',2X,'STD.DEVPRES0088 @',2X,'RESIDUAL',2X,'STD.DEV',3X,'ADJ.OBSERVATION',/) PRES0089 105 FORMAT(' ',I4,2X,'DISTANCE',6X,A8,2X,A8,2X,A8,F12.3,F10.3,F10.3, PRES0090 @F9.3,F15.3,/) PRES0091 106 FORMAT(' ',I4,2X,'DIRECTION',I3,2X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2,PRES0092 @ F9.2,F9.2,I9,I3,F6.2,/) PRES0093 107 FORMAT(' ',I4,2X,'ANGLE',9X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2, PRES0094 @ F9.2,F9.2,I9,I3,F6.2,/) PRES0095 108 FORMAT(' ',I4,2X,'AZIMUTH',7X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2, PRES0096 @ F9.2,F9.2,I9,I3,F6.2,/) PRES0097 109 FORMAT('1',21X,'SUMMARY OF REDUCED OBSERVATIONS, RESIDUALS AND ADJPRES0098 @USTED OBSERVATIONS:',/,' ',21X,68('-'),//) PRES0099 RETURN PRES0100 END PRES0101 SUBROUTINE PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSRPRIT0001 @,NFIX,NPROJ,NUNIT,NELPS,NSTAN,ALPH,NFAC,NZERO,NTEST,NCOV, PRIT0002 @ NCORR,NMULT,NITER,NDELX,NCRIT,CONVG,NRED1,NRED2,NCENT,CENT, PRIT0003 @ NRED3,I12,NB,CBH,NBR,ZER,NCOVB,IBH,IPX,AA,BB,RP,RL,XO,YO,X1,Y1, PRIT0004 @Z1,RKO,IDF) PRIT0005 C***********************************************************************PRIT0006 C* PRIT0007 C* PRIT PRINTS TITLE PAGE, INITIAL AND ADJUSTED COORDINATES. PRIT0008 C* PRIT0009 C* PRIT0010 C* INPUT: PRIT0011 C* -ALL DESCRIBED IN MAIN PRIT0012 C* PRIT0013 C* OUTPUT: PRIT0014 C* -ALL DESCRIBED IN MAIN PRIT0015 C* PRIT0016 C* PRIT0017 C* WRITTEN BY: PRIT0018 C* R.R. STEEVES, JUNE, 1978 PRIT0019 C* PRIT0020 C***********************************************************************PRIT0021 IMPLICIT REAL*8(A-H,O-Z) PRIT0022 LOGICAL*1 DATE(18),TIME(6) PRIT0023 DIMENSION TL(10),CNF(NFR),CPX(NPR),CNAM(NSR),AP(NSR,12), PRIT0024 @ NFIX(NFR),CBH(NBR),IBH(NBR),CENT(4),IPX(NPR) PRIT0025 IF(I12.EQ.2)GOTO50 PRIT0026 PRINT110 PRIT0027 PRINT101 PRIT0028 PRINT 102 PRIT0029 PRINT 103,(TL(I),I=1,10) PRIT0030 PRINT 102 PRIT0031 PRINT 101 PRIT0032 CALL GDATE(DATE,TIME) PRIT0033 PRINT701,(DATE(I),I=1,18),(TIME(I),I=1,6) PRIT0034 PRINT 153 PRIT0035 PRINT 154 PRIT0036 DATA ADJ1,ADJ2,PRE1,PRE2,Z4,Z5,UF,UM,ALL1,ALL2,ABS1,ABS2,REL1,REL2PRIT0037 @,ANSY,ANSN,XTAU1,XTAU2,XNOR1,XNOR2/'.... AD','JUSTMENT','... PREPRIT0038 @','ANALYSIS','R ZONE 4','R ZONE 5','.. FOOT','. METRE','........PRIT0039 @','... ALL','. ABSOL','UTE ONLY','. RELAT','IVE ONLY',' YES',' PRIT0040 @ NO',' MAX','IMUM TAU',' MAXIMU','M NORMAL'/ PRIT0041 DATA RNON,BLNK/'NONE ',' '/ PRIT0042 DATA TAU1,TAU2,RNOR1,RNOR2,ST1,ST2,XST1,XST2/' TAU (','NON-MAX)'PRIT0043 @,'NORMAL (','NON-MAX)',' ST','UDENTS-T',' STUDEN','TS-T MAX'PRIT0044 @/ PRIT0045 IF(NCODE.EQ.1)PRINT 155,PRE1,PRE2 PRIT0046 IF(NCODE.EQ.2)PRINT 155,ADJ1,ADJ2 PRIT0047 PRINT503 PRIT0048 PRINT157 PRIT0049 MAX=MAX0(NF,NP,NB) PRIT0050 IF(NF.EQ.0)PRINT501,RNON,BLNK,BLNK PRIT0051 IF(NP.EQ.0)PRINT501,BLNK,RNON,BLNK PRIT0052 IF(NB.EQ.0)PRINT501,BLNK,BLNK,RNON PRIT0053 IF(MAX.EQ.0)GOTO208 PRIT0054 DO 502 I=1,MAX PRIT0055 IF(I.LE.NF)PRINT501,CNF(I),BLNK,BLNK PRIT0056 IF(I.LE.NP)PRINT501,BLNK,CPX(I),BLNK PRIT0057 IF(I.LE.NB)PRINT501,BLNK,BLNK,CBH(I) PRIT0058 PRINT503 PRIT0059 502 CONTINUE PRIT0060 208 PRINT503 PRIT0061 IF(NCOV.EQ.1.AND.NP.NE.0)PRINT173 PRIT0062 IF(NCOV.EQ.0.AND.NP.NE.0)PRINT172 PRIT0063 IF(NCOVB.EQ.1.AND.NB.NE.0)PRINT187 PRIT0064 IF(NCOVB.EQ.0.AND.NB.NE.0)PRINT188 PRIT0065 IF(NPROJ.EQ.5.AND.NCODE.EQ.2)PRINT159,Z5 PRIT0066 IF(NPROJ.EQ.4.AND.NCODE.EQ.2)PRINT159,Z4 PRIT0067 IF(NPROJ.EQ.3.AND.NCODE.EQ.2)PRINT156 PRIT0068 IF(NPROJ.EQ.2.AND.NCODE.EQ.2)PRINT161 PRIT0069 IF(NPROJ.EQ.1.AND.NCODE.EQ.2)PRINT162 PRIT0070 IF(NUNIT.EQ.0)PRINT163,UM PRIT0071 IF(NUNIT.EQ.1)PRINT163,UF PRIT0072 IF(NZERO.EQ.1)PRINT170,ANSY PRIT0073 IF(NTEST.EQ.0.AND.NCODE.EQ.2.AND.IDF.NE.0)PRINT171,XTAU1,XTAU2 PRIT0074 IF(NTEST.EQ.1.AND.NCODE.EQ.2.AND.IDF.NE.0)PRINT171,TAU1,TAU2 PRIT0075 IF(NTEST.EQ.2.AND.NCODE.EQ.2.AND.IDF.NE.0)PRINT171,XNOR1,XNOR2 PRIT0076 IF(NTEST.EQ.3.AND.NCODE.EQ.2.AND.IDF.NE.0)PRINT171,RNOR1,RNOR2 PRIT0077 IF(NTEST.EQ.4.AND.NCODE.EQ.2.AND.IDF.NE.0)PRINT171,ST1,ST2 PRIT0078 IF(NTEST.EQ.5.AND.NCODE.EQ.2.AND.IDF.NE.0)PRINT171,XST1,XST2 PRIT0079 IF(NMULT.EQ.0.AND.NCODE.EQ.2.AND.IDF.NE.0)PRINT175,ANSN PRIT0080 IF(NMULT.EQ.1.AND.NCODE.EQ.2.AND.IDF.NE.0)PRINT175,ANSY PRIT0081 IF(NCODE.EQ.2)PRINT176,NITER PRIT0082 IF(NCODE.EQ.2)PRINT179,CONVG PRIT0083 IF(NRED1.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)PRINT180,ANSN PRIT0084 IF(NRED1.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3)PRINT180,ANSY PRIT0085 IF(NRED2.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)PRINT181,ANSN PRIT0086 IF(NRED2.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3)PRINT181,ANSY PRIT0087 IF(NRED3.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)PRINT184,ANSN PRIT0088 IF(NRED3.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3.AND.(NRED1.EQ.1.OR. PRIT0089 @NRED2.EQ.1))PRINT184,ANSY PRIT0090 IF(NRED3.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3.AND.NRED1.EQ.0.AND. PRIT0091 @NRED2.EQ.0)PRINT184,ANSN PRIT0092 IF(NCENT.EQ.1)PRINT183,(CENT(I),I=1,4) PRIT0093 IF(NPROJ.NE.3.AND.NCODE.EQ.2)CALL PROINF(NPROJ,AA,BB,RP,RL,XO, PRIT0094 @YO,X1,Y1,Z1,RKO,NUNIT) PRIT0095 IF(I12.EQ.1)PRINT107 PRIT0096 50 IF(I12.EQ.2)PRINT207 PRIT0097 PRINT111 PRIT0098 IF(NPROJ.NE.3)GOTO300 PRIT0099 PRINT108 PRIT0100 DO 3 I=1,NS PRIT0101 IF(NP.EQ.0)GOTO601 PRIT0102 DO 602 K=1,NP PRIT0103 IF(I.EQ.IPX(K))GOTO3 PRIT0104 602 CONTINUE PRIT0105 601 IF(NF.EQ.0)GOTO8 PRIT0106 DO 5 K=1,NF PRIT0107 IF(I.EQ.NFIX(K))GOTO3 PRIT0108 5 CONTINUE PRIT0109 8 IF(NB.EQ.0)GOTO4 PRIT0110 DO 7 K=1,NB PRIT0111 IF(I.EQ.IBH(K))GOTO3 PRIT0112 7 CONTINUE PRIT0113 4 PRINT 109,CNAM(I),(AP(I,J),J=1,2) PRIT0114 3 CONTINUE PRIT0115 IF(NF.EQ.0.AND.NB.EQ.0.AND.NP.EQ.0)GOTO1 PRIT0116 IF(NF.EQ.0)GOTO6 PRIT0117 PRINT104 PRIT0118 PRINT108 PRIT0119 DO 2 I=1,NF PRIT0120 PRINT109,CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,2) PRIT0121 2 CONTINUE PRIT0122 6 IF(NP.EQ.0)GOTO603 PRIT0123 PRINT604 PRIT0124 PRINT108 PRIT0125 DO 605 I=1,NP PRIT0126 PRINT109,CNAM(IPX(I)),(AP(IPX(I),J),J=1,2) PRIT0127 605 CONTINUE PRIT0128 603 IF(NB.EQ.0)GOTO1 PRIT0129 PRINT404 PRIT0130 PRINT108 PRIT0131 DO 405 I=1,NB PRIT0132 PRINT109,CNAM(IBH(I)),(AP(IBH(I),J),J=1,2) PRIT0133 405 CONTINUE PRIT0134 GOTO1 PRIT0135 300 IF(I12.EQ.1)PRINT201 PRIT0136 IF(I12.EQ.2)PRINT202 PRIT0137 DO 303 I=1,NS PRIT0138 IF(NF.EQ.0)GOTO406 PRIT0139 DO 305 K=1,NF PRIT0140 IF(I.EQ.NFIX(K))GOTO303 PRIT0141 305 CONTINUE PRIT0142 406 IF(NP.EQ.0)GOTO606 PRIT0143 DO 607 K=1,NP PRIT0144 IF(I.EQ.IPX(K))GOTO303 PRIT0145 607 CONTINUE PRIT0146 606 IF(NB.EQ.0)GOTO304 PRIT0147 DO 9 K=1,NB PRIT0148 IF(I.EQ.IBH(K))GOTO303 PRIT0149 9 CONTINUE PRIT0150 304 CALL RADMS(AP(I,9),IDP,IMP,SP) PRIT0151 CALL RADMS(AP(I,10),IDL,IML,SL) PRIT0152 CALL RADMS(AP(I,12),IDC,IMC,SC) PRIT0153 IF(I12.EQ.1)PRINT209,CNAM(I),(AP(I,J),J=1,6),IDP,IMP,SP,IDL,IML, PRIT0154 @ SL,AP(I,11),IDC,IMC,SC PRIT0155 IF(I12.EQ.2)PRINT210,CNAM(I),(AP(I,J),J=1,2),IDP,IMP,SP,IDL,IML, PRIT0156 @ SL,AP(I,11),IDC,IMC,SC PRIT0157 303 CONTINUE PRIT0158 IF(NF.EQ.0.AND.NB.EQ.0.AND.NP.EQ.0)GOTO1 PRIT0159 IF(NF.EQ.0)GOTO10 PRIT0160 PRINT104 PRIT0161 IF(I12.EQ.1)PRINT201 PRIT0162 IF(I12.EQ.2)PRINT202 PRIT0163 DO 302 I=1,NF PRIT0164 CALL RADMS(AP(NFIX(I),9),IDP,IMP,SP) PRIT0165 CALL RADMS(AP(NFIX(I),10),IDL,IML,SL) PRIT0166 CALL RADMS(AP(NFIX(I),12),IDC,IMC,SC) PRIT0167 IF(I12.EQ.1)PRINT 209,CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,6),IDP,IMP,PRIT0168 @ SP,IDL,IML,SL,AP(NFIX(I),11),IDC,IMC,SC PRIT0169 IF(I12.EQ.2)PRINT210,CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,2),IDP,IMP, PRIT0170 @ SP,IDL,IML,SL,AP(NFIX(I),11),IDC,IMC,SC PRIT0171 302 CONTINUE PRIT0172 10 IF(NP.EQ.0)GOTO608 PRIT0173 PRINT604 PRIT0174 IF(I12.EQ.1)PRINT201 PRIT0175 IF(I12.EQ.2)PRINT202 PRIT0176 DO 609 I=1,NP PRIT0177 CALL RADMS(AP(IPX(I),9),IDP,IMP,SP) PRIT0178 CALL RADMS(AP(IPX(I),10),IDL,IML,SL) PRIT0179 CALL RADMS(AP(IPX(I),12),IDC,IMC,SC) PRIT0180 IF(I12.EQ.1)PRINT209,CNAM(IPX(I)),(AP(IPX(I),J),J=1,6),IDP,IMP, PRIT0181 @ SP,IDL,IML,SL,AP(IPX(I),11),IDC,IMC,SC PRIT0182 IF(I12.EQ.2)PRINT210,CNAM(IPX(I)),(AP(IPX(I),J),J=1,2),IDP, PRIT0183 @ IMP,SP,IDL,IML,SL,AP(IPX(I),11),IDC,IMC,SC PRIT0184 609 CONTINUE PRIT0185 608 IF(NB.EQ.0)GOTO1 PRIT0186 PRINT404 PRIT0187 IF(I12.EQ.1)PRINT201 PRIT0188 IF(I12.EQ.2)PRINT202 PRIT0189 DO 11 I=1,NB PRIT0190 CALL RADMS(AP(IBH(I),9),IDP,IMP,SP) PRIT0191 CALL RADMS(AP(IBH(I),10),IDL,IML,SL) PRIT0192 CALL RADMS(AP(IBH(I),12),IDC,IMC,SC) PRIT0193 IF(I12.EQ.1)PRINT209,CNAM(IBH(I)),(AP(IBH(I),J),J=1,6),IDP,IMP, PRIT0194 @ SP,IDL,IML,SL,AP(IBH(I),11),IDC,IMC,SC PRIT0195 IF(I12.EQ.2)PRINT210,CNAM(IBH(I)),(AP(IBH(I),J),J=1,2),IDP,IMP, PRIT0196 @ SP,IDL,IML,SL,AP(IBH(I),11),IDC,IMC,SC PRIT0197 11 CONTINUE PRIT0198 1 IF(I12.EQ.2.AND.NZERO.EQ.1)PRINT211, ZER PRIT0199 101 FORMAT(' ',2X,106('*')) PRIT0200 102 FORMAT(' ',2X,'*',104X,'*') PRIT0201 103 FORMAT(' ',2X,'*',12X,10A8,12X,'*') PRIT0202 104 FORMAT(' ',/,' ',47X,'FIXED STATIONS:',/,' ',47X,14('-'),/) PRIT0203 107 FORMAT('1',22X,'I N I T I A L A P P R O X I M A T E C O O R D PRIT0204 @I N A T E S',/,' ',22X,61('-'),//) PRIT0205 108 FORMAT(' ',25X,' STATION ',13X,'X (E)',13X,'Y (N)',/) PRIT0206 109 FORMAT(' ',29X,A8,5X,F15.4,3X,F15.4,/) PRIT0207 110 FORMAT('1') PRIT0208 111 FORMAT(' ',47X,'FREE STATIONS:',/,' ',47X,13('-'),/) PRIT0209 211 FORMAT(' ',/,' ',40X,'ZERO ERROR=',F9.4) PRIT02 0 153 FORMAT(' ',/) PRIT0211 154 FORMAT(' ',39X,'O P T I O N S I N E F F E C T',/' ',39X,31('-'),PRIT0212 @ /) PRIT0213 155 FORMAT(' ',15X,'PREANALYSIS OR ADJUSTMENT ',38('.'),2A8,/) PRIT0214 156 FORMAT(' ',15X,'MAP PROJECTION ',59('.'), 2X,'NONE',/) PRIT0215 157 FORMAT(' ',15X,'FIXED STATIONS',18X,'WEIGHTED STATIONS',17X,'BLAHAPRIT0216 @ STATIONS',/) PRIT0217 159 FORMAT(' ',15X,'MAP PROJECTION ',16('.'),2X, PRIT0218 @ 'NOVA SCOTIA 3 DEGREE TRANSVERSE MERCATO',A8,/) PRIT0219 161 FORMAT(' ',15X,'MAP PROJECTION ',24('.'),'PRINCE EDWARD ISLAND DOUPRIT0220 @BLE STEREOGRAPHIC',/) PRIT0221 162 FORMAT(' ',15X,'MAP PROJECTION ',31('.'),'NEW BRUNSWICK DOUBLE STEPRIT0222 @REOGRAPHIC',/) PRIT0223 163 FORMAT(' ',15X,'CONVENTIONAL LINEAR UNIT ',47('.'),A8,/) PRIT0224 170 FORMAT(' ',15X,'ZERO ERROR ESTIMATED FOR DISTANCE OBSERVATIONS? ' PRIT0225 @ ,27('.'),1X,A4,/) PRIT0226 171 FORMAT(' ',15X,'TEST USED FOR REJECTION OF RESIDUALS ',27('.'), PRIT0227 @ 2A8,/) PRIT0228 172 FORMAT(' ',15X,'WEIGHTED WEIGHT OR COVARIANCE MATRIX READ?', PRIT0229 @ 19('.'),2X,'COVARIANCE MATRIX',/) PRIT0230 173 FORMAT(' ',15X,'WEIGHTED WEIGHT OR COVARIANCE MATRIX READ',23('.')PRIT0231 @ ,2X,'WEIGHT MATRIX',/) PRIT0232 175 FORMAT(' ',15X,'MULTIPLY INVERSE OF NORMAL EQUATIONS BY ESTIMATED PRIT0233 @VARIANCE FACTOR? ',8('.'),1X,A4,/) PRIT0234 176 FORMAT(' ',15X,'MAXIMUM NUMBER OF ITERATIONS ALLOWED ',38('.'), PRIT0235 @ 2X,I3,/) PRIT0236 179 FORMAT(' ',15X,'CRITERION FOR SOLUTION CONVERGENCE ',34('.'), PRIT0237 @ F11.6,/) PRIT0238 180 FORMAT(' ',15X,'MAKE OBSERVATION REDUCTIONS (TERRAIN TO ELLIPSOID)PRIT0239 @?' ,24('.'),1X,A4,/) PRIT0240 181 FORMAT(' ',15X,'MAKE OBSERVATION REDUCTIONS (ELLIPSOID TO MAPPING PRIT0241 @PLANE)? ',17('.'),1X,A4,/) PRIT0242 183 FORMAT(' ',15X,'CENTERING ERROR FOR OBSERVATIONS ',11('.'), PRIT0243 @ 4(2X,F7.4),/) PRIT0244 184 FORMAT(' ',15X,'REDUCTIONS FROM TERRIAN TO MAPPING PLANE MADE FOR PRIT0245 @AZIMUTHS ',16('.'),1X,A4,/) PRIT0246 187 FORMAT(' ',15X,'BLAHA WEIGHT OR COVARIANCE MATRIX READ',27('.'), PRIT0247 @ 2X,'WEIGHT MATRIX',/) PRIT0248 188 FORMAT(' ',15X,'BLAHA WEIGHT OR COVARIANCE MATRIX READ?',22('.'), PRIT0249 @ 2X,'COVARIANCE MATRIX',/) PRIT0250 207 FORMAT('1',27X,'F I N A L A D J U S T E D C O O R D I N A T E PRIT0251 @S',/,' ',27X,51('-'),//) PRIT0252 201 FORMAT(' ',15X,'X',11X,'Y',5X,'ORTHOMETRIC GEOID DEFLECTION',28XPRIT0253 @,'POINT',4X,'MERIDIAN',/,' ','STATION',4X,'(EASTING)',2X,'(NORTHINPRIT0254 @G)',3X,'HEIGHT',4X,'HEIGHT',2X,'COMPONENTS',2X,'LATITUDE',6X, PRIT0255 @ 'LONGITUDE',3X,'SCALE',2X,'CONVERGENCE',/) PRIT0256 202 FORMAT(' ',22X,'X',12X,'Y',46X,'POINT',8X,'MERIDIAN',/,' ',7X, PRIT0257 @ 'STATION',4X,'(EASTING)',4X,'(NORTHING)',6X,'LATITUDE',10X, PRIT0258 @ 'LONGITUDE',8X,'SCALE',6X,'CONVERGENCE',/) PRIT0259 209 FORMAT(' ',A8,2F12.3,F10.3,F9.3,2F6.1,I3,I3,F6.2,I5,I3,F6.2,F9.6, PRIT0260 @ I3,I3,F5.1,/) PRIT0261 210 FORMAT(' ',7X,A8,2F13.4,I6,I3,F9.5,I7,I3,F9.5,F12.7,I5,I3,F6.2,/) PRIT0262 404 FORMAT(' ',/,' ',47X,'BLAHA STATIONS:',/,' ',47X,14('-'),/) PRIT0263 501 FORMAT('+',18X,A8,26X,A8,24X,A8) PRIT0264 503 FORMAT(' ') PRIT0265 604 FORMAT(' ',/,' ',45X,'WEIGHTED STATIONS:',/,' ',45X,17('-'),/) PRIT0266 701 FORMAT(' ',40X,18A1,4X,2A1,':',2A1,':',2A1) PRIT0267 RETURN PRIT0268 END PRIT0269 SUBROUTINE PROINF(NPROJ,AA,BB,RP,RL,XO,YO,X1,Y1,Z1,RKO,NUNIT) PROINF01 C***********************************************************************PROINF02 C* PROINF03 C* PROINF PRINTS PROJECTION SPECIFICATIONS IF A SPECIFIC PROJECTION IS PROINF04 C* BEING USED. PROINF05 C* PROINF06 C* PROINF07 C* INPUT: PROINF08 C* -ALL DESCRIBED IN MAIN PROINF09 C* PROINF10 C* OUTPUT: PROINF11 C* -ALL DESCRIBED IN MAIN PROINF12 C* PROINF13 C* PROINF14 C* WRITTEN BY: PROINF15 C* R.R. STEEVES, AUG., 1978 PROINF16 C* PROINF17 C***********************************************************************PROINF18 IMPLICIT REAL*8(A-H,O-Z) PROINF19 DATA UM,UF/' METRES ',' FEET '/ PROINF20 U=UM PROINF21 IF(NUNIT.EQ.1)U=UF PROINF22 PRINT101 PROINF23 101 FORMAT('1',42X,'SPECIFICATIONS OF THE MAP PROJECTION',/,' ',42X, PROINF24 @ 36('-'),///) PROINF25 PRINT102 PROINF26 102 FORMAT(' ',21X,'PROJECTION USED :') PROINF27 IF(NPROJ.GT.3)GOTO10 PROINF28 IF(NPROJ.EQ.1)PRINT103 PROINF29 103 FORMAT('+',40X,'NEW BRUNSWICK DOUBLE STEREOGRAPHIC',//) PROINF30 IF(NPROJ.EQ.2)PRINT104 PROINF31 104 FORMAT('+',40X,'PRINCE EDWARD ISLAND DOUBLE STEREOGRAPHIC',//) PROINF32 CALL RADMS(RP,IDP,IMP,SP) PROINF33 CALL RADMS(RL,IDL,IML,SL) PROINF34 PRINT105,IDP,IMP,SP,IDL,IML,SL,XO,U,YO,U PROINF35 105 FORMAT(' ',21X,'ORIGIN : LATITUDE=',I4,I3,F9.5,' ; LONGITUDE=', PROINF36 @ I5,I3,F9.5,/,' ',31X,'EASTING (X)=',F12.3,A8,' ; NORTHING (Y)= ',PROINF37 @ F12.3,A8,//) PROINF38 PRINT106,RKO PROINF39 106 FORMAT(' ',39X,'SCALE AT THE ORIGIN :',F11.7,//) PROINF40 GOTO20 PROINF41 10 NZ=4 PROINF42 IF(NPROJ.EQ.5)NZ=5 PROINF43 PRINT107,NZ PROINF44 107 FORMAT('+',40X,'NOVA SCOTIA 3-DEGREE TRANSVERSE MERCATOR (ZONE', PROINF45 @ I2,')',//) PROINF46 CALL RADMS(RL,IDL,IML,SL) PROINF47 PRINT108,IDL,IML,SL,XO,U PROINF48 108 FORMAT(' ',32X,'CENTRAL MERIDIAN : LONGITUDE=',I6,I3,F9.5,/,' ', PROINF49 @ 51X,'EASTING (X)=',F12.3,A8,//) PROINF50 PRINT109,RKO PROINF51 109 FORMAT(' ',34X,'SCALE AT THE CENTRAL MERIDIAN :',F11.7,//) PROINF52 20 PRINT110,AA,U,BB,U,X1,U,Y1,U,Z1,U PROINF53 110 FORMAT(//,' ',21X,'REFERENCE ELLIPSOID : CLARK 1866',//,' ', PROINF54 @ 44X,'SEMI-MAJOR AXIS=',F14.3,A8,//,' ',44X,'SEMI-MINOR AXIS=', PROINF55 @ F14.3,A8,//,' ',44X,'TRANSLATION COMPONENTS (FROM GEOCENTRE) USEDPROINF56 @:',//,' ',48X,'XO=',F10.3,A8,/,' ',48X,'YO=',F10.3,A8,//,' ',48X, PROINF57 @ 'ZO=',F10.3,A8,/) PROINF58 RETURN PROINF59 END PROINF60 SUBROUTINE QUMUL(A,RN,NR,I,J,ICA,RES) QUMUL001 C***********************************************************************QUMUL002 C* QUMUL003 C* QUMUL COMPUTES THE VALUE OF THE QUADRATIC FORM DEFINED BY THE SPECIFQUMUL004 C* ROW OF THE DESIGN MATRIX A AND THE CORRESPONDING PART OF THE COVARIAQUMUL005 C* MATRIX (INVERSE OF NORMAL EQUATIONS). USED IN COMPUTING STANDARD DEVQUMUL006 C* TIONS OF ADJUSTED DISTANCES AND AZIMUTHS. QUMUL007 C* QUMUL008 C* QUMUL009 C* INPUT: QUMUL010 C* -ALL DESCRIBED IN MAIN QUMUL011 C* QUMUL012 C* OUTPUT: QUMUL013 C* -ALL DESCRIBED IN MAIN QUMUL014 C* QUMUL015 C* QUMUL016 C* WRITTEN BY: QUMUL017 C* R.R. STEEVES, AUG., 1978 QUMUL018 C* QUMUL019 C***********************************************************************QUMUL020 IMPLICIT REAL*8(A-H,O-Z) QUMUL021 DIMENSION A(4),RN(NR,NR),ICA(4) QUMUL022 RES=0.D0 QUMUL023 DO 1 K=1,4 QUMUL024 DO 1 L=1,4 QUMUL025 IF(ICA(K).EQ.0.OR.ICA(L).EQ.0)GOTO1 QUMUL026 RES=RES+A(K)*A(L)*RN(ICA(K),ICA(L)) QUMUL027 1 CONTINUE QUMUL028 RETURN QUMUL029 END QUMUL030 SUBROUTINE RADMS(RAD,IDEG,IMIN,SEC) RADMS001 C***********************************************************************RADMS002 C* RADMS003 C* THIS ROUTINE CONVERTS AN ANGLE FROM RADIANS TO DEGREES,MINUTES,RADMS004 C* SECONDS. RADMS005 C* RADMS006 C* INPUT: RADMS007 C* RAD - THE ANGLE IN RADIANS. RADMS008 C* RADMS009 C* OUTPUT: RADMS010 C* IDEG - DEGREES RADMS011 C* IMIN - MINUTES RADMS012 C* SEC - SECONDS RADMS013 C* RADMS014 C* RADMS015 C* WRITTEN BY: RADMS016 C* G. BOWIE, JUNE, 1977 RADMS017 C* MODIFIED BY: RADMS018 C* R.R. STEEVES, JUNE, 1978 RADMS019 C* RADMS020 C***********************************************************************RADMS021 IMPLICIT REAL*8(A-H,O-Z) RADMS022 DEG=DABS(RAD)*18.D1/3.141592653589793D0 RADMS023 IDEG=DEG RADMS024 F=(DEG-IDEG)*60.0D0 RADMS025 IMIN=F RADMS026 SEC=(F-IMIN)*60.0D0 RADMS027 IF(DABS(SEC-60.0D0).GT.1D-6) GO TO 1 RADMS028 SEC=0.0D0 RADMS029 IMIN=IMIN+1 RADMS030 IF(IMIN.NE.60) GO TO 1 RADMS031 IMIN=0 RADMS032 IDEG=IDEG+1 RADMS033 1 CONTINUE RADMS034 IDEG=IDEG*DSIGN(1.D0,RAD) RADMS035 IF(IDEG.EQ.0)IMIN=IMIN*DSIGN(1.D0,RAD) RADMS036 IF(IMIN.EQ.0.AND.IDEG.EQ.0)SEC=SEC*DSIGN(1.D0,RAD) RADMS037 RETURN RADMS038 END RADMS039 SUBROUTINE READ(TL,NP2R,NCODE,NF,NP,NSTAN,NPROJ,NUNIT,NELPS, READ0001 @ NDELX,NFAC,NITER,NZERO,NTEST,NMULT,NCOV,CNF,NFR,NP2, READ0002 @ NP3,CPX,NPR,PX,NPXR,ALPH,FAC,CNAM,NSR,AP,NS,X,D,NR,IOB,NOR, READ0003 @ DOB,CIO,NO,ND,N,NCORR,CONVG,CENT,NCENT,NCRIT,NRED1,NRED2,NRED3, READ0004 @ NB,CBH,BH,NBR,NBHR,NCOVB,N1,N2,N3,N4,CERR,NSIMU,NSRES,NPRA,NPRN,READ0005 @NPRW,NPRU,NPRCX,NSQRT,NB2,NB3,NVARF,NDISK,NRCOD,WANGC,WDISC,NABST)READ0006 C***********************************************************************READ0007 C* READ0008 C* READ READS ALL INPUT DATA WHETHER FROM PUNCHED CARDS OR FROM CARD IMREAD0009 C* ON DISK (NOT IMPLEMENTED AS OF THIS PRINTING). READ0010 C* READ0011 C* READ0012 C* INPUT: READ0013 C* -ALL DESCRIBED IN MAIN READ0014 C* READ0015 C* OUTPUT: READ0016 C* -ALL DESCRIBED IN MAIN READ0017 C* READ0018 C* READ0019 C* WRITTEN BY: READ0020 C* R.R. STEEVES, JUNE, 1978 READ0021 C* READ0022 C***********************************************************************READ0023 IMPLICIT REAL*8(A-H,O-Z) READ0024 DIMENSION TL(10),CNF(NFR),NC(37),CPX(NPR),PX(NPXR),FAC(5), READ0025 @ CNAM(NSR), X(NR),D(NR),IOB(NOR,4),DOB(NOR,4),CIO(NOR,3),READ0026 @ AP(NSR,12),CBH(NBR),BH(NBHR),CERR(NSR),SAV(7) READ0027 DIMENSION CENT(4) READ0028 IF(NRCOD.EQ.2)GOTO240 READ0029 READ(5,109,END=1215)(TL(I),I=1,10) READ0030 READ(5,102,ERR=200)(NC(I),I=1,37) READ0031 GOTO201 READ0032 200 PRINT202 READ0033 STOP READ0034 201 DO 1 I=1,37 READ0035 IF(I.EQ.1)GOTO1 READ0036 IF((I.EQ.2.OR.I.EQ.3.OR.I.EQ.4).AND.NC(I).GT.0)GOTO1 READ0037 IF(I.EQ.24)GOTO1 READ0038 IF(NC(I).LE.5.AND.NC(I).GE.0)GOTO1 READ0039 PRINT103,I READ0040 STOP READ0041 1 CONTINUE READ0042 NCODE=NC(1) READ0043 NF=NC(2) READ0044 NP=NC(3) READ0045 NB=NC(4) READ0046 NPROJ=NC(5) READ0047 NUNIT=NC(6) READ0048 NELPS=NC(7) READ0049 NSIMU=NC(8) READ0050 NSTAN=NC(9) READ0051 NFAC=NC(10) READ0052 NZERO=NC(11) READ0053 NTEST=NC(12) READ0054 NSRES=NC(13) READ0055 NCOV=NC(14) READ0056 NCOVB=NC(15) READ0057 NCORR=NC(16) READ0058 NMULT=NC(17) READ0059 NCENT=NC(18) READ0060 NDELX=NC(19) READ0061 NCRIT=NC(20) READ0062 NRED1=NC(21) READ0063 NRED2=NC(22) READ0064 NRED3=NC(23) READ0065 NITER=NC(24) READ0066 NPRA=NC(25) READ0067 NPRN=NC(26) READ0068 NPRW=NC(27) READ0069 NPRU=NC(28) READ0070 NPRCX=NC(29) READ0071 NSQRT=NC(30) READ0072 NVARF=NC(31) READ0073 NMISC=NC(32) READ0074 NABST=NC(33) READ0075 NDISK=NC(34) READ0076 IF(NCODE.NE.1)NCODE=2 READ0077 IF(NCOV.NE.1)NCOV=0 READ0078 IF(NCOVB.NE.1)NCOVB=0 READ0079 IF(NSTAN.GT.2.OR.NSTAN.LT.0)NSTAN=0 READ0080 IF(NZERO.NE.1)NZERO=0 READ0081 IF(NFAC.NE.1)NFAC=0 READ0082 IF(NPROJ.EQ.0)NPROJ=3 READ0083 IF(NUNIT.NE.1)NUNIT=0 READ0084 IF(NELPS.GT.3.OR.NELPS.LT.0)NELPS=0 READ0085 IF(NDELX.NE.1)NDELX=0 READ0086 IF(NMISC.NE.1)NMISC=0 READ0087 IF(NABST.NE.1)NABST=0 READ0088 IF(NITER.EQ.0)NITER=5 READ0089 IF(NITER.LT.0)NITER=0 READ0090 IF(NMULT.NE.1)NMULT=0 READ0091 IF(NRED1.NE.1)NRED1=0 READ0092 IF(NRED2.NE.1)NRED2=0 READ0093 IF(NRED3.NE.1)NRED3=0 READ0094 IF(NCENT.NE.1)NCENT=0 READ0095 IF(NCORR.NE.1)NCORR=0 READ0096 IF(NCRIT.NE.1)NCRIT=0 READ0097 IF(NSIMU.GT.4.OR.NSIMU.LT.0)NSIMU=0 READ0098 IF(NSRES.NE.1)NSRES=0 READ0099 IF(NPRA.NE.1.AND.NPRA.NE.2)NPRA=0 READ0100 IF(NPRN.NE.1.AND.NPRN.NE.2)NPRN=0 READ0101 IF(NPRU.NE.1.AND.NPRU.NE.2)NPRU=0 READ0102 IF(NPRCX.NE.1)NPRCX=0 READ0103 IF(NPRW.NE.1.AND.NPRW.NE.2)NPRW=0 READ0104 IF(NSQRT.NE.1.AND.NSQRT.NE.2)NSQRT=0 READ0105 IF(NVARF.NE.1)NVARF=0 READ0106 IF(NDISK.NE.1)NDISK=0 READ0107 IF(NTEST.LT.0.OR.NTEST.GT.5)NTEST=0 READ0108 DATA FIXD,PXD,BLAHD,CRITR ,BLNK ,FACTD,STATD,OBSERD,SIMUD/ READ0109 @'FIXED ','WEIGHTED','BLAHA ','CRITERIA',' ', READ0110 @'FACTORS ','STATIONS','OBSERVAT','SIMULTAN'/ READ0111 IF(NF.EQ.0)GOTO2 READ0112 READ(5,101,END=217)RCODE READ0113 IF(RCODE.EQ.FIXD)GOTO203 READ0114 PRINT204,RCODE READ0115 STOP READ0116 203 READ(5,101,END=216)(CNF(I),I=1,NF) READ0117 2 NP2=NP*2 READ0118 NP3=NP+2*NP**2 READ0119 NB2=NB*2 READ0120 NB3=NB+2*NB**2 READ0121 IF(NP.EQ.0)GOTO4 READ0122 READ(5,101,END=217)RCODE READ0123 IF(RCODE.EQ.PXD)GOTO205 READ0124 PRINT206,RCODE READ0125 STOP READ0126 205 READ(5,101,END=219)(CPX(I),I=1,NP) READ0127 L1=1 READ0128 DO 41 I=1,NP2 READ0129 L2=L1+NP2-I READ0130 READ(5,104,ERR=207)(PX(J),J=L1,L2) READ0131 GOTO208 READ0132 207 PRINT209 READ0133 STOP READ0134 208 L1=L2+1 READ0135 41 CONTINUE READ0136 4 IF(NB.EQ.0)GOTO3 READ0137 READ(5,101,END=217)RCODE READ0138 IF(RCODE.EQ.BLAHD)GOTO210 READ0139 PRINT211,RCODE READ0140 STOP READ0141 210 READ(5,101,END=221)(CBH(I),I=1,NB) READ0142 L1=1 READ0143 DO 42 I=1,NB2 READ0144 L2=L1+NB2-I READ0145 READ(5,104,ERR=212)(BH(J),J=L1,L2) READ0146 GOTO1213 READ0147 212 PRINT1214 READ0148 STOP READ0149 1213 L1=L2+1 READ0150 42 CONTINUE READ0151 3 READ(5,101,END=217)RCODE READ0152 IF(RCODE.NE.CRITR .AND.(NCRIT.EQ.1.OR.NSTAN.EQ.1.OR.NCENT.EQ.1.OR.READ0153 @NMISC.EQ.1))GOTO215 READ0154 IF(RCODE.EQ.CRITR)READ(5,105,ERR=213)CONVG,ALPH,(CENT(I),I=1,4) READ0155 @,WANGC,WDISC READ0156 IF(RCODE.NE.CRITR)GOTO214 READ0157 GOTO1216 READ0158 215 PRINT1217 READ0159 STOP READ0160 213 PRINT220 READ0161 STOP READ0162 1216 ALPH=DABS(ALPH) READ0163 214 IF(NSTAN.EQ.0)ALPH=95.D0 READ0164 IF(NSTAN.EQ.2)ALPH=39.4D0 READ0165 IF(ALPH.LT.39.4D0.OR.ALPH.GT.99.999D0)ALPH=95.0D0 READ0166 IF(NCRIT.EQ.0)CONVG=1.D-3 READ0167 IF(NCRIT.NE.0.AND.CONVG.LT.1.D-20)CONVG=1.D-3 READ0168 CONVG=DABS(CONVG) READ0169 FAK=1.D0 READ0170 IF(NUNIT.EQ.1)FAK=0.3048D0 READ0171 IF(NMISC.EQ.0)WANGC=36000.D0 READ0172 IF(NMISC.EQ.0)WDISC=100.0D0/FAK READ0173 WANGC=DABS(WANGC) READ0174 WDISC=DABS(WDISC) READ0175 IF(NCENT.EQ.1)GOTO27 READ0176 DO 28 I=1,4 READ0177 28 CENT(I)=0.D0 READ0178 27 CONTINUE READ0179 IF(RCODE.EQ.STATD)GOTO224 READ0180 IF(RCODE.EQ.FACTD)GOTO1221 READ0181 READ(5,101,END=217)RCODE READ0182 IF(RCODE.NE.FACTD.AND.NFAC.EQ.1)GOTO222 READ0183 1221 IF(RCODE.EQ.FACTD)READ(5,105,ERR=223)(FAC(I),I=1,5) READ0184 IF(RCODE.NE.FACTD)GOTO224 READ0185 GOTO225 READ0186 222 PRINT226 READ0187 STOP READ0188 223 PRINT227 READ0189 STOP READ0190 225 IF(NFAC.NE.0)GOTO7 READ0191 224 DO 6 I=1,5 READ0192 6 FAC(I)=1.D0 READ0193 GOTO8 READ0194 7 DO 20 I=1,5 READ0195 IF(I.EQ.2.AND.FAC(I).GE.0.D0)GOTO20 READ0196 IF(FAC(I).LE.0.D0)GOTO21 READ0197 20 CONTINUE READ0198 XX=FAC(2) READ0199 FAC(2)=FAC(3) READ0200 FAC(3)=FAC(4) READ0201 FAC(4)=FAC(5) READ0202 FAC(5)=XX READ0203 GOTO8 READ0204 21 PRINT 108 READ0205 STOP READ0206 8 CONTINUE READ0207 IF(RCODE.EQ.STATD)GOTO16 READ0208 READ(5,101,END=217)RCODE READ0209 IF(RCODE.NE.STATD)GOTO230 READ0210 GOTO16 READ0211 230 PRINT231,RCODE READ0212 STOP READ0213 232 PRINT233 READ0214 STOP READ0215 16 J=1 READ0216 9 READ(5,106,ERR=232)I,CNAM(J),XX,YY,HH,HG,EXI,ETA READ0217 IF(I.LT.0)GOTO10 READ0218 AP(J,1)=XX READ0219 AP(J,2)=YY READ0220 AP(J,3)=HH READ0221 AP(J,4)=HG READ0222 AP(J,5)=EXI READ0223 AP(J,6)=ETA READ0224 J=J+1 READ0225 GOTO9 READ0226 10 NS=J-1 READ0227 IF(NB.EQ.0)GOTO23 READ0228 NPOS=NS READ0229 DO 22 J=1,NB READ0230 DO 24 I=1,NS READ0231 IF(I.GE.NPOS)GOTO22 READ0232 IF(CNAM(I).EQ.CBH(J))GOTO25 READ0233 24 CONTINUE READ0234 GOTO22 READ0235 25 SAV(7)=CNAM(NPOS) READ0236 CNAM(NPOS)=CNAM(I) READ0237 CNAM(I)=SAV(7) READ0238 DO 26 L=1,6 READ0239 SAV(L)=AP(NPOS,L) READ0240 AP(NPOS,L)=AP(I,L) READ0241 26 AP(I,L)=SAV(L) READ0242 NPOS=NPOS-1 READ0243 22 CONTINUE READ0244 23 J=1 READ0245 READ(5,101,END=217)RCODE READ0246 IF(RCODE.EQ.OBSERD)GOTO234 READ0247 PRINT235,RCODE READ0248 STOP READ0249 236 PRINT237 READ0250 STOP READ0251 234 JD=0 READ0252 N1=0 READ0253 N2=0 READ0254 N3=0 READ0255 N4=0 READ0256 11 READ(5,107,ERR=236)K,(X(I),I=1,3),(D(I),I=1,4) READ0257 IF(K.LT.-2)GOTO14 READ0258 IF(K.EQ.-2)JD=JD+1 READ0259 IF(K.EQ.1)N1=N1+1 READ0260 IF(K.EQ.2.OR.K.EQ.-2)N2=N2+1 READ0261 IF(K.EQ.3)N3=N3+1 READ0262 IF(K.EQ.4)N4=N4+1 READ0263 IOB(J,1)=K READ0264 DO 12 I=1,3 READ0265 12 CIO(J,I)=X(I) READ0266 DO 13 I=1,4 READ0267 13 DOB(J,I)=D(I) READ0268 J=J+1 READ0269 GOTO11 READ0270 14 NO=J-1 READ0271 ND=JD READ0272 N=NS*2-NF*2+NZERO-NB*2 READ0273 IF(NRCOD.EQ.1)RETURN READ0274 240 READ(5,101,END=128)RCODE READ0275 IF(RCODE.NE.SIMUD)GOTO242 READ0276 DO 243 I=1,NSR READ0277 243 CERR(I)=BLNK READ0278 J=1 READ0279 DO 244 I=1,1000 READ0280 J1=J+6 READ0281 IF(J1.GT.NSR)J1=NSR READ0282 READ(5,245,END=246)L,(CERR(K),K=J,J1) READ0283 IF(J1.EQ.NSR)GOTO247 READ0284 IF(L.LT.0 )GOTO247 READ0285 J=J1+1 READ0286 244 CONTINUE READ0287 245 FORMAT(I5,5X,7(A8,2X)) READ0288 246 PRINT248 READ0289 STOP READ0290 242 PRINT249,RCODE READ0291 STOP READ0292 1215 PRINT301 READ0293 STOP READ0294 217 PRINT302 READ0295 STOP READ0296 216 PRINT303 READ0297 STOP READ0298 219 PRINT304 READ0299 STOP READ0300 221 PRINT305 READ0301 STOP READ0302 247 RETURN READ0303 128 NRCOD=3 READ0304 101 FORMAT(8(A8,2X)) READ0305 102 FORMAT(I2,3I4,33I2) READ0306 103 FORMAT(' ','*** INPUT ERROR #002 *** CODE # ',I3,' ON SECOND DATAREAD0307 @ CARD IS OUT OF ACCEPTABLE RANGE') READ0308 104 FORMAT(8F10.3) READ0309 105 FORMAT(8F10.3) READ0310 106 FORMAT(I2,A8,2F15.3,4F10.3) READ0311 107 FORMAT(I5,5X,3(A8,2X),4F10.3) READ0312 108 FORMAT(' ','*** INPUT ERROR #020 *** A FACTOR FOR STANDARD DEVIATREAD0313 @IONS OF OBSERVATIONS IS ZERO OR NEGATIVE') READ0314 109 FORMAT(10A8) READ0315 202 FORMAT(' ','***INPUT ERROR #001 *** AN ERROR OCCURRED WHILE ATTEMREAD0316 @PTING TO READ THE CODES CARD',/,' ','PROBABLE CAUSE: MISSING TITLEREAD0317 @ OR CODES CARD OR A NON NUMERIC CHARACTER IS PUNCHED ON THIS CARD'READ0318 @) READ0319 204 FORMAT(' ','*** INPUT ERROR #003 *** EXPECTING TO READ -FIXED- BUREAD0320 @T FOUND -',A8,'-') READ0321 206 FORMAT(' ','*** INPUT ERROR #004 *** EXPECTING TO READ -WEIGHTED-READ0322 @ BUT FOUND -',A8,'-') READ0323 209 FORMAT(' ','*** INPUT ERROR #005 *** AN ERROR OCCURRED WHILE ATTEREAD0324 @MPTING TO READ PX MATRIX',/,' ','PROBABLE CAUSE: INCOMPLETE PX MATREAD0325 @RIX DATA INPUT') READ0326 211 FORMAT(' ','*** INPUT ERROR #006 *** EXPECTING TO READ -BLAHA- BUREAD0327 @T FOUND -',A8,'-') READ0328 220 FORMAT(' ','*** INPUT ERROR #022 *** AN ERROR OCCURRED WHILE ATTEMREAD0329 @PTING TO READ THE SPECIFIC PARAMETERS FOR CONVERGENCE, CONFIDENCE READ0330 @,',/,' ',10X,'CENTERING AND/OR MISCLOSURES PROBABLE CAUSE: IMPROPEREAD0331 @R SEQUENCE OF INPUT DATA') READ0332 226 FORMAT(' ','*** INPUT ERROR #023 *** OPTION TO READ FACTORS FOR OBREAD0333 @SERVATION STANDARD DEVIATIONS WAS SELECTED',/,' ',10X,'BUT DATA CAREAD0334 @RD WITH THESE VALUES WAS NOT FOUND') READ0335 227 FORMAT(' ','*** INPUT ERROR #024 *** AN ERROR OCCURRED WHILE ATTEMREAD0336 @PTING TO READ FACTORS FOR OBSERVATION STANDARD DEVIATIONS',/,' ', READ0337 @10X,'PROBABLE CAUSE: IMPROPER SEQUENCE OF INPUT DATA') READ0338 231 FORMAT(' ','*** INPUT ERROR #025 *** EXPECTING TO READ -STATIONS-READ0339 @ BUT FOUND -',A8,'- PROBABLE CAUSE: IMPROPER SEQUENCE OF INPUT DAREAD0340 @TA') READ0341 233 FORMAT(' ','*** INPUT ERROR #026 *** AN ERROR OCCURRED WHILE ATTEREAD0342 @MPTING TO READ APPROXIMATE COORDINATES',/,' ',10X,'PROBABLE CAUSE:READ0343 @ IMPROPER SEQUENCE IN INPUT DATA') READ0344 235 FORMAT(' ','*** INPUT ERROR #027 *** EXPECTING TO READ -OBSERVAT(READ0345 @IONS)- BUT FOUND -',A8,'- PROBABLE CAUSE: IMPROPER SEQUENCE OF INPREAD0346 @UT DATA') READ0347 237 FORMAT(' ','*** INPUT ERROR #028 *** AN ERROR OCCURRED WHILE ATTEREAD0348 @MPTING TO READ OBSERVATIONS',/,' ',10X,'PROBABLE CAUSE: IMPROPER SREAD0349 @EQUENCE OF INPUT DATA OR FORMAT') READ0350 248 FORMAT(' ','*** INPUT ERROR #029 *** END OF DATA ENCOUNTERED WHILREAD0351 @E READING STATION NAMES FOR SIMULTANEOUS ELLIPSES') READ0352 249 FORMAT(' ','*** INPUT ERROR #030 *** EXPECTING TO READ -SIMULTAN(EREAD0353 @OUS)- BUT FOUND -',A8,'-') READ0354 301 FORMAT(' ','*** INPUT ERROR #037 *** NO INPUT DATA FOUND') READ0355 302 FORMAT(' ','*** INPUT ERROR #038 *** INCOMPLETE INPUT DATA') READ0356 303 FORMAT(' ','*** INPUT ERROR #039 *** END OF INPUT DATA FOUND WHILEREAD0357 @ ATTEMPTING TO READ FIXED STATION NAMES') READ0358 304 FORMAT(' ','*** INPUT ERROR #040 *** END OF INPUT DATA FOUND WHILREAD0359 @E ATTEMPTING TO READ WEIGHTED STATION NAMES') READ0360 305 FORMAT(' ','*** INPUT ERROR #041 *** END OF INPUT DATA FOUND WHILREAD0361 @E ATTEMPTING TO READ BLAHA STATION NAMES') READ0362 1214 FORMAT(' ','*** INPUT ERROR #007 *** AN ERROR OCCURRED WHILE ATTEREAD0363 @MPTING TO READ BLAHA MATRIX',/,' ','PROBABLE CAUSE: INCOMPLETE BLAREAD0364 @HA MATRIX DATA INPUT') READ0365 1217 FORMAT(' ','*** INPUT ERROR #021 *** SPECIFIC OPTIONS WERE REQUESTREAD0366 @ED FOR CONVERGENCE, CONFIDENCE, CENTERING OR MISCLOSURES',/,' ', READ0367 @10X,'BUT DATA CARD WITH THESE VALUES WAS NOT FOUND') READ0368 RETURN READ0369 END READ0370 SUBROUTINE REANG1(ANG,I,J,K,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) REANG101 C***********************************************************************REANG102 C* REANG103 C* REANG1 REDUCES ANGLE OBSERVATIONS FROM THE TERAIN TO THE ELLIPSOID. REANG104 C* REANG105 C* REANG106 C* INPUT: REANG107 C* ANG- ANGLE OBSERVATION ON TERRAIN (RADIANS) REANG108 C* OTHERS- DESCRIBED IN MAIN REANG109 C* REANG110 C* OUTPUT: REANG111 C* ANG- REDUCED ANGLE OBSERVATION (ON ELLIPSOID) (RADIANS) REANG112 C* C1,C2,C3- CORRECTIONS TO OBSERVED ANGLE (RADIANS) REANG113 C* (PRINTED IF REQUESTED) REANG114 C* REANG115 C* REANG116 C* WRITTEN BY: REANG117 C* R.R. STEEVES, JULY, 1978 REANG118 C* REANG119 C***********************************************************************REANG120 IMPLICIT REAL*8(A-H,O-Z) REANG121 REAL*8 MIJ,MIK,NIJ,NIK REANG122 DIMENSION AP(NSR,12) REANG123 PI=3.141592653589793D0 REANG124 RO=3600.D0*180.D0/PI REANG125 HJ=AP(J,3)+AP(J,4) REANG126 HK=AP(K,3)+AP(K,4) REANG127 MIJ=(AP(I,8)+AP(J,8))/2.D0 REANG128 MIK=(AP(I,8)+AP(K,8))/2.D0 REANG129 NIJ=(AP(I,7)+AP(J,7))/2.D0 REANG130 NIK=(AP(I,7)+AP(K,7))/2.D0 REANG131 CALL ASAZ(AP,I,J,AIJ,NSR) REANG132 CALL ASAZ(AP,I,K,AIK,NSR) REANG133 SAIJ=DSIN(AIJ) REANG134 CAIJ=DCOS(AIJ) REANG135 SAIK=DSIN(AIK) REANG136 CAIK=DCOS(AIK) REANG137 CPJ=DCOS(AP(J,9)) REANG138 CPK=DCOS(AP(K,9)) REANG139 PIJ=(AP(I,9)+AP(J,9))/2.D0 REANG140 CPIJ=DCOS(PIJ) REANG141 PIK=(AP(I,9)+AP(K,9))/2.D0 REANG142 CPIK=DCOS(PIK) REANG143 SIJ=(AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2 REANG144 SIK=(AP(K,1)-AP(I,1))**2+(AP(K,2)-AP(I,2))**2 REANG145 ESQ=(AA**2-BB**2)/AA**2 REANG146 C2=HJ/MIJ*ESQ*SAIJ*CAIJ*CPJ**2+HK/MIK*ESQ*SAIK*CAIK*CPK**2 REANG147 C3=-ESQ*SIJ*CPIJ**2*DSIN(2.D0*AIJ)/12.D0/NIJ**2 REANG148 @ -ESQ*SIK*CPIK**2*DSIN(2.D0*AIK)/12.D0/NIK**2 REANG149 CALL GVERT(AP,NSR,AA,BB,XO,YO,ZO,VIJ,I,J) REANG150 CALL GVERT(AP,NSR,AA,BB,XO,YO,ZO,VIK,I,K) REANG151 C1=0.D0 REANG152 IF(VIJ.EQ.0.D0)GOTO1 REANG153 COT=1.D0/DTAN(VIJ) REANG154 C1=C1-(AP(I,5)*SAIJ/RO-AP(I,6)*CAIJ/RO)*COT REANG155 1 IF(VIK.EQ.0.D0)GOTO2 REANG156 COT=1.D0/DTAN(VIK) REANG157 C1=C1-(AP(I,5)*SAIK/RO-AP(I,6)*CAIK/RO)*COT REANG158 2 ANG=ANG+C1+C2+C3 REANG159 RETURN REANG160 END REANG161 SUBROUTINE REDAZ1(AZ,I,J,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3,C4) REDAZ101 C***********************************************************************REDAZ102 C* REDAZ103 C* REDAZ1 REDUCES AZIMUTH OBSERVATIONS FROM THE TERRAIN TO THE ELLIPSOIREDAZ104 C* REDAZ105 C* REDAZ106 C* INPUT REDAZ107 C* AZ- OBSERVED DIRECTION ON THE TERRAIN (RADIANS) REDAZ108 C* OTHERS- DESCRIBED IN MAIN. REDAZ109 C* REDAZ110 C* OUTPUT: REDAZ111 C* AZ- REDUCED AZIMUTH (ON THE ELLIPSOID) (RADIANS) REDAZ112 C* C1,C2,C3,C4- CORRECTIONS TO OBSERVED AZIMUTH (RADIANS) REDAZ113 C* REDAZ114 C* REDAZ115 C* WRITTEN BY: REDAZ116 C* R.R. STEEVES, JUNE, 1978 REDAZ117 C* REDAZ118 C***********************************************************************REDAZ119 IMPLICIT REAL*8(A-H,O-Z) REDAZ120 REAL*8 MIJ,NIJ REDAZ121 DIMENSION AP(NSR,12) REDAZ122 PI=3.141592653589793D0 REDAZ123 RO=3600.D0*180.D0/PI REDAZ124 ESQ=(AA**2-BB**2)/AA**2 REDAZ125 C4=-AP(I,6)/RO*DTAN(AP(I,9)) REDAZ126 CALL GVERT(AP,NSR,AA,BB,XO,YO,ZO,V,I,J) REDAZ127 AZ=AZ+C4 REDAZ128 IF(V.EQ.0.D0)GOTO1 REDAZ129 COT=1.D0/DTAN(V) REDAZ130 C1=-(AP(I,5)/RO*DSIN(AZ)-AP(I,6)/RO*DCOS(AZ))*COT REDAZ131 1 IF(V.EQ.0.D0)C1=0.D0 REDAZ132 AZ=AZ+C1 REDAZ133 MIJ=(AP(I,8)+AP(J,8))/2.D0 REDAZ134 NIJ=(AP(I,7)+AP(J,7))/2.D0 REDAZ135 SIJ=(AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2 REDAZ136 HJ=AP(J,3)+AP(J,4) REDAZ137 CPJ=DCOS(AP(J,9)) REDAZ138 CPIJ=DCOS((AP(I,9)+AP(J,9))/2.D0) REDAZ139 C2=HJ/MIJ*ESQ*DSIN(AZ)*DCOS(AZ)*CPJ**2 REDAZ140 AZ=AZ+C2 REDAZ141 C3=-SIJ/NIJ**2/12.D0*ESQ*CPIJ**2*DSIN(2.D0*AZ) REDAZ142 AZ=AZ+C3 REDAZ143 RETURN REDAZ144 END REDAZ145 SUBROUTINE REDIR1(DIJ,I,J,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) REDIR101 C***********************************************************************REDIR102 C* REDIR103 C* REDIR1 REDUCES DIRECTION OBSERVATIONS FROM THE TERRAIN TO THE ELLIPSREDIR104 C* REDIR105 C* REDIR106 C* INPUT: REDIR107 C* DIJ- OBSERVED DIRECTION ON THE TERRAIN (RADIANS) REDIR108 C* OTHERS- DESCRIBED IN MAIN REDIR109 C* REDIR110 C* OUTPUT: REDIR111 C* DIJ- REDUCED DIRECTION (ON THE ELLIPSOID) (RADIANS) REDIR112 C* C1,C2,C3- CORRECTIONS TO OBSERVED DIRECTION (RADIANS) REDIR113 C* REDIR114 C* REDIR115 C* WRITTEN BY: REDIR116 C* R.R. STEEVES, JUNE, 1978 REDIR117 C* REDIR118 C***********************************************************************REDIR119 IMPLICIT REAL*8(A-H,O-Z) REDIR120 REAL*8 MIJ,NIJ REDIR121 DIMENSION AP(NSR,12) REDIR122 PI=3.141592653589793D0 REDIR123 RO=3600.D0*180.D0/PI REDIR124 HJ=AP(J,3)+AP(J,4) REDIR125 MIJ=(AP(I,8)+AP(J,8))/2.D0 REDIR126 NIJ=(AP(I,7)+AP(J,7))/2.D0 REDIR127 CALL ASAZ(AP,I,J,GAZ,NSR) REDIR128 SA=DSIN(GAZ) REDIR129 CA=DCOS(GAZ) REDIR130 PIJ=(AP(I,9)+AP(J,9))/2.D0 REDIR131 CPIJ=DCOS(PIJ) REDIR132 CPJ=DCOS(AP(J,9)) REDIR133 SIJ=(AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2 REDIR134 ESQ=(AA**2-BB**2)/AA**2 REDIR135 C2=HJ/MIJ*ESQ*SA*CA*CPJ**2 REDIR136 C3=-ESQ*SIJ*CPIJ**2*DSIN(2.D0*GAZ)/12.D0/NIJ**2 REDIR137 CALL GVERT(AP,NSR,AA,BB,XO,YO,ZO,VERT,I,J) REDIR138 C1=0.D0 REDIR139 IF(VERT.EQ.0.D0)GOTO1 REDIR140 COT=1.D0/DTAN(VERT) REDIR141 C1=C1-(AP(I,5)*SA/RO-AP(I,6)*CA/RO)*COT REDIR142 1 DIJ=DIJ+C1+C2+C3 REDIR143 RETURN REDIR144 END REDIR145 SUBROUTINE REDIS1(DIS,I,J,AA,BB,AP,NSR,C5,C6,CNAM) REDIS101 C***********************************************************************REDIS102 C* REDIS103 C* REDIS1 REDUCES OBSERVED SPATIAL DISTANCES (CORRECTED FOR REFRACTION)REDIS104 C* FROM THE TERRAIN TO THE REFERENCE ELLIPSOID. REDIS105 C* REDIS106 C* REDIS107 C* INPUT: REDIS108 C* DIS- OBSERVED SPATIAL DISTANCE REDIS109 C* I- STATION (SEQUENCE NUMBER) FROM WHICH DISTANCE WAS REDIS110 C* OBSERVED REDIS111 C* J- STATION (SEQUENCE NUMBER) TO WHICH DISTANCE WAS OBSERVEDREDIS112 C* OTHERS- DESCRIBED IN MAIN REDIS113 C* REDIS114 C* OUTPUT: REDIS115 C* DIS- REDUCED DISTANCE (ON ELLIPSOID) REDIS116 C* C5- CORRECTION FROM SPATIAL TO CHORD REDIS117 C* C6- CORRECTION FROM CHORD TO ELLIPSOID REDIS118 C* REDIS119 C* REDIS120 C* WRITTEN BY: REDIS121 C* R.R. STEEVES, MAY, 1978 REDIS122 C* REDIS123 C***********************************************************************REDIS124 IMPLICIT REAL*8(A-H,O-Z) REDIS125 REAL*8 MI,MJ,NI,NJ REDIS126 DIMENSION AP(NSR,12),CNAM(NSR) REDIS127 RALPH(MI,NI,AIJ)=MI*NI/(MI*DSIN(AIJ)**2+NI*DCOS(AIJ)**2) REDIS128 CALL ASAZ(AP,I,J,AIJ,NSR) REDIS129 CALL ASAZ(AP,J,I,AJI,NSR) REDIS130 MI=AP(I,8) REDIS131 NI=AP(I,7) REDIS132 MJ=AP(J,8) REDIS133 NJ=AP(J,7) REDIS134 RIJ=RALPH(MI,NI,AIJ) REDIS135 RJI=RALPH(MJ,NJ,AJI) REDIS136 R=(RIJ+RJI)/2.D0 REDIS137 HI=AP(I,3)+AP(I,4) REDIS138 HJ=AP(J,3)+AP(J,4) REDIS139 DH=HJ-HI REDIS140 IF(DIS.LT.DABS(DH))PRINT101,CNAM(I),CNAM(J) REDIS141 IF(DIS.LT.DABS(DH))STOP REDIS142 101 FORMAT(' ','*** INPUT ERROR #015 *** OBSERVED SLOPE DISTANCE BETWEREDIS143 @EN STATIONS ',A8,' AND ',A8,/,' ',' IS LESS THAN THE HEIGHT ', REDIS144 @ 'DIFFERENCE BETWEEN THE TWO STATIONS') REDIS145 RLO=DSQRT((DIS**2-DH**2)/(1.D0+HI/R)/(1.D0+HJ/R)) REDIS146 C5=RLO-DIS REDIS147 DIS=2.D0*R*DARSIN(RLO/2.D0/R) REDIS148 C6=DIS-RLO REDIS149 RETURN REDIS150 END REDIS151 SUBROUTINE RESID(IOB,NO,A,X,W,WX,ICA,N,V,NV,ND,NP,ICP,SPX, RESID001 @ NOR,NR,NP2R,CNAM,NSR,ZER,DOBR,IDF,S0) RESID002 C***********************************************************************RESID003 C* RESID004 C* RESID COMPUTES RESIDUALS FOR ALL OBSERVATIONS. ALSO COMPUTES THE RESID005 C* QUADRATIC FORM OF WEIGHTED RESIDUALS RESID006 C* RESID007 C* RESID008 C* INPUT: RESID009 C* -ALL DESCRIBED IN MAIN RESID010 C* RESID011 C* OUTPUT: RESID012 C* S0- VALUE OF THE QUADRATIC FORM OF WEIGHTED RESIDUALS RESID013 C* V- RESIDUALS RESID014 C* RESID015 C* RESID016 C* WRITTEN BY: RESID017 C* R.R. STEEVES, RESID018 C* RESID019 C***********************************************************************RESID020 IMPLICIT REAL*8(A-H,O-Z) RESID021 DIMENSION IOB(NOR,4),A(NOR,6),X(NR),W(NO),WX(NP2R), RESID022 @ ICA(NOR,6),V(NV),ICP(NR),SPX(NP2R,NP2R),CNAM(NSR),DOBR(NOR,4) RESID023 S0=0.D0 RESID024 I=1 RESID025 10 IG=IOB(I,1) RESID026 GOTO(1,3,1,1),IG RESID027 C COMPUTE DISTANCE, ANGLE AND AZIMUTH RESIDUALS RESID028 1 W1=0.D0 RESID029 DO 2 J=1,6 RESID030 IF(ICA(I,J).EQ.0)GOTO2 RESID031 W1=W1-A(I,J)*X(ICA(I,J)) RESID032 2 CONTINUE RESID033 V(I)=W(I)+W1 RESID034 S0=S0+V(I)**2/DOBR(I,1)**2 RESID035 I=I+1 RESID036 GOTO24 RESID037 C COMPUTE DIRECTION RESIDUALS RESID038 3 II=I+20 RESID039 DO 4 J=I,II RESID040 M=J RESID041 IF(IOB(J,1).EQ.-2)GOTO5 RESID042 4 CONTINUE RESID043 5 NUM=M-I+1 RESID044 SUM=0.D0 RESID045 DO 7 J=I,M RESID046 SUM=SUM+1.D0/DOBR(J,1)**2 RESID047 W1=0.D0 RESID048 DO 6 K=1,4 RESID049 IF(ICA(J,K).EQ.0)GOTO6 RESID050 W1=W1-A(J,K)*X(ICA(J,K)) RESID051 6 CONTINUE RESID052 V(J)=W(J)+W1 RESID053 7 CONTINUE RESID054 SUM1=0.D0 RESID055 DO 8 J=I,M RESID056 W1=0.D0 RESID057 DO 15 K=1,4 RESID058 IF(ICA(J,K).EQ.0)GOTO15 RESID059 W1=W1+A(J,K)*X(ICA(J,K)) RESID060 15 CONTINUE RESID061 W1=(W1-W(J))/DOBR(J,1)**2 RESID062 SUM1=SUM1+W1 RESID063 8 CONTINUE RESID064 SUM2=SUM1/SUM RESID065 DO 9 J=I,M RESID066 9 V(J)=V(J)+SUM2 RESID067 DO 13 J=I,M RESID068 13 S0=S0+V(J)**2/DOBR(J,1)**2 RESID069 I=I+NUM RESID070 24 IF(I.LE.NO)GOTO10 RESID071 IF(NP.EQ.0)GOTO14 RESID072 NP2=NP*2 RESID073 DO 11 J=1,NP2 RESID074 IF(ICP(J).EQ.0)GOTO20 RESID075 V(NO+J)=WX(J)-X(ICP(J)) RESID076 GOTO11 RESID077 20 V(NO+J)=WX(J) RESID078 11 CONTINUE RESID079 DO 12 J=1,NP2 RESID080 DO 12 K=1,NP2 RESID081 12 S0=S0+V(NO+J)*V(NO+K)*SPX(J,K) RESID082 14 RETURN RESID083 END RESID084 SUBROUTINE RESREJ(V,NV,DOB,IOB,NOR,NO,NTEST,ALPH,IDF,CNAM,NSR, RESREJ01 @ NUMREJ) RESREJ02 C***********************************************************************RESREJ03 C* RESREJ04 C* RESREJ TESTS STANDARDIZED RESIDUALS FOR REJECTION AND PRINTS INFORMARESREJ05 C* CORRESPONDING TO RESIDUALS FLAGGED FOR REJECTION RESREJ06 C* RESREJ07 C* RESREJ08 C* INPUT: RESREJ09 C* -ALL DESCRIBED IN MAIN RESREJ10 C* RESREJ11 C* OUTPUT: RESREJ12 C* -ALL DESCRIBED IN MAIN RESREJ13 C* RESREJ14 C* RESREJ15 C* WRITTEN BY: RESREJ16 C* R.R. STEEVES, AUG., 1978 RESREJ17 C* RESREJ18 C***********************************************************************RESREJ19 IMPLICIT REAL*8(A-H,O-Z) RESREJ20 REAL*4 SRALPH,SNGL,FLOAT,SCR,SDF RESREJ21 DIMENSION DOB(NOR,4),V(NV),IOB(NOR,4),CNAM(NSR) RESREJ22 NUMREJ=0 RESREJ23 SAVAL=ALPH RESREJ24 IF(ALPH.LT.90.D0)ALPH=95.D0 RESREJ25 PRINT101,ALPH RESREJ26 IF(NTEST.EQ.0)PRINT102 RESREJ27 IF(NTEST.EQ.1)PRINT103 RESREJ28 IF(NTEST.EQ.2)PRINT104 RESREJ29 IF(NTEST.EQ.3)PRINT105 RESREJ30 IF(NTEST.EQ.4)PRINT106 RESREJ31 IF(NTEST.EQ.5)PRINT107 RESREJ32 RALPH=ALPH/100.D0 RESREJ33 RALPH1=1.D0-RALPH RESREJ34 IF(NTEST.EQ.0.OR.NTEST.EQ.2.OR.NTEST.EQ.4)RALPH1=RALPH1/NO RESREJ35 IF(NTEST.EQ.2.OR.NTEST.EQ.3)SRALPH=SNGL(1.D0-RALPH1/2.D0) RESREJ36 IF(NTEST.EQ.4.OR.NTEST.EQ.5)SRALPH=SNGL(RALPH1) RESREJ37 IF(NTEST.EQ.0.OR.NTEST.EQ.1)CALL TAURE(1,IDF,RALPH1,CR) RESREJ38 IF(NTEST.LT.2)GOTO1 RESREJ39 SDF=FLOAT(IDF) RESREJ40 IF(NTEST.EQ.4.OR.NTEST.EQ.5)CALL MDSTI(SRALPH,SDF,SCR,IER) RESREJ41 IF(NTEST.EQ.2.OR.NTEST.EQ.3)CALL MDNRIS(SRALPH,SCR,IER) RESREJ42 CR=DBLE(SCR) RESREJ43 1 PRINT108,CR RESREJ44 PRINT109 RESREJ45 PRINT110 RESREJ46 I=1 RESREJ47 2 IG=IOB(I,1) RESREJ48 IA=IOB(I,2) RESREJ49 IF=IOB(I,3) RESREJ50 IT=IOB(I,4) RESREJ51 GOTO(3,4,3,3),IG RESREJ52 3 CRPT=CR*DOB(I,1) RESREJ53 IF(DABS(V(I)).LT.CRPT)GOTO7 RESREJ54 NUMREJ=NUMREJ+1 RESREJ55 IF(IG.EQ.1)PRINT111,I,CNAM(IA),CNAM(IA),CNAM(IF) RESREJ56 IF(IG.EQ.3)PRINT112,I,CNAM(IA),CNAM(IF),CNAM(IT) RESREJ57 IF(IG.EQ.4)PRINT113,I,CNAM(IA),CNAM(IA),CNAM(IF) RESREJ58 PRINT114,V(I),DOB(I,1),CRPT RESREJ59 7 I=I+1 RESREJ60 GOTO10 RESREJ61 4 J=1 RESREJ62 5 CRPT=CR*DOB(I,1) RESREJ63 IA=IOB(I,2) RESREJ64 IF=IOB(I,3) RESREJ65 IF(DABS(V(I)).LT.CRPT)GOTO6 RESREJ66 NUMREJ=NUMREJ+1 RESREJ67 PRINT115,I,J,CNAM(IA),CNAM(IA),CNAM(IF),V(I),DOB(I,1),CRPT RESREJ68 6 J=J+1 RESREJ69 I=I+1 RESREJ70 IF(IOB(I-1,1).NE.-2)GOTO5 RESREJ71 10 IF(I.LE.NO)GOTO2 RESREJ72 IPC=(NUMREJ*100)/NO RESREJ73 PRINT116,NUMREJ,IPC RESREJ74 IF(NUMREJ.GT.0)PRINT117 RESREJ75 DO 11 I=1,NO RESREJ76 11 V(I)=V(I)/DOB(I,1) RESREJ77 ALPH=SAVAL RESREJ78 101 FORMAT('1',22X,'SUMMARY OF REJECTION OF RESIDUALS AT THE', RESREJ79 @ F7.3,' % CONFIDENCE LEVEL',/,' ',22X,66('-'),/) RESREJ80 102 FORMAT(' ',42X,'(TAU MAX CRITERION USED)',/) RESREJ81 103 FORMAT(' ',41X,'(TAU NON-MAX CRITERION USED)',/) RESREJ82 104 FORMAT(' ',41X,'(NORMAL MAX CRITERION USED)',/) RESREJ83 105 FORMAT(' ',39X,'(NORMAL NON-MAX CRITERION USED)',/) RESREJ84 106 FORMAT(' ',39X,'(STUDENTS-T MAX CRITERION USED)',/) RESREJ85 107 FORMAT(' ',37X,'(STUDENTS-T NON-MAX CRITERION USED)',/) RESREJ86 108 FORMAT(' ',24X,'COMPUTED FACTOR FOR STANDARD DEVIATION OF RESIDUALRESREJ87 @ =',F9.4,//) RESREJ88 109 FORMAT(' ',45X,'REJECTED RESIDUALS:',/,' ',45X,19('-'),/) RESREJ89 110 FORMAT(' ',9X,57X,'STD.DEV',/,' ',9X,'OBSERVATION',3X,'AT',8X, RESREJ90 @'FROM',6X,'TO',9X,'RESIDUAL',4X,'RESIDUAL',3X,'CRITICAL POINT',/) RESREJ91 111 FORMAT(' ',I7,2X,'DISTANCE',6X,3(A8,2X)) RESREJ92 112 FORMAT(' ',I7,2X,'ANGLE',9X,3(A8,2X)) RESREJ93 113 FORMAT(' ',I7,2X,'AZIMUTH',7X,3(A8,2X)) RESREJ94 114 FORMAT('+',52X,F8.4,F12.4,F13.4,11X,'REJECT',/) RESREJ95 115 FORMAT(' ',I7,2X,'DIRECTION',I3,3(2X,A8),1X,F8.4,F12.4,F13.4,11X, RESREJ96 @ 'REJECT',/) RESREJ97 116 FORMAT(///,' ',17X,I5,' RESIDUALS (',I3,' % OF THE OBSERVATIONS) WRESREJ98 @ERE FLAGGED FOR REJECTION',//) RESREJ99 117 FORMAT(' ',6X,'**** WARNING **** OBSERVATIONS CORRESPONDING TO REJRESRE100 @ECTED RESIDUALS HAVE BEEN USED IN THIS ADJUSTMENT') RESRE101 RETURN RESRE102 END RESRE103 SUBROUTINE SDAAZM(I,J,IC,NSR,RN,NR,SIJ,AP,STD) SDAAZM01 C***********************************************************************SDAAZM02 C* SDAAZM03 C* SDAAZM COMPUTES THE STANDARD DEVIATIONS OF THE ADJUSTED AZIMUTH FROMSDAAZM04 C* STATION I TO STATION J (SEQUENCE NUMBERS) SDAAZM05 C* SDAAZM06 C* SDAAZM07 C* INPUT: SDAAZM08 C* -ALL DESCRIBED IN MAIN SDAAZM09 C* SDAAZM10 C* OUTPUT: SDAAZM11 C* -ALL DESCRIBED IN MAIN SDAAZM12 C* SDAAZM13 C* SDAAZM14 C* WRITTEN BY: SDAAZM15 C* R.R. STEEVES, AUG., 1978 SDAAZM16 C* SDAAZM17 C***********************************************************************SDAAZM18 IMPLICIT REAL*8(A-H,O-Z) SDAAZM19 DIMENSION IC(NSR,2),RN(NR,NR),A(4),AP(NSR,12),ICA(4) SDAAZM20 RO=3600.D0/3.141592653589793D0*180.D0 SDAAZM21 A(1)=(AP(I,2)-AP(J,2))/SIJ**2*RO SDAAZM22 A(2)=(AP(J,1)-AP(I,1))/SIJ**2*RO SDAAZM23 A(3)=-A(1) SDAAZM24 A(4)=-A(2) SDAAZM25 ICA(1)=IC(I,1) SDAAZM26 ICA(2)=IC(I,2) SDAAZM27 ICA(3)=IC(J,1) SDAAZM28 ICA(4)=IC(J,2) SDAAZM29 CALL QUMUL(A,RN,NR,I,J,ICA,RES) SDAAZM30 STD=DSQRT(RES) SDAAZM31 RETURN SDAAZM32 END SDAAZM33 SUBROUTINE SDADIS(I,J,IC,NSR,RN,NR,SIJ,AP,STD) SDADIS01 C***********************************************************************SDADIS02 C* SDADIS03 C* SDADIS COMPUTES THE STANDARD DEVIATION OF THE ADJUSTED DISTANCE FROMSDADIS04 C* STATION I TO STATION J (SEQUENCE NUMBERS) SDADIS05 C* SDADIS06 C* SDADIS07 C* INPUT: SDADIS08 C* -ALL DESCRIBED IN MAIN SDADIS09 C* SDADIS10 C* OUTPUT: SDADIS11 C* -ALL DESCRIBED IN MAIN SDADIS12 C* SDADIS13 C* SDADIS14 C* WRITTEN BY: SDADIS15 C* R.R. STEEVES, AUG., 1978 SDADIS16 C* SDADIS17 C***********************************************************************SDADIS18 IMPLICIT REAL*8(A-H,O-Z) SDADIS19 DIMENSION IC(NSR,2),RN(NR,NR),A(4),AP(NSR,12),ICA(4) SDADIS20 A(1)=(AP(I,1)-AP(J,1))/SIJ SDADIS21 A(2)=(AP(I,2)-AP(J,2))/SIJ SDADIS22 A(3)=-A(1) SDADIS23 A(4)=-A(2) SDADIS24 ICA(1)=IC(I,1) SDADIS25 ICA(2)=IC(I,2) SDADIS26 ICA(3)=IC(J,1) SDADIS27 ICA(4)=IC(J,2) SDADIS28 CALL QUMUL(A,RN,NR,I,J,ICA,RES) SDADIS29 STD=DSQRT(RES) SDADIS30 RETURN SDADIS31 END SDADIS32 SUBROUTINE SIGST(IOB,I,IVEC,NSS,NOR,NO) SIGST001 C***********************************************************************SIGST002 C* SIGST003 C* SIGST DETERMINES WHICH STATIONS ARE SIGHTED FROM STATION I SIGST004 C* SIGST005 C* SIGST006 C* INPUT: SIGST007 C* -ALL DESCRIBED IN MAIN SIGST008 C* SIGST009 C* OUTPUT: SIGST010 C* -ALL DESCRIBED IN MAIN SIGST011 C* SIGST012 C* SIGST013 C* WRITTEN BY: SIGST014 C* R.R. STEEVES, AUG., 1978 SIGST015 C* SIGST016 C***********************************************************************SIGST017 IMPLICIT REAL*8(A-H,O-Z) SIGST018 DIMENSION IOB(NOR,4),IVEC(50) SIGST019 J=1 SIGST020 DO 1 K=1,NO SIGST021 IA=IOB(K,2) SIGST022 IF=IOB(K,3) SIGST023 IT=IOB(K,4) SIGST024 IF(I.NE.IA.AND.I.NE.IF.AND.I.NE.IT)GOTO1 SIGST025 IG=IABS(IOB(K,1)) SIGST026 GOTO(2,2,3,2),IG SIGST027 2 IF(I.EQ.IA)L=IF SIGST028 IF(I.EQ.IF)L=IA SIGST029 4 IF(J.EQ.1)GOTO5 SIGST030 M=J-1 SIGST031 DO 6 N=1,M SIGST032 IF(L.EQ.IVEC(N))GOTO1 SIGST033 6 CONTINUE SIGST034 5 IVEC(J)=L SIGST035 J=J+1 SIGST036 GOTO1 SIGST037 3 DO 7 N=2,4 SIGST038 IF(IOB(K,N).EQ.I)GOTO1 SIGST039 IF(J.EQ.1)GOTO15 SIGST040 M=J-1 SIGST041 DO 16 NN=1,M SIGST042 IF(IOB(K,N).EQ.IVEC(NN))GOTO1 SIGST043 16 CONTINUE SIGST044 15 IVEC(J)=IOB(K,N) SIGST045 J=J+1 SIGST046 7 CONTINUE SIGST047 1 CONTINUE SIGST048 NSS=J-1 SIGST049 RETURN SIGST050 END SIGST051 SUBROUTINE SINO(RN,NR,I,N,IC,CNAM,NS,NSR) SINO0001 C***********************************************************************SINO0002 C* SINO0003 C* SINO ZEROS ROWS AND COLUMNS IN THE NORMAL EQUATIONS WHEN A SINGULARISINO0004 C* IS ENCOUNTERED IN THE COMPUTATION OF THE CHOLESKI SQUARE ROOT. ALSOSINO0005 C* PRINTS INFORMATION ON THE LOCATION OF THE SINGULARITIES IF ANY. SINO0006 C* SINO0007 C* SINO0008 C* INPUT: SINO0009 C* I- POSITION (INTERSECTION OF THE ROW AND COLUMN TO BE ZEROESINO0010 C* OF THE SINGULARITY. SINO0011 C* OTHERS- DESCRIBED IN MAIN SINO0012 C* SINO0013 C* SINO0014 C* WRITTEN BY: SINO0015 C* R.R. STEEVES, JULY, 1978 SINO0016 C* SINO0017 C***********************************************************************SINO0018 IMPLICIT REAL*8(A-H,O-Z) SINO0019 DIMENSION RN(NR,NR),IC(NSR,2),CNAM(NSR) SINO0020 DO 1 J=1,I SINO0021 RN(J,I)=0.D0 SINO0022 1 CONTINUE SINO0023 DO 2 J=I,N SINO0024 RN(I,J)=0.D0 SINO0025 2 CONTINUE SINO0026 DO 3 J=1,NS SINO0027 DO 3 K=1,2 SINO0028 IF(I.EQ.IC(J,K))GOTO4 SINO0029 3 CONTINUE SINO0030 PRINT101,I,I SINO0031 PRINT102 SINO0032 GOTO5 SINO0033 4 PRINT101,I,I SINO0034 IF(K.EQ.1)PRINT103,CNAM(J) SINO0035 IF(K.EQ.2)PRINT104,CNAM(J) SINO0036 101 FORMAT(' ','*** ERROR #010 *** SINGULARITY ENCOUNTERED IN NORMAL ESINO0037 @QUATIONS',/,' ','IN POSITION','(',I4,',',I4,')') SINO0038 102 FORMAT('+',24X,'ZERO ERROR',/) SINO0039 103 FORMAT('+',24X,'X-COORDINATE OF STATION',1X,A8,/) SINO0040 104 FORMAT('+',24X,'Y-COORDINATE OF STATION',1X,A8,/) SINO0041 5 RETURN SINO0042 END SINO0043 SUBROUTINE SORT(VCLS,NOR,NRES) SORT0001 C***********************************************************************SORT0002 C* SORT0003 C* SORT REARRANGES THE ELEMENTS OF VCLS IN ORDER OF INCREASING MAGNITUDSORT0004 C* FOR USE IN SEPARATING THESE ELEMENTS INTO CLASS INTERVALS FOR THE CHSORT0005 C* SQUARE GOODNESS OF FIT TEST AND HISTOGRAM PLOT. SORT0006 C* SORT0007 C* SORT0008 C* INPUT: SORT0009 C* NRES- NUMBER OF RESIDUALS IN VCLS SORT0010 C* SORT0011 C* SORT0012 C* WRITTEN BY: SORT0013 C* LAURIE PACH, JULY, 1978 SORT0014 C* SORT0015 C***********************************************************************SORT0016 IMPLICIT REAL*8(A-H,O-Z) SORT0017 DIMENSION VCLS(NOR) SORT0018 NOUT=NRES*(NRES+1)/2 SORT0019 NINS=NRES-1 SORT0020 DO 12 J=1,NOUT SORT0021 IFLG=0 SORT0022 DO 11 I=1,NINS SORT0023 IF(VCLS(I).GT.VCLS(I+1))GOTO10 SORT0024 GOTO11 SORT0025 10 IFLG=1 SORT0026 TEMP=VCLS(I) SORT0027 VCLS(I)=VCLS(I+1) SORT0028 VCLS(I+1)=TEMP SORT0029 11 CONTINUE SORT0030 IF(IFLG.EQ.0)GOTO13 SORT0031 12 CONTINUE SORT0032 13 RETURN SORT0033 END SORT0034 SUBROUTINE SPTEL(CHI,SLAM,C1,C2,E,PHI,ELAM) SPTEL001 C***********************************************************************SPTEL002 C* SPTEL003 C* THIS ROUTINE TRANSFORMS SPHERICAL (CONFORMAL SPHERE) COORDINATESPTEL004 C* CHI,SLAM TO ELLIPSOIDAL COORDINATES PHI,ELAM USING A NEWTON- SPTEL005 C* RAPHSON ITERATION. SPTEL006 C* SPTEL007 C* SPTEL008 C* INPUT: SPTEL009 C* CHI - SPHERICAL LATITUDE OF THE POINT, IN RADIANS. SPTEL010 C* SLAM - SPHERICAL LONGITUDE OF THE POINT, IN RADIANS. SPTEL011 C* E - FIRST ECCENTRICITY OF THE ELLIPSOID (COMPUTED IN SPTEL012 C* SUBROUTINE STGINL). SPTEL013 C* C1 - CONSTANT COMPUTED IN STGINL. SPTEL014 C* C2 - CONSTANT COMPUTED IN STGINL. SPTEL015 C* SPTEL016 C* OUTPUT: SPTEL017 C* PHI - ELLIPSOIDAL LATITUDE OF THE POINT, IN RADIANS. SPTEL018 C* ELAM - ELLIPSOIDAL LONGITUDE OF THE POINT, IN RADIANS. SPTEL019 C* SPTEL020 C* SPTEL021 C* WRITTEN BY: SPTEL022 C* R.R. STEEVES, JULY, 1977 SPTEL023 C* SPTEL024 C***********************************************************************SPTEL025 IMPLICIT REAL*8(A-H,O-Z) SPTEL026 PI4=3.141592653589793D0/4.D0 SPTEL027 PHI=CHI SPTEL028 1 ESP=E*DSIN(PHI) SPTEL029 P2=((1.D0-ESP)/(1.D0+ESP))**(E/2.D0) SPTEL030 P1=DTAN(PI4+PHI/2.D0) SPTEL031 F=C2*(P1*P2)**C1-DTAN(PI4+CHI/2.D0) SPTEL032 FP=C1*C2*(P1*P2)**(C1-1.D0)*P2*(1.D0/2.D0/DCOS(PI4+PHI/2.D0)**2-E*SPTEL033 1 *2*DCOS (PHI)/(1.D0-ESP**2)*DTAN(PI4+PHI/2.D0)) SPTEL034 DPHI=F/FP SPTEL035 PHI=PHI-DPHI SPTEL036 IF(DABS(DPHI).GT.1.D-11) GO TO 1 SPTEL037 ELAM=SLAM/C1 SPTEL038 RETURN SPTEL039 END SPTEL040 SUBROUTINE SPTPL(CHI,SLAM,XO,YO,KO,CHIO,SLAMO,R,X,Y,K,C) SPTPL001 C***********************************************************************SPTPL002 C* SPTPL003 C* THIS ROUTINE TRANSFORMS SPHERICAL COORDINATES CHI,SLAM TO SPTPL004 C* STEREOGRAPHIC GRID COORDINATES X,Y. SPTPL005 C* SPTPL006 C* SPTPL007 C* INPUT: SPTPL008 C* CHI - SPHERICAL LATITUDE OF THE POINT, IN RADIANS. SPTPL009 C* SLAM - SPHERICAL LONGITUDE OF THE POINT, IN RADIANS. SPTPL010 C* (POSITIVE EAST OF GREENWICH) SPTPL011 C* XO - FALSE EASTING OF THE ORIGIN OF THE PROJECTION SPTPL012 C* YO - FALSE NORTHING OF THE ORIGIN OF THE PROJECTION. SPTPL013 C* KO - POINT SCALE FACTOR AT THE ORIGIN OF THE PROJECTION. SPTPL014 C* (FROM SPHERE TO PLANE) SPTPL015 C* CHIO - SPHERICAL LATITUDE OF THE ORIGIN, IN RADIANS. SPTPL016 C* SLAMO - SPHERICAL LONGITUDE OF THE ORIGIN, IN RADIANS. SPTPL017 C* R - RADIUS OF THE SPHERE. SPTPL018 C* SPTPL019 C* OUTPUT: SPTPL020 C* X - STEREOGRAPHIC GRID EASTING. SPTPL021 C* Y - STEREOGRAPHIC GRID NORTHING. SPTPL022 C* K - POINT SCALE FACTOR AT THE POINT, GOING FROM THE SPHERSPTPL023 C* TO THE PLANE. SPTPL024 C* C - MERIDIAN CONVERGENCE AT THE POINT, IN RADIANS. SPTPL025 C* SPTPL026 C* SPTPL027 C* WRITTEN BY: SPTPL028 C* R.R. STEEVES, JULY, 1977 SPTPL029 C* SPTPL030 C***********************************************************************SPTPL031 IMPLICIT REAL*8(A-H,O-Z) SPTPL032 REAL*8 KO,K SPTPL033 RO=2.D0*KO*R SPTPL034 DLAM=SLAM-SLAMO SPTPL035 CC=DCOS(CHI) SPTPL036 SC=DSIN(CHI) SPTPL037 CCO=DCOS(CHIO) SPTPL038 SCO=DSIN(CHIO) SPTPL039 SDL=DSIN(DLAM) SPTPL040 CDL=DCOS(DLAM) SPTPL041 DEN=1.D0+SCO*SC+CCO*CC*CDL SPTPL042 X=XO+RO*CC*SDL/DEN SPTPL043 Y=YO+RO*(SC*CCO-CC*SCO*CDL)/DEN SPTPL044 K=2.D0*KO/DEN SPTPL045 C=DATAN((SDL*(SC+SCO))/(CC*CCO+(1.D0+SC*SCO)*CDL)) SPTPL046 RETURN SPTPL047 END SPTPL048 SUBROUTINE STATS(ITER,NITER,N1,N2,N3,N4,NP,NB,NZERO,ND,N,IDF,S0, STATS001 @ NVARF,NUMREJ,NCODE,V,NV,DOB,NOR,NO,IOB,ALPH,VCLS,VARF) STATS002 C***********************************************************************STATS003 C* STATS004 C* STATS PERFORMS AND PRINTS A STATISTICS SUMMARY OF THE COMPUTATION OFSTATS005 C* THE DEGREES OF FREEDOM, THE ESTIMATED VARIANCE FACTOR, THE CHI-SQUARSTATS006 C* TEST ON THE VARIANCE FACTOR AND CONTROLS GOODNESS OF FIT TESTS AND TSTATS007 C* CORRESPONDING PLOTS. STATS008 C* STATS009 C* STATS010 C* INPUT: STATS011 C* -ALL DESCRIBED IN MAIN STATS012 C* STATS013 C* STATS014 C* WRITTEN BY: STATS015 C* R.R. STEEVES, AUG., 1978 STATS016 C* STATS017 C***********************************************************************STATS018 IMPLICIT REAL*8(A-H,O-Z) STATS019 REAL*4 SALPH,SDF,FLOAT,SNGL,X STATS020 DIMENSION V(NV),DOB(NOR,4),IOB(NOR,4),VCLS(NOR) STATS021 PRINT101 STATS022 IF(NCODE.EQ.2)PRINT102,ITER STATS023 IF(NCODE.EQ.2)PRINT103,NITER STATS024 IF(NCODE.EQ.2.AND.ITER.EQ.NITER)PRINT104 STATS025 IF(NCODE.EQ.2.AND.ITER.NE.NITER)PRINT112 STATS026 NP2=NP*2 STATS027 NN=N-NZERO STATS028 NS1=N1+N2+N3+N4+NP2 STATS029 NS2=NZERO+ND+NN STATS030 PRINT105,N1,NZERO,N2,ND,N3,N4,NP2,NN,NS1,NS2 STATS031 PRINT106,IDF STATS032 IF(IDF.EQ.0.OR.NCODE.EQ.1)GOTO9 STATS033 VARF=S0/DFLOAT(IDF) STATS034 PRINT107,VARF STATS035 PRINT108 STATS036 IF(NVARF.EQ.0)PRINT114 STATS037 IF(NVARF.EQ.1)PRINT115 STATS038 ALP2=(1.D0-ALPH/100.D0)/2.D0 STATS039 SALPH=SNGL(1.D0-ALP2) STATS040 SDF=FLOAT(IDF) STATS041 CALL MDCHI(SALPH,SDF,X,IER) STATS042 RLOW=S0/DBLE(X) STATS043 SALPH=SNGL(ALP2) STATS044 CALL MDCHI(SALPH,SDF,X,IER) STATS045 HIGH=S0/DBLE(X) STATS046 PRINT109,RLOW,HIGH STATS047 IF(RLOW.GT.1.D0.OR.HIGH.LT.1.D0)PRINT110,ALPH STATS048 IF(RLOW.LE.1.D0.AND.HIGH.GE.1.D0)PRINT111,ALPH STATS049 IF(IDF.GT.0)PRINT113,NUMREJ STATS050 IF(N1.GE.9)CALL GODFIT(V,NOR,VCLS,1,NO,IOB,NVARF,ALPH,NV) STATS051 IF(N2+N3+N4.GE.9)CALL GODFIT(V,NOR,VCLS,2,NO,IOB,NVARF,ALPH,NV) STATS052 IF(N1.GT.0.AND.(N2+N3+N4+N1).GE.9)CALL GODFIT(V,NOR,VCLS,3,NO,IOB,STATS053 @ NVARF,ALPH,NV) STATS054 101 FORMAT('1',46X,'STATISTICS SUMMARY',/,' ',46X,18('-'),//) STATS055 102 FORMAT(' ',28X,'NUMBER OF ITERATIONS REQUIRED FOR CONVERGENCE -->'STATS056 @ ,I5) STATS057 103 FORMAT(' ',28X,'MAXIMUM NUMBER OF ITERATIONS ALLOWED ----------->'STATS058 @ ,I5) STATS059 104 FORMAT(' ',1X,'**** WARNING **** MAXIMUM NUMBER OF ITERATIONS WASSTATS060 @ REACHED. THE CONVERGENCE CRITERION MAY NOT BE SATISFIED.',//) STATS061 105 FORMAT(' ',29X,'NUMBER OF OBSERVATIONS',5X,'|',' NUMBER OF UNKNOWNSTATS062 @S',/,' ',29X,27('-'),'|',24('-'),/,' ',56X,'|',/,' ',29X,'DISTANCESTATS063 @S',I13,5X,'|',' ZERO ERROR',I13,/,' ',29X,'DIRECTIONS',I12,5X,'|',STATS064 @' ORIENTATION',I12,/,' ',29X,'ANGLES',I16,5X,'|',/,' ',29X,'AZIMUTSTATS065 @HS',I14,5X,'|',/,' ',29X,'COORDINATES',I11,5X,'|',' COORDINATES', STATS066 @I12,/,' ',46X,5('-'),25X,5('-'),/,' ',29X,'TOTALS',I16,I30,//) STATS067 106 FORMAT(' ',34X,'THE NUMBER OF DEGREES OF FREEDOM IS ',I6,////) STATS068 107 FORMAT(' ',34X,'ESTIMATED VARIANCE FACTOR= ',F15.6,//) STATS069 108 FORMAT(' ',36X,'CHI-SQUARE TEST ON THE VARIANCE FACTOR',/,' ',36X,STATS070 @ 38('-'),/) STATS071 109 FORMAT(' ',28X,F12.6,6X,'< 1.000000 <',3X,F12.6,5X,'?',/) STATS072 110 FORMAT(' ',24X,'TEST ON VARIANCE FACTOR AT THE ',F7.3,' % CONFIDENSTATS073 @CE LEVEL FAILS',/,' ',82X,5('-'),/) STATS074 111 FORMAT(' ',24X,'TEST ON VARIANCE FACTOR AT THE ',F7.3,' % CONFIDENSTATS075 @CE LEVEL PASSES',/,' ',82X,6('-'),/) STATS076 112 FORMAT(/) STATS077 113 FORMAT(' ',32X,'(',I4,' RESIDUALS WERE FLAGGED FOR REJECTION )',STATS078 @/) STATS079 114 FORMAT(' ',42X,'(VARIANCE FACTOR UNKNOWN)',/) STATS080 115 FORMAT(' ',43X,'(VARIANCE FACTOR KNOWN)',/) STATS081 9 RETURN STATS082 END STATS083 SUBROUTINE STGINL (PHIO,ELAMO,A,B,R,C1,C2,E,CHIO,SLAMO) STGINL01 C***********************************************************************STGINL02 C* STGINL03 C* THIS ROUTINE COMPUTES THE INITIAL VALUES TO BE USED IN STGINL04 C* THE STEREOGRAPHIC DOUBLE PROJECTION SUBROUTINES. STGINL05 C* STGINL06 C* STGINL07 C* INPUT: STGINL08 C* PHIO - ELLIPSOID LATITUDE OF THE ORIGIN OF THE PROJECTIONSTGINL09 C* IN RADIANS. STGINL10 C* ELAMO - ELLIPSOIDAL LNGITUDE (POSITIVE EAST OF GREENWICH)STGINL11 C* OF THE ORIGIN OF THE PROJECTION IN RADIANS. STGINL12 C* A,B - SEMI-MAJOR AND SEMI-MINOR AXES OF THE REFERENCE STGINL13 C* ELLIPSOID, IN METRES. STGINL14 C* STGINL15 C* OUTPUT: STGINL16 C* R - RADIUS OF THE CONFORMAL SPHERE, IN METRES. STGINL17 C* C1 - CONSTANT USED IN THE TRANSFORMATIONS BETWEEN THE STGINL18 C* ELLIPSOID AND THE CONFORMAL SPHERE. STGINL19 C* C2 - CONSTANT FOR THE SAME USE AS C1. STGINL20 C* E - FIRST ECCENTRICITY OF THE ELLIPSOID. STGINL21 C* CHIO - SPHERICAL LATITUDE OF THE ORIGIN OF THE PROJECTIONSTGINL22 C* IN RADIANS. STGINL23 C* SLAMO - SPERICAL LONGITUDE OF THE ORIGIN OF THE PROJECTIOSTGINL24 C* IN RADIANS. STGINL25 C* STGINL26 C* STGINL27 C* WRITTEN BY: STGINL28 C* R.R. STEEVES, JULY, 1977 STGINL29 C* STGINL30 C***********************************************************************STGINL31 IMPLICIT REAL*8(A-H,O-Z) STGINL32 E2=(A*A-B*B)/(A*A) STGINL33 E=DSQRT(E2) STGINL34 SP=DSIN(PHIO) STGINL35 R=A*DSQRT(1.D0-E2)/(1.D0-E2*SP**2) STGINL36 C1=DSQRT(1.D0+E2 /(1.D0-E2)*DCOS(PHIO)**4) STGINL37 CHIO=DARSIN(SP/C1) STGINL38 SLAMO=C1*ELAMO STGINL39 PI=3.141592653589793D0 STGINL40 C2=DTAN(PI/4.D0+CHIO/2.D0)/(DTAN(PI/4.D0+PHIO/2.D0)*((1.D0-E*SP)/ STGINL41 1 (1.D0+E*SP))**(E/2.D0))**C1 STGINL42 RETURN STGINL43 END STGINL44 SUBROUTINE TAURE(NT,NU,ALPH,CRTAU) TAURE001 C***********************************************************************TAURE002 C* TAURE003 C* TAURE COMPUTES THE CRITICAL VALUE FOR REJECTION OF STANDARDIZED TAURE004 C* RESIDUALS WITH CONTROL OF TYPE I ERROR. TAURE005 C* TAURE006 C* TAURE007 C* INPUT: TAURE008 C* NT- NUMBER OF OBSERVATIONS TAURE009 C* NU- DEGREES OF FREEDOM TAURE010 C* ALPH- DESIRED PROBABILITY OF TYPE I ERROR TAURE011 C* TAURE012 C* OUTPUT: TAURE013 C* CRTAU- CRITICAL VALUE (TAU-MAX) TAURE014 C* TAURE015 C* TAURE016 C* REFERENCE: TAURE017 C* A.J. POPE (1976)- THE STATISTTAURE018 C* OF RESIDUALS AND THE DETECTIOTAURE019 C* OF OUTLIERS; U.S. DEPT OR COMTAURE020 C* NOAA TECHNICAL REPORT TAURE021 C* NO. 65 NGS1. TAURE022 C* TAURE023 C***********************************************************************TAURE024 IMPLICIT REAL*8(A-H,O-Z) TAURE025 DATA PI/ 3.1415926535898 / TAURE026 PD = 2. /PI TAURE027 S = 1. TAURE028 WNU = NU TAURE029 U = WNU -1. TAURE030 IF( U.EQ.0. ) GO TO 72 TAURE031 IF ( ALPH.EQ.0. ) GO TO 72 TAURE032 IF ( ALPH.LT.1. ) GO TO 10 TAURE033 CRTAU = 0. TAURE034 C TAURE035 RETURN TAURE036 C TAURE037 10 Q = NT TAURE038 IF ( ALPH.GT.0.5 ) GO TO 19 TAURE039 AA = ALPH / Q TAURE040 DELT = AA TAURE041 DO 18 I = 1,100 TAURE042 XI = I TAURE043 DELT = DELT * ALPH * (( XI*Q - 1.)/(( XI+1.)*Q)) TAURE044 IF ( DELT.LT.1.D-14 ) GO TO 20 TAURE045 18 AA = AA + DELT TAURE046 19 AA = 1. - (1.-ALPH)**(1./Q) TAURE047 20 P = 1. - AA TAURE048 IF(U.EQ.1. ) GO TO 71 TAURE049 F = 1.3862943611199 - 2.*DLOG(AA) TAURE050 G = DSQRT(F) TAURE051 X = G - (2.515517 + 0.802853*G + 0.010328*F) TAURE052 $ / (1. + 1.432788*G + F*(0.189269 + 0.001308*G)) TAURE053 Y = X*X TAURE054 A = X*(1. + Y)/4. TAURE055 B = X*(3. + Y*(16. + 5.*Y))/96. TAURE056 C = X*(-15. + Y*(17. + Y*(19. + 3.*Y)))/384. TAURE057 E = X*(-945. + Y*(-1920. + Y*(1482. + Y*(776. + 79.*Y))))/92160. TAURE058 V = 1./U TAURE059 T = X + V*(A + V*(B + V*(C + E*V))) TAURE060 S = T/DSQRT(U + T*T) TAURE061 UM = U - 1. TAURE062 DELL = 1. TAURE063 DO 70 M = 1,50 TAURE064 H = 1. - S*S TAURE065 R = 0.0 TAURE066 IF ( DMOD(U,2.D0).EQ.0.0 ) GO TO 49 TAURE067 DD = DSQRT(H) TAURE068 N = 0.5*UM TAURE069 DO 45 I = 1,N TAURE070 Z = 2*I TAURE071 R = R + DD TAURE072 D = DD TAURE073 45 DD = DD * H * (Z/(Z+1.)) TAURE074 R = PD*(R*S + DARSIN(S)) TAURE075 D = PD*D*UM TAURE076 GO TO 61 TAURE077 49 DD = 1. TAURE078 N = 0.5*U TAURE079 DO 55 I = 1,N TAURE080 Z = 2*I TAURE081 R = R + DD TAURE082 D = DD TAURE083 55 DD = DD*H*((Z-1.)/Z) TAURE084 R = R*S TAURE085 D = D*UM TAURE086 61 CONTINUE TAURE087 DEL = (P-R)/D TAURE088 IF( DABS( DEL/DELL ) .GT.0.5) GO TO 72 TAURE089 DELL = DEL TAURE090 S = S + DEL TAURE091 IF( DABS(DEL) .LT. 1.D-8 ) GO TO 72 TAURE092 70 CONTINUE TAURE093 GO TO 72 TAURE094 71 S =DSIN(P/PD) TAURE095 72 CRTAU = S*DSQRT(WNU) TAURE096 RETURN TAURE097 END TAURE098 SUBROUTINE TKSTER(I,J,AP,NSR,R1,XO,YO,RKO,TT,S) TKSTER01 C***********************************************************************TKSTER02 C* TKSTER03 C* TKSTER COMPUTES THE ARC TO CHORD CORRECTION AND LINE SCALE OF LINE ITKSTER04 C* TO J (SEQUENCE NUMBERS) FOR THE DOUBLE STEREOGRAPHIC MAP PROJECTION.TKSTER05 C* TKSTER06 C* TKSTER07 C* INPUT: TKSTER08 C* I,J- SEQUENCE NUMBERS OF STATIONS FROM AND TO TKSTER09 C* AP,NSR- DESCRIBED IN MAIN TKSTER10 C* R1- RADIUS OF CONFORMAL SPHERE TKSTER11 C* XO,YO- COORDINATES OF ORIGIN OF PROJECTION TKSTER12 C* RKO- POINT SCALE AT THE ORIGIN TKSTER13 C* TKSTER14 C* OUTPUT: TKSTER15 C* TT- ARC TO CHORD CORRECTION I TO J TKSTER16 C* S- LINE SCALE I TO J TKSTER17 C* TKSTER18 C* TKSTER19 C* WRITTEN BY: TKSTER20 C* R.R. STEEVES, JULY, 1978 TKSTER21 C* TKSTER22 C***********************************************************************TKSTER23 IMPLICIT REAL*8(A-H,O-Z) TKSTER24 DIMENSION AP(NSR,12) TKSTER25 X1=AP(I,1)-XO TKSTER26 Y1=AP(I,2)-YO TKSTER27 X2=AP(J,1)-XO TKSTER28 Y2=AP(J,2)-YO TKSTER29 TT=DATAN2(X1*Y2-X2*Y1,X1*X2+Y1*Y2+(RKO*R1*2.D0)**2) TKSTER30 RKI=AP(I,11) TKSTER31 RKJ=AP(J,11) TKSTER32 YM=(Y1+Y2)/2.0D0 TKSTER33 XM=(X1+X2)/2.0D0 TKSTER34 RKM=RKO+(XM**2+YM**2)/4.D0/RKO/R1**2 TKSTER35 S=1.D0/((1.D0/RKI+4.D0/RKM+1.D0/RKJ)/6.D0) TKSTER36 RETURN TKSTER37 END TKSTER38 SUBROUTINE TKTM(I,J,AP,NSR,RKO,AA,BB,XO,TT,S) TKTM0001 C***********************************************************************TKTM0002 C* TKTM0003 C* TKTM COMPUTES THE ARC TO CHORD CORRECTION AND THE LINE SCALE FOR THETKTM0004 C* LINE I TO J, FOR THE TRANSVERSE MERCATOR PROJECTION. TKTM0005 C* TKTM0006 C* TKTM0007 C* INPUT: TKTM0008 C* I- SEQUENCE NUMBER OF STATION FROM TKTM0009 C* J- SEQUENCE NUMBER OF STATION TO TKTM0010 C* AP,NSR- DESCRIBED IN MAIN TKTM0011 C* RKO- SCALE FACTOR AT THE CENTRAL MERIDIAN TKTM0012 C* AA,BB- SEMI MAJOR AND SEMI MINOR AXES OF THE REFERENCE ELLIPSIOTKTM0013 C* X0- FALSE EASTING OF THE CENTRAL MERIDIAN TKTM0014 C* TKTM0015 C* TKTM0016 C* OUTPUT: TKTM0017 C* TT- ARC TO CHORD CORRECTION IN RADIANS TKTM0018 C* S- LINE SCALE TKTM0019 C* TKTM0020 C* TKTM0021 C* WRITTEN BY: TKTM0022 C* R.R. STEEVES, JUNE, 1978 TKTM0023 C* TKTM0024 C***********************************************************************TKTM0025 IMPLICIT REAL*8(A-H,O-Z) TKTM0026 DIMENSION AP(NSR,12) TKTM0027 PHI=(AP(I,9)+AP(J,9))/2.D0 TKTM0028 ESQ=(AA**2-BB**2)/AA**2 TKTM0029 R2=AA**2*(1.D0-ESQ)/(1.D0-ESQ*DSIN(PHI)**2)**2 TKTM0030 X1=AP(I,1)-XO TKTM0031 X2=AP(J,1)-XO TKTM0032 XU2=X1**2+X1*X2+X2**2 TKTM0033 S=RKO*(1.D0+XU2/6.D0/R2*(1.D0+XU2/36.D0/R2)) TKTM0034 Y1=AP(I,2) TKTM0035 Y2=AP(J,2) TKTM0036 TT=(Y2-Y1)*(X2+2.D0*X1)/6.D0/R2*(1.D0-(2.D0*X1+X2)**2/27.D0/R2) TKTM0037 RETURN TKTM0038 END TKTM0039 SUBROUTINE TMSFMC(PHI,DLAM,SFO,A,B,SF,C) TMSFMC01 C***********************************************************************TMSFMC02 C* TMSFMC03 C* THIS ROUTINE COMPUTES THE POINT SCALE FACTOR AND MERIDIAN TMSFMC04 C* CONVERGENCE (FOR A POINT DEFINED BY PHI,DLAM) FOR A TRANSVERSE TMSFMC05 C* MERCATOR PROJECTION DEFINED BY THE SCALE FACTOR SFO AT THE TMSFMC06 C* CENTRAL MERIDIAN. TMSFMC07 C* TMSFMC08 C* TMSFMC09 C* INPUT: TMSFMC10 C* PHI - ELLIPSOIDAL LATITUDE OF THE POINT, IN RADIANS. TMSFMC11 C* DLAM - ELLIPSOIDAL LONITUDE OF THE POINT MINUS THE TMSFMC12 C* ELLIPSOIDAL LONGITUDE OF THE CENTRAL MERIDIAN OF TMSFMC13 C* PROJECTION, (LONGITUDE POSITIVE EAST), IN RADIANS.TMSFMC14 C* SFO - SCALE AT THE CENTRAL MERIDIAN. TMSFMC15 C* A,B - SEMI-MAJOR AND SEMI-MINOR AXES OF THE REFERENCE TMSFMC16 C* ELLIPSOID RESPECTIVELY, IN METRES. TMSFMC17 C* TMSFMC18 C* OUTPUT: TMSFMC19 C* SF - POINT SCALE AT THE POINT. TMSFMC20 C* C - MERIDIAN CONVERGENCE AT THE POINT, IN RADIANS. TMSFMC21 C* TMSFMC22 C* TMSFMC23 C* WRITTEN BY: TMSFMC24 C* R.R. STEEVES, AUG., 1977 TMSFMC25 C* TMSFMC26 C***********************************************************************TMSFMC27 IMPLICIT REAL*8(A-Z) TMSFMC28 CP=DCOS(PHI) TMSFMC29 T=DTAN(PHI) TMSFMC30 ETA=DSQRT((A*A-B*B)/(B*B)*CP**2) TMSFMC31 C=DLAM*DSIN(PHI)*(1.D0+DLAM**2*CP**2/3.D0*(1.D0+3.D0*ETA**2+2.D0* TMSFMC32 1 ETA**4)+DLAM**4*CP**4/15.D0*(2.D0-T**2)) TMSFMC33 SF=1.D0+DLAM**2*CP**2/2.D0*(1.D0+ETA**2)+DLAM**4*CP**4/24.D0*(5.D0TMSFMC34 1 -4.D0*T**2) TMSFMC35 SF=SF*SFO TMSFMC36 RETURN TMSFMC37 END TMSFMC38 SUBROUTINE TMXYPL(X,Y,A,B,SF,XO,CMRAD,PHI,OLAM) TMXYPL01 C***********************************************************************TMXYPL02 C* TMXYPL03 C* SUBROUTINE TMXYPL COMPUTES THE GEOGRAPHIC COORDINATES- LATITUDETMXYPL04 C* AND LONGITUDE - GIVEN THE X,Y COORDINATES OF THE TRANSVERSE TMXYPL05 C* MERCATOR PROJECTION. THE EQUATIONS USED TO COMPUTE THE LONGITUDE TMXYPL06 C* AND LATITUDE ARE FROM THOMAS (1952). SUBROUTINE FPLAT IS USED TMXYPL07 C* TO COMPUTE THE FOOT-POINT LATITUDE. TMXYPL08 C* TMXYPL09 C* TMXYPL10 C* INPUT; TMXYPL11 C* X -EASTING COORDINATE OF THE TRANSVERSE MERCATOR TMXYPL12 C* PROJECTION. TMXYPL13 C* Y -NORTHING COORDINATE OF THE TRANSVERSE MERCATOR TMXYPL14 C* PROJECTION. TMXYPL15 C* A -SEMI-MAJOR AXES OF THE REFERENCE ELLIPSOID. TMXYPL16 C* B -SEMI-MINOR AXES OF THE REFERENCE ELLIPSOID. TMXYPL17 C* SF - SCALE OF THE CENTRAL MERIDIAN. TMXYPL18 C* XO - FALSE EASTING OF THE CENTRAL MERIDIAN. TMXYPL19 C* CMRAD - THE CENTRAL MERIDIAN,IN RADIANS. TMXYPL20 C* TMXYPL21 C* OUTPUT: TMXYPL22 C* PHI -LATITUDE OF THE POINT IN RADIANS TMXYPL23 C* OLAM-LONGITUDE OF THE POINT IN RADIANS TMXYPL24 C* TMXYPL25 C* TMXYPL26 C* WRITTEN BY: TMXYPL27 C* R.R. STEEVES, MAY, 1977 TMXYPL28 C* TMXYPL29 C***********************************************************************TMXYPL30 IMPLICIT REAL*8(A-H,O-Z) TMXYPL31 X=(X-XO)/SF TMXYPL32 Y=Y/SF TMXYPL33 E=DSQRT((A**2-B**2)/A**2) TMXYPL34 CALL FPLAT(A,B,Y,PHI1) TMXYPL35 T=DTAN(PHI1) TMXYPL36 SP=DSIN(PHI1) TMXYPL37 CP=DCOS(PHI1) TMXYPL38 ETA=DSQRT((A**2-B**2)/B**2*CP**2) TMXYPL39 DN=A/DSQRT(1.0D0-E**2*SP**2) TMXYPL40 DM=A*(1.0D0-E**2)/DSQRT((1.0D0-E**2*SP**2)**3) TMXYPL41 PHI=PHI1-T*X**2/2.0D0/DM/DN+T*X**4/24.0D0/DM/DN**3*(5.0D0+3.0D0* TMXYPL42 1 T**2+ETA**2-4.0D0*ETA**4-9.0D0*ETA**2*T**2)-T*X**6/720.0D0/DM/ TMXYPL43 2 DN**5*(61.0D0+90.0D0*T**2+46.0D0*ETA**2+45.0D0*T**4-252.0D0*T**TMXYPL44 3 2*ETA**2-3.0D0*ETA**4+100.0D0*ETA**6-66.0D0*T**2*ETA**4-90.0D0 TMXYPL45 4 *T**4*ETA**2+88.0D0*ETA**8+225.0D0*T**4*ETA**4+84.0D0*T**2* TMXYPL46 5 ETA**6-192.0D0*T**2*ETA**8) TMXYPL47 PHI=PHI+T*X**8/40320.0D0/DM/DN**7*(1385.0D0+3633.0D0*T**2+4095.0D0TMXYPL48 1 *T**4+1575.0D0*T**6) TMXYPL49 DLAM=(X/DN-(X/DN)**3/6.0D0*(1.0D0+2.0D0*T**2+ETA**2)+(X/DN)**5/ TMXYPL50 1 120.0D0*(5.0D0+6.0D0*ETA**2+28.0D0*T**2-3.0D0*ETA**4+8.0D0*T**2TMXYPL51 2 *ETA**2+24.0D0*T**4-4.0D0*ETA**6+4.0D0*T**2*ETA**4+24.0D0*T**2*TMXYPL52 3 ETA**6)-(X/DN)**7/5040.0D0*(61.0D0+662.0D0*T**2+1320.0D0*T**4+ TMXYPL53 4 720.0D0*T**6))/CP TMXYPL54 OLAM=CMRAD+DLAM TMXYPL55 X=X*SF+XO TMXYPL56 Y=Y*SF TMXYPL57 RETURN TMXYPL58 END TMXYPL59 SUBROUTINE TOELPS(IOB,DOB,DOBR,NOR,AA,BB,XO,YO,ZO,AP,NSR,NCORR,NO,TOELPS01 @ CNAM,NRED3) TOELPS02 C***********************************************************************TOELPS03 C* TOELPS04 C* TOELPS COMPUTES CORRECTIONS AND MAKES REDUCTIONS TO OBSERVATIONS FROTOELPS05 C* THE TERRAIN TO THE ELLIPSOID. TOELPS06 C* TOELPS07 C* TOELPS08 C* INPUT: TOELPS09 C* -ALL DESCRIBED IN MAIN TOELPS10 C* TOELPS11 C* TOELPS12 C* WRITTEN BY: TOELPS13 C* R.R. STEEVES, JUNE, 1978 TOELPS14 C* TOELPS15 C***********************************************************************TOELPS16 IMPLICIT REAL*8(A-H,O-Z) TOELPS17 DIMENSION IOB(NOR,4),DOB(NOR,4),DOBR(NOR,4),AP(NSR,12),CNAM(NSR) TOELPS18 IF(NCORR.EQ.1)PRINT 101 TOELPS19 IF(NCORR.EQ.1)PRINT 102 TOELPS20 PI=3.141592653589793D0 TOELPS21 RO=3600.D0*180.D0/PI TOELPS22 I=1 TOELPS23 J=1 TOELPS24 1 ID=IOB(I,1) TOELPS25 IA=IOB(I,2) TOELPS26 IF=IOB(I,3) TOELPS27 IT=IOB(I,4) TOELPS28 GOTO(10,20,30,40),ID TOELPS29 C REDUCE DISTANCES FROM TERRAIN TO ELLIPSOID TOELPS30 10 CALL REDIS1(DOB(I,3),IA,IF,AA,BB,AP,NSR,C5,C6,CNAM) TOELPS31 IF(NCORR.EQ.1)PRINT 103,CNAM(IA),CNAM(IA),CNAM(IF),DOBR(I,3),C5, TOELPS32 @C6,DOB(I,3) TOELPS33 I=I+1 TOELPS34 GOTO50 TOELPS35 C REDUCE DIRECTIONS FROM TERRAIN TO ELLIPSOID TOELPS36 20 IA=IOB(I,2) TOELPS37 IF=IOB(I,3) TOELPS38 IDEG=DOB(I,2) TOELPS39 IMIN=DOB(I,3) TOELPS40 CALL DMSRAD(IDEG,IMIN,DOB(I,4),R) TOELPS41 CALL REDIR1(R,IA,IF,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) TOELPS42 IF(J.EQ.1)SR=C1+C2+C3 TOELPS43 C1=C1*RO TOELPS44 C2=C2*RO TOELPS45 C3=C3*RO TOELPS46 IF(J.NE.1)GOTO21 TOELPS47 IF(NCORR.EQ.1)PRINT 104,J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN, TOELPS48 @ DOB(I,4),C1,C2,C3,IDEG,IMIN,DOB(I,4) TOELPS49 GOTO22 TOELPS50 21 R=R-SR TOELPS51 IF(R.LT.0.D0)R=R+2.D0*PI TOELPS52 CALL RADMS(R,IDE,IMI,SEC) TOELPS53 IF(NCORR.EQ.1)PRINT 104,J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN, TOELPS54 @ DOB(I,4),C1,C2,C3,IDE,IMI,SEC TOELPS55 DOB(I,2)=IDE TOELPS56 DOB(I,3)=IMI TOELPS57 DOB(I,4)=SEC TOELPS58 22 I=I+1 TOELPS59 IF(IOB(I-1,1).EQ.-2)J=1 TOELPS60 IF(IOB(I-1,1).EQ.-2)GOTO50 TOELPS61 J=J+1 TOELPS62 GOTO20 TOELPS63 C REDUCE ANGLES FROM TERRAIN TO ELLIPSOID TOELPS64 30 IDEG=DOB(I,2) TOELPS65 IMIN=DOB(I,3) TOELPS66 CALL DMSRAD(IDEG,IMIN,DOB(I,4),R) TOELPS67 CALL REANG1(R,IA,IF,IT,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) TOELPS68 IF(R.LT.0.D0)R=R+2.D0*PI TOELPS69 C1=C1*RO TOELPS70 C2=C2*RO TOELPS71 C3=C3*RO TOELPS72 CALL RADMS(R,IDE,IMI,SEC) TOELPS73 IF(NCORR.EQ.1)PRINT 105,CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN, TOELPS74 @ DOB(I,4),C1,C2,C3,IDE,IMI,SEC TOELPS75 DOB(I,2)=IDE TOELPS76 DOB(I,3)=IMI TOELPS77 DOB(I,4)=SEC TOELPS78 I=I+1 TOELPS79 GOTO50 TOELPS80 C REDUCE AZIMUTHS FROM TERRAIN TO ELLIPSOID TOELPS81 40 IF(NRED3.EQ.0)I=I+1 TOELPS82 IF(NRED3.EQ.0)GOTO50 TOELPS83 IDEG=DOB(I,2) TOELPS84 IMIN=DOB(I,3) TOELPS85 CALL DMSRAD(IDEG,IMIN,DOB(I,4),R) TOELPS86 CALL REDAZ1(R ,IA,IF,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3,C4) TOELPS87 IF(R.LT.0.D0)R=R+2.D0*PI TOELPS88 C1=C1*RO TOELPS89 C2=C2*RO TOELPS90 C3=C3*RO TOELPS91 C4=C4*RO TOELPS92 CALL RADMS(R,IDE,IMI,SEC) TOELPS93 IF(NCORR.EQ.1)PRINT 106,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN, TOELPS94 @ DOB(I,4),C1,C2,C3,C4,IDE,IMI,SEC TOELPS95 DOB(I,2)=IDE TOELPS96 DOB(I,3)=IMI TOELPS97 DOB(I,4)=SEC TOELPS98 I=I+1 TOELPS99 50 IF(I.LE.NO)GOTO1 TOELP100 101 FORMAT('1',24X,'SUMMARY OF REDUCTION OF OBSERVATIONS FROM TERRAIN TOELP101 @TO ELLIPSOID',/,' ',24X,62('-'),//) TOELP102 102 FORMAT(' ',54X,'GRAVI-',2X,'SKEW',2X,'TO GE-',2X,'AZI- SPATIAL',2XTOELP103 @,'CHORD',3X,'REDUCED',/,' ',13X,'AT',7X,'FROM',5X,'TO',9X,'OBSERVETOELP104 @D',4X,'METRIC',1X,'NORMAL ODESIC',2X,'MUTH',1X,'TO CHORD TO EL',2XTOELP105 @,'OBSERVATION',/) TOELP106 103 FORMAT(' ','DISTANCE',5X,A8,1X,A8,1X,A8,F11.3,30X,2F8.3,F12.3,/) TOELP107 104 FORMAT(' ','DIRECTION',I2,2X,A8,1X,A8,1X,A8,I4,I3,4F7.3,21X,I4,I3,TOELP108 @ F7.3,/) TOELP109 105 FORMAT(' ','ANGLE',8X,A8,1X,A8,1X,A8,I4,I3,4F7.3,21X,I4,I3,F7.3,/)TOELP110 106 FORMAT(' ','AZIMUTH',6X,A8,1X,A8,1X,A8,I4,I3,5F7.3,14X,I4,I3,F7.3,TOELP111 @ /) TOELP112 RETURN TOELP113 END TOELP114 SUBROUTINE TOPLAN(IOB,DOB,NOR,XO,YO,RKO,AP,NSR,NCORR,NO,CNAM, TOPLAN01 @ NRED3,NPROJ,AA,BB,R1,DOBR,NRED1) TOPLAN02 C***********************************************************************TOPLAN03 C* TOPLAN04 C* TOPLAN COMPUTES CORRECTIONS AND MAKES REDUCTIONS TO OBSERVATIONS FROTOPLAN05 C* THE ELLIPSOID TO THE MAPPING PLANE TOPLAN06 C* TOPLAN07 C* TOPLAN08 C* INPUT: TOPLAN09 C* -ALL DESCRIBED IN MAIN TOPLAN10 C* TOPLAN11 C* TOPLAN12 C* WRITTEN BY: TOPLAN13 C* R.R. STEEVES, JUNE, 1978 TOPLAN14 C* TOPLAN15 C***********************************************************************TOPLAN16 IMPLICIT REAL*8(A-H,O-Z) TOPLAN17 DIMENSION IOB(NOR,4),DOB(NOR,4),AP(NSR,12),CNAM(NSR),DOBR(NOR,4) TOPLAN18 IF(NCORR.EQ.1)PRINT101 TOPLAN19 IF(NCORR.EQ.1)PRINT102 TOPLAN20 I=1 TOPLAN21 PI=3.141592653589793D0 TOPLAN22 1 ID=IOB(I,1) TOPLAN23 IA=IOB(I,2) TOPLAN24 IF=IOB(I,3) TOPLAN25 IT=IOB(I,4) TOPLAN26 GOTO(10,20,30,40),ID TOPLAN27 C REDUCE DISTANCES FROM ELLIPSOID TO PLANE TOPLAN28 10 SIJ=DOB(I,3) TOPLAN29 IF(NPROJ.EQ.1.OR.NPROJ.EQ.2)GOTO11 TOPLAN30 CALL TKTM(IA,IF,AP,NSR,RKO,AA,BB,XO,TT,S) TOPLAN31 GOTO12 TOPLAN32 11 CALL TKSTER(IA,IF,AP,NSR,R1,XO,YO,RKO,TT,S) TOPLAN33 12 DOB(I,3)=DOB(I,3)*S TOPLAN34 IF(NCORR.EQ.1)PRINT103,CNAM(IA),CNAM(IA),CNAM(IF),SIJ,S,DOB(I,3) TOPLAN35 I=I+1 TOPLAN36 GOTO50 TOPLAN37 C REUCE DIRECTIONS FROM ELLIPSOID TO PLANE TOPLAN38 20 J=0 TOPLAN39 21 J=J+1 TOPLAN40 IA=IOB(I,2) TOPLAN41 IF=IOB(I,3) TOPLAN42 IDEG=DOB(I,2) TOPLAN43 IMIN=DOB(I,3) TOPLAN44 SEC=DOB(I,4) TOPLAN45 IF(NPROJ.EQ.1.OR.NPROJ.EQ.2)GOTO22 TOPLAN46 CALL TKTM(IA,IF,AP,NSR,RKO,AA,BB,XO,TT,S) TOPLAN47 GOTO23 TOPLAN48 22 CALL TKSTER(IA,IF,AP,NSR,R1,XO,YO,RKO,TT,S) TOPLAN49 23 IF(J.NE.1)GOTO24 TOPLAN50 TT1=TT TOPLAN51 CALL RADMS(TT,IDT,IMT,ST) TOPLAN52 IF(NCORR.EQ.1)PRINT104,J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,SEC,TOPLAN53 @ IDT,IMT,ST,IDEG,IMIN,SEC TOPLAN54 I=I+1 TOPLAN55 GOTO21 TOPLAN56 24 CALL DMSRAD(IDEG,IMIN,SEC,R) TOPLAN57 R=R-TT+TT1 TOPLAN58 IF(R.LT.0.D0)R=R+2.D0*PI TOPLAN59 CALL RADMS(R,IDR,IMR,SR) TOPLAN60 CALL RADMS(TT,IDT,IMT,ST) TOPLAN61 DOB(I,2)=IDR TOPLAN62 DOB(I,3)=IMR TOPLAN63 DOB(I,4)=SR TOPLAN64 IF(NCORR.EQ.1)PRINT104,J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,SEC,TOPLAN65 @IDT,IMT,ST,IDR,IMR,SR TOPLAN66 I=I+1 TOPLAN67 IF(IOB(I-1,1).EQ.-2)GOTO50 TOPLAN68 GOTO21 TOPLAN69 C REDUCE ANGLES FROM ELLIPSOID TO PLANE TOPLAN70 30 IDEG=DOB(I,2) TOPLAN71 IMIN=DOB(I,3) TOPLAN72 SEC=DOB(I,4) TOPLAN73 IF(NPROJ.EQ.1.OR.NPROJ.EQ.2)GOTO31 TOPLAN74 CALL TKTM(IA,IF,AP,NSR,RKO,AA,BB,XO,TT1,S) TOPLAN75 CALL TKTM(IA,IT,AP,NSR,RKO,AA,BB,XO,TT2,S) TOPLAN76 GOTO32 TOPLAN77 31 CALL TKSTER(IA,IF,AP,NSR,R1,XO,YO,RKO,TT1,S) TOPLAN78 CALL TKSTER(IA,IT,AP,NSR,R1,XO,YO,RKO,TT2,S) TOPLAN79 32 TT=TT1-TT2 TOPLAN80 CALL DMSRAD(IDEG,IMIN,SEC,R) TOPLAN81 R=R+TT TOPLAN82 IF(R.LT.0.D0)R=R+2.D0*PI TOPLAN83 CALL RADMS(TT,IDT,IMT,ST) TOPLAN84 CALL RADMS(R,IDR,IMR,SR) TOPLAN85 DOB(I,2)=IDR TOPLAN86 DOB(I,3)=IMR TOPLAN87 DOB(I,4)=SR TOPLAN88 IF(NCORR.EQ.1)PRINT105,CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN,SEC, TOPLAN89 @ IDT,IMT,ST,IDR,IMR,SR TOPLAN90 I=I+1 TOPLAN91 GOTO50 TOPLAN92 C REDUCE AZIMUTHS FROM ELLIPSOID TO PLANE TOPLAN93 40 IF(NRED3.EQ.0)I=I+1 TOPLAN94 IF(NRED3.EQ.0)GOTO50 TOPLAN95 IDEG=DOB(I,2) TOPLAN96 IMIN=DOB(I,3) TOPLAN97 SEC=DOB(I,4) TOPLAN98 IF(NPROJ.EQ.1.OR.NPROJ.EQ.2)GOTO41 TOPLAN99 CALL TKTM(IA,IF,AP,NSR,RKO,AA,BB,XO,TT,S) TOPLA100 GOTO42 TOPLA101 41 CALL TKSTER(IA,IF,AP,NSR,R1,XO,YO,RKO,TT,S) TOPLA102 42 CALL DMSRAD(IDEG,IMIN,SEC,R) TOPLA103 R=R-TT-AP(IA,12) TOPLA104 IF(R.LT.0.D0)R=R+2.D0*PI TOPLA105 CALL RADMS(TT,IDT,IMT,ST) TOPLA106 CALL RADMS(AP(IA,12),IDM,IMM,SM) TOPLA107 CALL RADMS(R,IDR,IMR,SR) TOPLA108 DOB(I,2)=IDR TOPLA109 DOB(I,3)=IMR TOPLA110 DOB(I,4)=SR TOPLA111 IF(NCORR.EQ.1)PRINT106,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,SEC, TOPLA112 @ IDM,IMM,SM,IDT,IMT,ST,IDR,IMR,SR TOPLA113 I=I+1 TOPLA114 50 IF(I.LE.NO)GOTO1 TOPLA115 101 FORMAT('1',21X,'SUMMARY OF REDUCTION OF OBSERVATIONS FROM ELLIPSOITOPLA116 @D TO MAPPING PLANE',/,' ',21X,68('-'),//) TOPLA117 102 FORMAT(' ',45X,'OBSERVATION MERIDIAN',8X,'ARC',8X,'LINE',7X,'REDTOPLA118 @UCED',/,' ',16X,'AT',7X,'FROM',5X,'TO',7X,'(ON ELLIPSOID) CONVERGETOPLA119 @NCE',3X,'TO CHORD',5X,'SCALE',6X,'OBSERVATION',/) TOPLA120 103 FORMAT(' ',' DISTANCE',6X,A8,1X,A8,1X,A8,F12.3,28X,F11.7,F12.3,/)TOPLA121 104 FORMAT(' ',' DIRECTION',I3,2X,A8,1X,A8,1X,A8,I5,I3,F6.2,13X,I4,I3TOPLA122 @,F6.2,11X,I5,I3,F6.2,/) TOPLA123 105 FORMAT(' ',' ANGLE',9X,A8,1X,A8,1X,A8,I5,I3,F6.2,13X,I4,I3,F6.2, TOPLA124 @ 11X,I5,I3,F6.2,/) TOPLA125 106 FORMAT(' ',' AZIMUTH',7X,A8,1X,A8,1X,A8,I5,I3,F6.2,I4,I3,F6.2,I4,TOPLA126 @ I3,F6.2,11X,I5,I3,F6.2,/) TOPLA127 RETURN TOPLA128 END TOPLA129 SUBROUTINE UPDAT(NS,ITER,NF,NFIX,AP,X,NZERO,ZER,N,NSR,CNAM,NFR, UPDAT001 @ NDELX,NB,IBH,NBR) UPDAT002 C***********************************************************************UPDAT003 C* UPDAT004 C* UPDAT ADDS COMPUTED ITERATIVE CORRECTIONS TO THE PARAMETERS AND PRINUPDAT005 C* THEM IF REQUESTED. UPDAT006 C* UPDAT007 C* UPDAT008 C* INPUT: UPDAT009 C* -ALL DESCRIBED IN MAIN UPDAT010 C* UPDAT011 C* UPDAT012 C* WRITTEN BY: UPDAT013 C* R.R. STEEVES, MAY, 1976 UPDAT014 C* REVISED, JUNE,1978 UPDAT015 C* UPDAT016 C***********************************************************************UPDAT017 IMPLICIT REAL*8(A-H,O-Z) UPDAT018 DIMENSION NFIX(NFR),AP(NSR,12),X(N),CNAM(NSR),IBH(NBR) UPDAT019 IF(ITER.EQ.0)PRINT159 UPDAT020 IF(ITER.GT.0.AND.NDELX.EQ.1)GOTO5 UPDAT021 PRINT 101,ITER UPDAT022 PRINT 102 UPDAT023 5 J=1 UPDAT024 DO 3 I=1,NS UPDAT025 IF(NF.EQ.0)GOTO8 UPDAT026 DO 1 K=1,NF UPDAT027 IF(I.EQ.NFIX(K))GOTO3 UPDAT028 1 CONTINUE UPDAT029 8 IF(NB.EQ.0)GOTO2 UPDAT030 DO 7 K=1,NB UPDAT031 IF(I.EQ.IBH(K))GOTO3 UPDAT032 7 CONTINUE UPDAT033 2 OLDX=AP(I,1) UPDAT034 OLDY=AP(I,2) UPDAT035 AP(I,1)=AP(I,1)-X(J) UPDAT036 AP(I,2)=AP(I,2)-X(J+1) UPDAT037 XX=-X(J) UPDAT038 YY=-X(J+1) UPDAT039 IF(ITER.GT.0.AND.NDELX.EQ.1)GOTO6 UPDAT040 PRINT 103,CNAM(I),OLDX,OLDY,XX,YY,AP(I,1),AP(I,2) UPDAT041 6 J=J+2 UPDAT042 3 CONTINUE UPDAT043 IF(NZERO.EQ.0)GOTO4 UPDAT044 ZER=ZER-X(N) UPDAT045 IF(ITER.GT.0.AND.NDELX.EQ.1)GOTO4 UPDAT046 PRINT 104,ZER UPDAT047 101 FORMAT(' ',///,' ',45X,'ITERATION #',I3,/) UPDAT048 102 FORMAT(' ',10X,'STATION',8X,'OLD X',8X,'OLD Y',7X,'DX',11X,'DY', UPDAT049 @ 11X,'NEW X',8X,'NEW Y',/) UPDAT050 103 FORMAT(' ',10X,A8,2F13.3,F12.5,F13.5,2F13.3,/) UPDAT051 104 FORMAT(' ',/,' ',40X,'ZERO ERROR= ',F9.3) UPDAT052 159 FORMAT('1',21X,'SUMMARY OF ITERATIVE CORRECTIONS TO INITIAL APPROXUPDAT053 @IMATE COORDINATES:',/,' ',21X,67('-'),//) UPDAT054 4 RETURN UPDAT055 END UPDAT056 SUBROUTINE WVEC(ICA,A,RU,W,P,N,NO,I,NOR) WVEC0001 C***********************************************************************WVEC0002 C* WVEC0003 C* WVEC SEQUENTIALLY ADDS CONTRIBUTION OF DISTANCE, ANGLE OR AZIMUTH WVEC0004 C* OBSERVATIONS TO THE CONSTANT VECTOR WVEC0005 C* WVEC0006 C* WVEC0007 C* INPUT: WVEC0008 C* -ALL DESCRIBED IN MAIN WVEC0009 C* WVEC0010 C* WVEC0011 C* WRITTEN BY: WVEC0012 C* R.R. STEEVES, MAY, 1976 WVEC0013 C* WVEC0014 C***********************************************************************WVEC0015 IMPLICIT REAL*8(A-H,O-Z) WVEC0016 DIMENSION ICA(NOR,6),A(NOR,6),RU(N) WVEC0017 DO 1 K=1,6 WVEC0018 IF(ICA(I,K).EQ.0)GOTO1 WVEC0019 RU(ICA(I,K))=RU(ICA(I,K))+A(I,K)*P*W WVEC0020 1 CONTINUE WVEC0021 RETURN WVEC0022 END WVEC0023 SUBROUTINE XOBS(NCODE,RN,RU,N,SPX,NP,IPX,ICP,AP,OX,IB,NS,IC,WX XOBS0001 @ ,NR,NP2R,NB2R,NSR,CNAM,NPR,NBR) XOBS0002 C***********************************************************************XOBS0003 C* XOBS0004 C* XOBS ADDS THE CONTRIBUTION OF WEIGHTED STATIONS TO THE NORMAL EQUATIXOBS0005 C* AND CONSTANT VECTOR XOBS0006 C* XOBS0007 C* XOBS0008 C* INPUT: XOBS0009 C* -ALL DESCRIBED IN MAIN XOBS0010 C* XOBS0011 C* XOBS0012 C* WRITTEN BY: XOBS0013 C* R.R.STEEVES, JUNE, 1978 XOBS0014 C* XOBS0015 C***********************************************************************XOBS0016 IMPLICIT REAL*8(A-H,O-Z) XOBS0017 DIMENSION RN(NR,NR),RU(NR),SPX(NB2R,NB2R),IPX(NBR),ICP(NR), XOBS0018 @ OX(NPR,2),IB(NR),IC(NSR,2),WX(NP2R),CNAM(NSR),AP(NSR,12) XOBS0019 J=1 XOBS0020 DO 1 I=1,NP XOBS0021 ICP(J)=IC(IPX(I),1) XOBS0022 ICP(J+1)=IC(IPX(I),2) XOBS0023 1 J=J+2 XOBS0024 NP2=NP*2 XOBS0025 DO 2 I=1,NP2 XOBS0026 DO 2 J=1,NP2 XOBS0027 IF(ICP(I).EQ.0.OR.ICP(J).EQ.0)GOTO2 XOBS0028 IF(ICP(I).GT.ICP(J))GOTO2 XOBS0029 IF(ICP(I).LT.IB(ICP(J)))IB(ICP(J))=ICP(I) XOBS0030 RN(ICP(I),ICP(J))=RN(ICP(I),ICP(J))+SPX(I,J) XOBS0031 2 CONTINUE XOBS0032 IF(NCODE.EQ.1)GOTO6 XOBS0033 J=1 XOBS0034 DO 4 I=1,NP XOBS0035 WX(J)=AP(IPX(I),1)-OX(I,1) XOBS0036 WX(J+1)=AP(IPX(I),2)-OX(I,2) XOBS0037 4 J=J+2 XOBS0038 DO 5 I=1,NP2 XOBS0039 DO 5 J=1,NP2 XOBS0040 IF(ICP(J).EQ.0)GOTO5 XOBS0041 RU(ICP(J))=RU(ICP(J))+WX(I)*SPX(I,J) XOBS0042 5 CONTINUE XOBS0043 6 RETURN XOBS0044 END XOBS0045 SUBROUTINE XSIN(T,N,NCODE,NN,B,D,IID,IB,X,NR,CONVG,NSQRT,ITER, XSIN0001 @CNAM,NS,IOB,NOR,IC,NSR,ICA,RU,W,CPX,NP,WX,NP2R,NPR,NO,JCD,NITER, XSIN0002 @INCQ) XSIN0003 C***********************************************************************XSIN0004 C* XSIN0005 C* XSIN COMPUTES THE CHOLESKI SQUARE ROOT OF A VARIABLE BANDED SYMMETRIXSIN0006 C* MATRIX T. IT ALSO COMPUTES THE SOLUTION VECTOR OF THE LINEAR EQUATIXSIN0007 C* T*X=B BY BACKWARD AND FORWARD SUBSTITUTIONS. THE INVERSE OF T IS COXSIN0008 C* PUTED IF THE SOLUTION VECTOR ELEMENTS ARE SMALLER THAN CONVG. SINGUXSIN0009 C* ARITIES EXISTING IN T ARE DETECTED WHEN COMPUTING THE CHOLESKI SQUARXSIN0010 C* ROOT. XSIN IS USED FOR COMPUTING THE INVERSE OF THE INPUT (IF ANY) XSIN0011 C* A PRIORI COVARIANCE MATRIX. XSIN0012 C* XSIN0013 C* XSIN0014 C* WRITTEN BY: XSIN0015 C* R.R. STEEVES, MAY, 1976 XSIN0016 C* MODIFIED: MAY, 1978 XSIN0017 C* MODIFIED: JULY,1978 XSIN0018 C* MODIFIED: AUG., 1978 XSIN0019 C* XSIN0020 C***********************************************************************XSIN0021 IMPLICIT REAL*8(A-H,O-Z) XSIN0022 DIMENSION T(NR,NR),D(NR),B(NR),X(NR),IB(NR),CNAM(NSR),IOB(NOR,4), XSIN0023 @ IC(NSR,2),ICA(NOR,6),RU(NR),W(NOR),CPX(NPR),WX(NP2R) XSIN0024 CRIT=1.D-6 XSIN0025 DO 4 J=1,N XSIN0026 DO 4 I=1,J XSIN0027 IF(I.LT.IB(J))GOTO4 XSIN0028 IF(I.EQ.1)GOTO2 XSIN0029 M=I-1 XSIN0030 SUM=0.0D0 XSIN0031 IF(IB(I).LE.IB(J))L=IB(J) XSIN0032 IF(IB(J).LT.IB(I))L=IB(I) XSIN0033 IF(L.GT.M)GOTO2 XSIN0034 DO 1 K=L,M XSIN0035 1 SUM=SUM+T(K,I)*T(K,J) XSIN0036 IF(I.NE.J)GOTO5 XSIN0037 IF(JCD.EQ.0)GOTO5 XSIN0038 C2=(T(I,J)-SUM)**2 XSIN0039 GI=C2/T(I,I) XSIN0040 IF(GI.LE.CRIT.AND.INCQ.GT.0)GOTO23 XSIN0041 IF(GI.LE.CRIT)CALL SINO(T,NR,I,N,IC,CNAM,NS,NSR) XSIN0042 IF(GI.LE.CRIT)JCD=JCD+1 XSIN0043 IF(GI.LE.CRIT)GOTO2 XSIN0044 5 T(I,J)=T(I,J)-SUM XSIN0045 2 IF(I.EQ.J)GOTO3 XSIN0046 IF(T(I,I).EQ.0.D0)GOTO4 XSIN0047 T(I,J)=T(I,J)/T(I,I) XSIN0048 GOTO4 XSIN0049 3 IF(T(I,I).LE.0.D0)GOTO4 XSIN0050 T(I,I)=DSQRT(T(I,I)) XSIN0051 4 CONTINUE XSIN0052 IF(JCD.GT.1)STOP XSIN0053 IF(NSQRT.NE.0.AND.((NSQRT.EQ.1.AND.ITER.EQ.0).OR.(NSQRT.EQ.2))) XSIN0054 @ CALL PRAR(T,NR,NR,N,N,22,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, XSIN0055 @ CPX,NP,WX,NR,NP2R,NPR,NO) XSIN0056 IF(NCODE.EQ.1)GOTO10 XSIN0057 D(1)=B(1)/T(1,1) XSIN0058 DO 6 I=2,N XSIN0059 SUM=0.0D0 XSIN0060 K=I-1 XSIN0061 DO 22 J=1,K XSIN0062 22 SUM=SUM+T(J,I)*D(J) XSIN0063 6 D(I)=(B(I)-SUM)/T(I,I) XSIN0064 X(N)=D(N)/T(N,N) XSIN0065 M=N-1 XSIN0066 DO 8 I=1,M XSIN0067 SUM=0.0D0 XSIN0068 J=N-I+1 XSIN0069 L=N-I XSIN0070 DO 7 K=J,N XSIN0071 7 SUM=SUM+T(L,K)*X(K) XSIN0072 8 X(L)=(D(L)-SUM)/T(L,L) XSIN0073 IID=0 XSIN0074 DO 9 I=1,NN XSIN0075 IF(DABS(X(I)).GT.CONVG )IID=1 XSIN0076 IF(IID.EQ.1.AND.ITER.LT.NITER)GOTO20 XSIN0077 9 CONTINUE XSIN0078 10 DO 17 J=1,N XSIN0079 DO 17 I=1,J XSIN0080 IF(I.LT.J)GOTO15 XSIN0081 T(J,J)=1.0D0/T(J,J) XSIN0082 GOTO17 XSIN0083 15 SUM=0.0D0 XSIN0084 M=J-1 XSIN0085 DO 16 K=I,M XSIN0086 16 SUM=SUM-T(I,K)*T(K,J) XSIN0087 T(I,J)=SUM/T(J,J) XSIN0088 17 CONTINUE XSIN0089 DO 19 J=1,N XSIN0090 DO 19 I=1,J XSIN0091 SUM=0.0D0 XSIN0092 DO 18 K=J,N XSIN0093 18 SUM=SUM+T(I,K)*T(J,K) XSIN0094 T(I,J)=SUM XSIN0095 T(J,I)=SUM XSIN0096 19 CONTINUE XSIN0097 20 RETURN XSIN0098 23 IF(INCQ.EQ.1)PRINT101,I,I XSIN0099 101 FORMAT(' ','*** INPUT ERROR #051 *** SINGULARITY ENCOUNTERED IN TXSIN0100 @HE INPUT MATRIX FOR WEIGHTED STATIONS; POSITION (',I4,' ,',I4, XSIN0101 @' )') XSIN0102 IF(INCQ.EQ.2)PRINT102,I,I XSIN0103 102 FORMAT(' ','*** INPUT ERROR #052 *** SINGULARITY ENCOUNTERED IN TXSIN0104 @HE INPUT MATRIX FOR BLAHA STATIONS; POSITION (',I4,' ,',I4,' )') XSIN0105 STOP XSIN0106 END XSIN0107 SUBROUTINE ZERON(RN,RU,IB,N,NR) ZERON001 C***********************************************************************ZERON002 C* ZERON003 C* ZERON SETS ELEMENTS OF THE NORMAL EQUATIONS AND CONSTANT VECTOR TO ZZERON004 C* ALSO INITIALIZES VARIABLE BANDING CONTROL VECTOR TO NUMBERS CORRESPOZERON005 C* ING TO THE DIAGONAL OF THE NORMAL EQUATIONS. ZERON006 C* ZERON007 C* ZERON008 C* INPUT: ZERON009 C* -ALL DESCRIBED IN MAIN ZERON010 C* ZERON011 C* OUTPUT: ZERON012 C* -ALL DESCRIBED IN MAIN ZERON013 C* ZERON014 C* ZERON015 C* WRITTEN BY: ZERON016 C* R.R. STEEVES, AUG., 1978 ZERON017 C* ZERON018 C***********************************************************************ZERON019 IMPLICIT REAL*8(A-H,O-Z) ZERON020 DIMENSION RN(NR,NR),RU(NR),IB(NR) ZERON021 DO 22 I=1,N ZERON022 IB(I)=I ZERON023 RU(I)=0.0D0 ZERON024 DO 22 J=1,N ZERON025 22 RN(I,J)=0.0D0 ZERON026 RETURN ZERON027 END