C PROGRAM STRAINPLOT (GRAPHICAL REPRESENTATION OF STRAIN TENSORFIELDS) (0001) C PROGRAM STRAINPLOT (GRAPHICAL REPRESENTATION OF STRAIN TENSORFIELD (0002) (0003) C **************************************************************** (0004) C * * (0005) C * PROGRAM STRAINPLOT (VERSION 12.81) * (0006) C * * (0007) C * DEVELOPED BY K.THAPPA, MODIFIED BY D.SCHNEIDER * (0008) C * AT THE UNIVERSITY OF NEW BRUNSWICK, THE GEODETIC SURVEY * (0009) C * OF CANADA (EMR) AND THE SWISS TOPOGRAPHIC SURVEY. * (0010) C * WABERN, DECEMBER 1981 * (0011) C * * (0012) C **************************************************************** (0013) (0014) C (0015) C STRAINPLOT IS USED TO DISPLAY GRAPHICALLY THE RESULTING STRAIN TEN (0016) C FIELD AS IT IS COMPUTED AND STORED IN THE PERMANENT FILE IFILI BY (0017) C PROGRAMS DACAP OR CRUSTRAIN. (0018) C (0019) C (0020) C LIST OF I/O - FILES: (0021) C (0022) C FILENAME FTN# PRIMOS# TYP CONTENTS (0023) C (0024) C 1 SEQ DIALOG WITH CRT-TERMINAL (0025) C IFILI 5 1 SEQ COORD.,DISPLAC.,STRAIN,COV. (S (0026) C BY PROGRAM DACAP OR CRUSTRAIN) (0027) C 'O_STRAINPLOT' 6 2 SEQ OUTPUT-LIST (0028) C 'PERPOL' 7 3 SEQ COORD. OF PERIMETER POLYGON (0029) C 'PLT_STRAIN' 8 4 SEQ PLOT-INFO. (0030) C IFIL2 9 5 SEQ GIVEN DISPLACEMENTS (I-FILE OF (0031) C PROGRAM DACAP) (0032) C (0033) C (0034) C INPUT FORMATS: (0035) C (0036) C I-FILE FORMAT (0037) C (0038) C IFILI (4A2,2F10.2,2F8.4,4F9.4/8E10.3/8E10.3) (0039) C 'PERPOL' (2F10.2) (0040) C IFIL2 (32X,2F8.4) (0041) C (0042) C (0043) C LIST OF PLOT-LIB SUBROUTINES (CALCOMP): (0044) C (0045) C SUBROUTINE NAME (0046) C (0047) C PLOTS INITIALIZE PLOTTING (0048) C PLOT PLOT POINT OR STRAIGHT LINE (0049) C SYMBOL PLOT SYMBOL OR ALPHABETIC SYMBOL (0050) C NUMBER PLOT NUMBER (0051) C (0052) C OTHER PLOT-ROUTINES ARE PROVIDED WITH THIS SOURCE (0053) C (0054) C (0055) INTEGER*2 (0056) I IFILI(16), /* NAME OF INPUT FILE 1 (0057) I IFIL2(16), /* NAME OF INPUT FILE 2 (0058) N N(500,5), /* STATION NAMES (0059) N NSTAT(4), /* STATION NAME (0060) N NTITLE(32) /* TITLE OF PROJECT (0061) (0062) REAL*4 (0063) C CCHIPS(4,4), /* COV.-SUBMATRICES OF STRAIN VALUES (0064) C CHI2, /* PERCENTILE OF CHI-SQUARE DISTRIBUTION (0065) P P(500,2), /* POINT COORD. (0066) P PAR(5), /* PLOT-PARAMETERS FOR SUBROUTINE POLAR (0067) R RAD(5), /* PLOT-PARAMETERS FOR SUBROUTINE POLAR (0068) X XR(2), (0069) Y YR(2) (0070) (0071) REAL*8 (0072) D DPER(2), (0073) P PER(100,2), /* COORD. OF PERIMETER POLYGON (0074) P PI, (0075) Q Q(2), (0076) R RHOGON (0077) (0078) COMPLEX*8 (0079) C CHI, /* CONFORMAL COMPLEX STRAIN COMPONENT (0080) P PSI /* ANTICONFORMAL COMPLEX STRAIN COMPONENT (0081) (0082) LOGICAL (0083) L LSTATN, /* PLOT STATION NAMES (0084) L LDISPL, /* PLOT GIVEN DISPLACEMENTS (0085) L LADISP, /* PLOT APPROXIMATED DISPLACEMENTS (0086) L LROTAT, /* PLOT AVERAGE DIFFERENTIAL ROTATION SECTORS (0087) L LDILAT, /* PLOT DILATION (AVERAGE EXTENSION CIRCLES) (0088) L LELLAX, /* PLOT PRINCIPLE AXES OF STRAIN (0089) L LELIPS, /* PLOT STRAIN ELLIPSES (0090) L LSHRAX, /* PLOT AXES OF MAX. SHEAR (0091) L LROSET, /* PLOT SHEAR ROSETTES (0092) L LPEDAL, /* PLOT STRAIN PEDAL CURVES (0093) L LCON , /* PLOT NETWORK CONNECTIONS (0094) L LCONFI, /* PLOT STAND.DEV. TO SELECTED QUANTITIES (0095) L LCONF0, /* PLOT STAND.DEV.ONLY (0096) L LCONF, /* PLOT CONFIDENCE REGIONS (0097) L LINPER, /* PLOT POINTS IN PERIMETER ONLY (0098) L LPLTPR, /* PLOT PERIMETER POLYGON (0099) L LINPOL, /* POINT IN PERIMETER POLYGON (0100) L LOPEN, (0101) N NOELPS, /* DO NOT PLOT STRAIN FIGURE (0102) N NODXY1, /* DO NOT PLOT GIVEN DISPLACEMENT VECTOR (0103) N NODXY2, /* DO NOT PLOT PREDICTED DISPLACEMENT VECTOR (0104) N NOSHR, /* DO NOT PLOT SHEAR AXES AND ROSETTES (0105) N NEWFLT, /* (0106) L LFAULT, /* PLOT FAULT LINES (0107) L LBLOCK /* PLOT BLOCK LIMITS (0108) (0109) COMMON CCHIPS,CFACT (0110) COMMON /CONF/ CHI2 (0111) (0112) C INSERT SYSTEM ROUTINES FOR FILE HANDLING (0113) C A$KEYS, APPLIB, ELS, 08/21/80 (0113) C Insert file for mnemonic APPLIB keys (FTN) (0113) C Copyright 1977, PR1ME COMPUTER, INC., Framingham, MA. (0113) NOLIST (0114) (0115) EXTERNAL PEDAL,CIRC,ELIPS,ROSET,CPEDAL,CROSET,CCIRC,QROSET (0116) (0117) DATA (0118) C CFACT/1./, (0119) D DXID/0.3/, (0120) R RMARG/5./, /* MARGINS / MAX. SIZE FOR ELLIPSES, VECTORS (0121) U UNITS/100./, /* EQUIVAL. OF 1M IN PLOTTER UNITS (0122) W WMIN,WMAX/1.E20,-1.E20/, (0123) X XMAX,YMAX/100.,99.6/, /* X-, Y-EXTEND [CM] (0124) Z ZMIN,ZMAX/1.E20,-1.E20/ (0125) (0126) C PEN COLOR DEFINITION (0127) DATA (0128) I ICOL1/1/, /* RED (0129) I ICOL2/2/, /* GREEN (0130) I ICOL3/3/, /* BLUE (0131) I ICOL4/4/ /* BLACK (0132) (0133) PI = 4.D0 * DATAN(1.D0) (0134) RHOGON = 50.D0/DATAN(1.D0) (0135) PI2 = PI * 2 (0136) C (0137) C OPEN FILES (0138) LOPEN = OPNP$A('INPUTFILE',9,A$READ+A$SAMF,IFILI,32,1) (0139) IF(.NOT.LOPEN) GOTO 901 (0140) LOPEN = OPEN$A(A$WRIT+A$SAMF,'O_STRAINPLOT',12,2) (0141) IF(.NOT.LOPEN) GOTO 901 (0142) (0143) C READ AND PRINT TITEL OF PROJECT (0144) READ(5,105)NTITLE (0145) 105 FORMAT(32A2) (0146) WRITE(6,106)NTITLE (0147) 106 FORMAT(1H ,'PROGRAM STRAINPLOT (GRAPHICAL REPRESENTATION OF STRAIN (0148) 1 TENSORFIELDS)'/1H ,18(1H*)//' OUTPUT-LIST:'/1H ,12(1H-)//' TITEL (0149) 2OF PROJECT: ',32A2,//' PLOT PARAMETERS:'//) (0150) (0151) C READ AND PRINT CONFIDENCE LEVEL, CHI2, DIM. OF PARAMETER VECTOR (0152) READ(5,112) ALFA1,CHI2,IDIM (0153) 112 FORMAT(2F8.4,I4) (0154) CONFAC = SQRT(CHI2) (0155) WRITE(6,612) ALFA1,CHI2,IDIM,CONFAC (0156) 612 FORMAT(' LEVEL OF CONFIDENCE: 1-ALFA = ',F8.4/ (0157) 1 ' PERCENTIL OF CHI-SQUARE DISTRIBUTION : ',F8.4/ (0158) 2 ' DIM. OF PARAMETER VECTOR : ',I4/ (0159) 3 ' STANDARD CONFIDENCE INTERVALS ARE MULTIPLIED BY: ',F9.4/) (0160) (0161) C SELECT PLOT-OPTIONS (0162) WRITE(1,111) (0163) 111 FORMAT(' SELECT PLOT OPTIONS'// (0164) 1 ' OPT.# OPTION'// (0165) 2 ' 1 PLOT STATION NAMES'/ (0166) 3 ' 2 PLOT GIVEN DISPLACEMENTS'/ (0167) 4 ' 3 PLOT PREDICTED DISPLACEMENTS'/ (0168) 5 ' 4 PLOT AVERAGE DIFFERENTIAL ROTATION'/ (0169) 6 ' 5 PLOT DILATION (AVERAGE EXTENSION)'/ (0170) 7 ' 6 PLOT PRINCIPAL AXIS OF STRAIN'/ (0171) 8 ' 7 PLOT STRAIN ELLIPSES'/ (0172) 9 ' 8 PLOT AXIS OF MAX. SHEAR'/ (0173) A ' 9 PLOT SHEAR ROSETTES'/ (0174) B ' 10 PLOT STRAIN PEDAL CURVES'/ (0175) C C ' 11 PLOT NETWORK CONNECTIONS'/ (0176) D ' 12 PLOT STAND.DEVIATIONS TO SELECTED QUANTITIES'/ (0177) E ' 13 PLOT STAND.DEVIATIONS ONLY'/ (0178) F ' 14 PLOT CONFIDENCE REGIONS'/ (0179) G ' 15 PLOT POINTS IN PERIMETER ONLY'/ (0180) H ' 16 PLOT PERIMETER POLYGON'/ (0181) I ' 17 PLOT FAULT LINES'/ (0182) K ' 18 PLOT REL. BLOCK MOTIONS'// (0183) L ' 19 TERMINATE SELECTION OF OPTIONS'//) (0184) 500 CONTINUE (0185) CALL TNOUA('OPT.#: ',7) (0186) READ(1,*)IOPT (0187) GOTO(501,502,503,504,505,506,507,508,509,510,511,512,513,514,515, (0188) 1 516,517,518,599),IOPT (0189) GOTO 599 (0190) 501 LSTATN = .TRUE. (0191) GOTO 598 (0192) 502 LDISPL = .TRUE. (0193) GOTO 598 (0194) 503 LADISP = .TRUE. (0195) GOTO 598 (0196) 504 LROTAT = .TRUE. (0197) GOTO 598 (0198) 505 LDILAT = .TRUE. (0199) GOTO 598 (0200) 506 LELLAX = .TRUE. (0201) GOTO 598 (0202) 507 LELIPS = .TRUE. (0203) GOTO 598 (0204) 508 LSHRAX = .TRUE. (0205) GOTO 598 (0206) 509 LROSET = .TRUE. (0207) GOTO 598 (0208) 510 LPEDAL = .TRUE. (0209) GOTO 598 (0210) 511 LCON = .TRUE. (0211) GOTO 598 (0212) 512 LCONFI = .TRUE. (0213) GOTO 598 (0214) 513 LCONF0 = .TRUE. (0215) GOTO 598 (0216) 514 LCONF = .TRUE. (0217) GOTO 598 (0218) 515 LINPER = .TRUE. (0219) GOTO 598 (0220) 516 LPLTPR = .TRUE. (0221) GOTO 598 (0222) 517 LFAULT = .TRUE. (0223) GOTO 598 (0224) 518 LBLOCK = .TRUE. (0225) 598 CONTINUE (0226) GOTO 500 (0227) 599 CONTINUE (0228) (0229) C READ DEFINITION OF PERIMETER POLYGON FROM FILE 'PERPOL' (0230) 101 IF(.NOT.(LINPER.OR.LPLTPR)) GOTO 102 (0231) LOPEN = OPEN$A(A$READ+A$SAMF,'PERPOL',6,3) /* OPEN FILE PERPOL (0232) IF(.NOT.LOPEN) GOTO 901 (0233) 103 DO 104 I=1,100 (0234) 107 READ(7,701,END=108) DPER (0235) 701 FORMAT(2F10.2) (0236) PER(I,1) = DINT(DPER(1)/1.D1) (0237) PER(I,2) = DINT(DPER(2)/1.D1) (0238) 104 CONTINUE (0239) I = I + 1 (0240) 108 CONTINUE (0241) NPER = I-1 (0242) 102 CONTINUE (0243) (0244) C OPEN INPUTFILE 2 (0245) 39 IF(.NOT.LDISPL) GOTO 40 (0246) LOPEN = OPNP$A('I-FILE 2 (DACAP)',16,A$READ+A$SAMF,IFIL2,32,5) (0247) IF(.NOT.LOPEN) GOTO 901 (0248) 40 CONTINUE (0249) (0250) C READ PLOTPARAMETERS (INTERACTIV) (0251) CALL TNOUA('MAP SCALE = 1: ',15) (0252) READ(1,*) SCALE (0253) CALL TNOUA('SCALE OF FIGURES [CM/PPM] = ',28) (0254) READ(1,*) SCALEL (0255) PAR(5) = SCALEL (0256) RAD(5) = 1. (0257) 341 IF(.NOT.LROTAT) GOTO 342 (0258) CALL TNOUA('SCALE OF ROTATIONS [GON/0.1CC] = ',33) (0259) READ(1,*) SCALRO (0260) 342 CONTINUE (0261) 343 IF(.NOT.(LADISP.OR.LDISPL))GOTO 344 (0262) CALL TNOUA('SCALE OF DISPLACEMENTS = 1: ',28) (0263) READ(1,*) SCALDX (0264) 344 CONTINUE (0265) CALL TNOUA('RADIUS OF SECTORS [CM] = ',25) (0266) READ(1,*) RADIUS (0267) RAD1 = RADIUS - 0.1 (0268) C (0269) C WRITE PLOT PARAMETERS INTO OUTPUTLIST (0270) WRITE(6,202)SCALE,SCALEL,SCALRO,SCALDX,RADIUS (0271) 202 FORMAT(1X,'SCALE=1:', (0272) +F10.1/1X,'SCALE OF FIGURES=',F7.3,'CM PER MICROSTRAIN'/ (0273) +' SCALE OF ROTATIONS',F7.3,'GON PER 0.1CC'/ (0274) +' SCALE OF DISPLACEMENTS = 1:',F8.4/ (0275) +' RADIUS OF ROTATION SECTORS:',F7.3//' LIST OF PLOTTED STRAIN FIGU (0276) +RES:'/1H ,31(1H-)//) (0277) C (0278) 25 IF(ICON.EQ.0)GOTO 26 (0279) LCON=.TRUE. (0280) WRITE(6,204) (0281) 204 FORMAT(3X,'OPTION CON: CONNECTIONS USED FOR STRAIN COMPUTATION (0282) +TO BE PLOTTED'/) (0283) 26 CONTINUE (0284) C (0285) C INITIALIZE PLOTTER (0286) CALL PLOTS('PLT_STRAIN',10,4,0.,0.,XMAX,YMAX,1.,360.) (0287) CALL NEWPEN(ICOL4) (0288) C (0289) C SUBROUTINE PLOT IS USED TO SHIFT THE PAPER TO PROPER SETTING (0290) CALL PLOT(0.,0.,-3) (0291) C (0292) C READ STATION NUMBERS AND CO-ORDINATES OF STATIONS (0293) C COMPUTE PERIMETER (0294) C (0295) NS = 0 (0296) DO 22 I=1,500 (0297) 37 READ(5,450,END=38)(N(I,J),J=1,4),Q (0298) 450 FORMAT(4A2,2F10.2//) (0299) C WRITE(1,450)(N(I,J),J=1,4),Q (0300) P(I,1) = Q(1) (0301) P(I,2) = Q(2) (0302) C (0303) C CHECK IF POINT IS IN PERIMETER (0304) 109 IF(.NOT.LINPER) GOTO 110 (0305) 35 IF(LINPOL(Q,PER,NPER,1)) GOTO 36 (0306) N(I,5) = '$$' (0307) GOTO 22 (0308) 36 CONTINUE (0309) 110 CONTINUE (0310) (0311) C COMPUTE CIRCUMRECTANGLE (0312) WMIN = AMIN1(WMIN,P(I,1)) (0313) ZMIN = AMIN1(ZMIN,P(I,2)) (0314) WMAX = AMAX1(WMAX,P(I,1)) (0315) ZMAX = AMAX1(ZMAX,P(I,2)) (0316) 22 CONTINUE (0317) NS = 1 (0318) (0319) 38 CONTINUE (0320) NS = NS + I - 1 (0321) REWIND 5 (0322) READ(5,5112) (0323) READ(5,5112) (0324) 5112 FORMAT(1X) (0325) (0326) C COMPUTE WINDOW AND MARGINS (0327) ZM1=0. (0328) WM1=5. (0329) W1=WM1+RMARG (0330) Z1=ZM1+RMARG (0331) 13 DO 14 I=1,2 (0332) DW=(WMAX-WMIN)*UNITS (0333) WM2=W1+DW/SCALE+RMARG (0334) DZ=(ZMAX-ZMIN)*UNITS (0335) ZM2=Z1+DZ/SCALE+RMARG (0336) C (0337) C CHECK PLOT SIZE (0338) C (0339) 1 IF(WM2.LT.XMAX.AND.ZM2.LT.YMAX) GOTO2 (0340) SCALE1=DW/(XMAX-2.*RMARG-WM1) (0341) SCALE2=DZ/(YMAX-2.*RMARG-ZM1) (0342) SCALE=SCALE1 (0343) IF(SCALE2.GT.SCALE1)SCALE=SCALE2 (0344) 14 CONTINUE (0345) (0346) C WRITE HEADER OF OUTPUTLIST (0347) WRITE(6,451)SCALE (0348) 451 FORMAT(3X,'COMPUTED SCALE=1:',F12.1/) (0349) 2 CONTINUE (0350) WRITE(6,615) (0351) 615 FORMAT(1H ,'STATION',4X,'X(EAST) [M]',1X,'Y(NORTH) [M]',2X, (0352) 1 'X [CM]',5X,'Y [CM]',5X,'DX [CM]',4X,'DY [CM]',2X,'OMEGA [GON]', (0353) 2 1X,'PHI [GON]',1X,'MAJOR [CM]',1X,'MINOR [CM]'//) (0354) C (0355) C WRITE TITLE AND LEGEND INTO PLOT HEADER (0356) CALL SYMBOL(0.53,0.,0.5,'NETWORK: ',90.,9) (0357) CALL SYMBOL(0.53,5.,0.5,NTITLE,90.,32) (0358) CALL SYMBOL(999.,999.,0.5,NTITLE(17),90.,32) (0359) CALL SYMBOL(1.3,0.,0.43,'MAP SCALE 1:',90.,12) (0360) CALL NUMBER(1.3,5.,0.43,SCALE,90.,'F8.0') (0361) CALL SYMBOL(2.0,0.,0.43,'FIGURE SCALE [CM/PPM]: ',90.,23) (0362) CALL NUMBER(2.0,8.5,0.43,SCALEL,90.,2) (0363) 301 IF(.NOT.LROTAT) GOTO 302 (0364) CALL SYMBOL(2.8,0.,0.43,'SCALE OF ROTATIONS [GON/0.1CC]: ',90.,32) (0365) CALL NUMBER(2.8,12.0,0.43,SCALRO,90.,2) (0366) 302 CONTINUE (0367) C (0368) 31 IF(.NOT.LADISP)GOTO 32 (0369) CALL SYMBOL(1.3,15.0,0.43,'SCALE OF DISPLACEMENTS 1:',90.,25) (0370) CALL NUMBER(1.3,25.0,0.43,SCALDX,90.,2) (0371) 32 CONTINUE (0372) C (0373) 33 IF(.NOT.LCONF) GOTO 34 (0374) CALL SYMBOL(2.0,15.0,0.43,'LEVEL OF CONFIDENCE [%]:',90.,24) (0375) CALL NUMBER(2.0,25.0,0.43,ALFA1,90.,2) (0376) 34 CONTINUE (0377) C PLOT PERIMETER (0378) C (0379) CALL PLOT(WM1,ZM1,3) (0380) C CALL PLOT(WM2,ZM1,2) (0381) C CALL PLOT(WM2,ZM2,2) (0382) CALL PLOT(WM1,ZM2,2) (0383) C CALL PLOT(WM1,ZM1,2) (0384) CALL PLOT(WM1,ZM1,3) (0385) (0386) C PLOT SCALE AND NORTH ARROW (0387) CALL NORTH(WM1,ZM1,SCALE,SCALDX,SCALEL) (0388) (0389) C PLOT PERIMETER POLYGON (0390) 291 IF(.NOT.LPLTPR) GOTO 292 (0391) 293 DO 294 I=1,NPER (0392) IPEN = 2 (0393) IF(I.EQ.1)IPEN=3 (0394) C WRITE(1,1991)PER(I,1),PER(I,2) (0395) 1991 FORMAT(2E20.13) (0396) X = (PER(I,1)*10.D0-WMIN)/SCALE*UNITS+W1 (0397) Y = (PER(I,2)*10.D0-ZMIN)/SCALE*UNITS+Z1 (0398) CALL PLOT(X,Y,IPEN) (0399) 294 CONTINUE (0400) 292 CONTINUE (0401) C (0402) NEWFLT = .TRUE. (0403) 98 DO 99 J=1,NS (0404) NOELPS = .FALSE. (0405) NODXY1 = .FALSE. (0406) NODXY2 = .FALSE. (0407) C (0408) C READ STATION NUMBER, DISPLACEMENT, COMPLEX STRAIN COMPONENTS (0409) C AND COVARIANCE MATRIX OF COMPLEX STRAIN COMPONENTS (0410) C (0411) READ(5,415)DX,DY,CHI,PSI,CCHIPS (0412) 415 FORMAT(28X,2F8.4,4F9.4/8E10.3/8E10.3) (0413) (0414) 351 IF(.NOT.(LADISP.OR.LBLOCK)) GOTO 352 (0415) DX=DX/SCALDX*UNITS (0416) DY=DY/SCALDX*UNITS (0417) 352 CONTINUE (0418) C (0419) C PLOTTER COORDINATES OF POINT (0420) X= P(J,1)-WMIN (0421) Y= P(J,2)-ZMIN (0422) X=X*UNITS/SCALE+W1 (0423) Y=Y*UNITS/SCALE+Z1 (0424) (0425) 121 IF(N(J,1).EQ.' $') GOTO 122 (0426) NEWFLT = .TRUE. (0427) 123 IF(N(J,1).EQ.' #') GOTO 124 (0428) 125 IF(N(J,1).EQ.' %') GOTO 126 (0429) (0430) C REAL STRAIN COEFFICIENTS (0431) PAR(1) = REAL(CHI) (0432) PAR(2) = AIMAG(CHI) (0433) PAR(3) = REAL(PSI) (0434) PAR(4) = AIMAG(PSI) (0435) C (0436) C READ GIVEN DISPLACEMENTS FROM FILE IFIL2 (I-FILE OF PROG. DACAP (0437) 43 IF(.NOT.LDISPL) GOTO 44 (0438) 41 READ(9,9001,END=42) X9,Y9 (0439) 9001 FORMAT(32X,2F8.4) (0440) 44 CONTINUE (0441) GOTO 113 (0442) 42 CONTINUE (0443) NODXY1 = .TRUE. (0444) C (0445) C CHECK IF POINT IS IN POLYGON (0446) 113 CONTINUE (0447) IF(N(J,5).EQ.'$$') GOTO 97 (0448) (0449) C (0450) C COMPUTE PRINCIPAL STRAINS (0451) CALL EVALU(RMAJOR,RMINOR,PHI,CHI,PSI) (0452) OMEGA = AIMAG(CHI) * 1.E-6 (0453) RMAJOR=RMAJOR*SCALEL (0454) RMINOR=RMINOR*SCALEL (0455) C (0456) C CHECK FIGURE SIZE (0457) 193 IF(LROSET.OR.LSHRAX) GOTO 194 (0458) IF(ABS(RMAJOR).GT.RMARG.OR.ABS(RMINOR).GT.RMARG) NOELPS=.TRUE. (0459) 194 CONTINUE (0460) C (0461) C COMPUTE THE COORDINATES AT THE ENDS OF EACH AXIS (0462) C OF THE STRAIN ELLIPSES (0463) C (0464) COSPHI=COS(PHI) (0465) SINPHI=SIN(PHI) (0466) RMAJC=RMAJOR*COSPHI (0467) RMAJS=RMAJOR*SINPHI (0468) RMINC=RMINOR*COSPHI (0469) RMINS=RMINOR*SINPHI (0470) X1=X+RMAJC (0471) Y1=Y+RMAJS (0472) X2=X-RMAJC (0473) Y2=Y-RMAJS (0474) X3=X-RMINS (0475) Y3=Y+RMINC (0476) X4=X+RMINS (0477) Y4=Y-RMINC (0478) C (0479) C COMPUTE THE CO-ORDINATES OF THE CORNERS OF THE SECTORS (0480) C (0481) OMEGA=OMEGA*SCALRO*100000. (0482) X5=X+RADIUS+DXID (0483) Y5=Y (0484) X6=X+RADIUS*COS(OMEGA) (0485) Y6=Y+RADIUS*SIN(OMEGA) (0486) X7=X5+DXID (0487) OMEGON = OMEGA * RHOGON (0488) PHIGON = PHI * RHOGON (0489) (0490) C COMPUTE COOORDINATES OF THE ENDS OF THE DISPLACEMENT VECTORS (0491) C (0492) C GIVEN DISPLACEMENTS (0493) 23 IF(.NOT.LDISPL.OR.NODXY1) GOTO 24 (0494) IF(ABS(X9).GT.RMARG.OR.ABS(Y9).GT.RMARG) NODXY1=.TRUE. (0495) X9 = X + X9/SCALDX*UNITS (0496) Y9 = Y + Y9/SCALDX*UNITS (0497) 24 CONTINUE (0498) (0499) C PREDICTED DISPLACEMENTS (0500) 11 IF(.NOT.LADISP) GOTO 12 (0501) C CHECK DISPLACEMENTS (0502) IF(ABS(DX).GT.RMARG.OR.ABS(DY).GT.RMARG) NODXY2=.TRUE. (0503) X8=X+DX (0504) Y8=Y+DY (0505) 12 CONTINUE (0506) C (0507) C (0508) C WRITE STAT. INTO THE OUTPUT-LIST (0509) WRITE(6,155)(N(J,I),I=1,4),P(J,1),P(J,2),X,Y,DX,DY,OMEGON, (0510) 1 PHIGON,RMAJOR,RMINOR (0511) 155 FORMAT(1H ,4A2,2(1X,F11.2),8(1X,F10.4)) (0512) IF(NOELPS)WRITE(6,156) (0513) 156 FORMAT(1H ,64X,'FIGURE PLOTTING SUPPRESSED'/) (0514) C (0515) C PLOT PRINCIPAL STRAIN AXES (0516) C (0517) IF(NOELPS)GOTO 83 (0518) CALL NEWPEN(ICOL4) (0519) IF(.NOT.LELLAX) GOTO 86 (0520) CALL PLOT(X1,Y1,3) (0521) (0522) C PLOT MAJOR PRINCIPAL STRAIN AXIS (SOLID/DASH LINES FOR POS./NEG. V (0523) (0524) IF(RMAJOR.LT.0.) CALL DASHP(X2,Y2,0.2,X1,Y1) (0525) IF(RMAJOR.LT.0.) CALL ARROW(X1,Y1,X2,Y2,0.12,4,-1) (0526) IF(RMAJOR.LT.0.) CALL ARROW(X2,Y2,X1,Y1,0.12,4,-1) (0527) (0528) IF(RMAJOR.GE.0.)CALL PLOT(X2,Y2,2) (0529) IF(RMAJOR.GE.0.)CALL ARROW(X1,Y1,X2,Y2,0.12,4,1) (0530) IF(RMAJOR.GE.0.)CALL ARROW(X2,Y2,X1,Y1,0.12,4,1) (0531) (0532) C PLOT MINOR PRINCIPAL STRAIN AXIS (SOLID/DASH LINES FOR POS./NEG. V (0533) (0534) CALL PLOT(X4,Y4,3) (0535) IF(RMINOR.LT.0.0)CALL DASHP(X3,Y3,0.2,X4,Y4) (0536) IF(RMINOR.LT.0.0)CALL ARROW(X3,Y3,X4,Y4,0.12,4,-1) (0537) IF(RMINOR.LT.0.0)CALL ARROW(X4,Y4,X3,Y3,0.12,4,-1) (0538) (0539) IF(RMINOR.GE.0.0)CALL PLOT(X3,Y3,2) (0540) IF(RMINOR.GE.0.0)CALL ARROW(X3,Y3,X4,Y4,0.12,4,1) (0541) IF(RMINOR.GE.0.0)CALL ARROW(X4,Y4,X3,Y3,0.12,4,1) (0542) 86 CONTINUE (0543) (0544) C PLOT AXIS OF MAX.SHEAR (0545) (0546) 90 IF(.NOT.LSHRAX) GOTO 91 (0547) NOSHR = .FALSE. (0548) SHRM = CABS(PSI) * SCALEL (0549) IF(SHRM.GT.RMARG) NOSHR = .TRUE. (0550) 93 IF(NOSHR) GOTO 94 (0551) PHI1 = PHI + PI/4. (0552) PHI2 = PHI - PI/4. (0553) COSPHI = COS(PHI1) (0554) SINPHI = SIN(PHI1) (0555) RMAJC = SHRM * COSPHI (0556) RMAJS = SHRM * SINPHI (0557) X21 = X + RMAJC (0558) Y21 = Y + RMAJS (0559) X22 = X + RMAJS (0560) Y22 = Y - RMAJC (0561) X23 = X - RMAJC (0562) Y23 = Y - RMAJS (0563) X24 = X - RMAJS (0564) Y24 = Y + RMAJC (0565) (0566) CALL PLOT(X21,Y21,3) (0567) ROS1 = ROSET(PHI1,PAR) (0568) IF(ROS1.GE.0.) CALL PLOT(X23,Y23,2) (0569) IF(ROS1.GE.0.) CALL ARROW(X21,Y21,X23,Y23,0.12,4,-2) (0570) IF(ROS1.GE.0.) CALL ARROW(X23,Y23,X21,Y21,0.12,4,-2) (0571) (0572) IF(ROS1.LT.0.) CALL DASHP(X23,Y23,0.2,X21,Y21) (0573) IF(ROS1.LT.0.) CALL ARROW(X23,Y23,X21,Y21,0.12,4,-2) (0574) IF(ROS1.LT.0.) CALL ARROW(X21,Y21,X23,Y23,0.12,4,-2) (0575) CALL PLOT(X22,Y22,3) (0576) ROS2 = ROSET(PHI2,PAR) (0577) IF(ROS2.GE.0.) CALL PLOT(X24,Y24,2) (0578) IF(ROS2.GE.0.) CALL ARROW(X22,Y22,X24,Y24,0.12,4,2) (0579) IF(ROS2.GE.0.) CALL ARROW(X24,Y24,X22,Y22,0.12,4,2) (0580) IF(ROS2.LT.0.) CALL DASHP(X24,Y24,0.2,X22,Y22) (0581) IF(ROS2.LT.0.) CALL ARROW(X24,Y24,X22,Y22,0.12,4,-2) (0582) IF(ROS2.LT.0.) CALL ARROW(X22,Y22,X24,Y24,0.12,4,-2) (0583) 91 CONTINUE (0584) 94 CONTINUE (0585) C (0586) C PLOT DILATION CIRCLE,STRAIN ELLIPSE,PEDAL CURVE OR SHEAR ROSETT (0587) C (0588) IF(LDILAT) CALL POLAR(X,Y,CIRC,PAR,5,0.,PI2,0.,0) (0589) IF(LELIPS) CALL PARAM(X,Y,ELIPS,PAR,5,0.,PI2,0.) (0590) IF(LPEDAL) CALL POLAR(X,Y,PEDAL,PAR,5,0.,PI2,0.,0) (0591) IF(LROSET.AND..NOT.NOSHR) (0592) 1 CALL POLAR(X,Y,ROSET,PAR,5,0.,PI2,0.,0) (0593) C (0594) C PLOT STAND.DEV. OF SELECTED STRAIN FIGURES (0595) (0596) 81 IF(.NOT.LCONFI) GOTO 82 (0597) CALL NEWPEN(ICOL2) (0598) IF(LDILAT) CALL POLAR(X,Y,CCIRC,PAR,5,0.,PI2,0.,1) (0599) IF(LROSET.AND..NOT.NOSHR) (0600) 1 CALL POLAR(X,Y,CROSET,PAR,5,0.,PI2,0.,1) (0601) IF(LPEDAL) CALL POLAR(X,Y,CPEDAL,PAR,5,0.,PI2,0.,1) (0602) CFACT = -CFACT (0603) IF(LDILAT) CALL POLAR(X,Y,CCIRC,PAR,5,0.,PI2,0.,1) (0604) IF(LROSET.AND..NOT.NOSHR) (0605) 1 CALL POLAR(X,Y,CROSET,PAR,5,0.,PI2,0.,1) (0606) IF(LPEDAL) CALL POLAR(X,Y,CPEDAL,PAR,5,0.,PI2,0.,1) (0607) CFACT = -CFACT (0608) (0609) C PLOT STAND.DEV. OF AVERAGE DIFF. ROTATION (0610) IF(.NOT.LROTAT) GOTO 82 (0611) IF(CCHIPS(2,2).LE.0.) CCHIPS(2,2)=0. (0612) DOMEGA = SQRT(CCHIPS(2,2)) * SCALRO * 1.E-1 * CFACT (0613) OMEG1 = OMEGA + DOMEGA (0614) OMEG2 = OMEGA - DOMEGA (0615) CALL RECTA(XR,YR,X,Y,RAD1,RADIUS,OMEG1) (0616) CALL PLOT(XR(1),YR(1),3) (0617) CALL PLOT(XR(2),YR(2),2) (0618) RAD(1) = RADIUS+0.03 (0619) CALL RECTA(XR,YR,X,Y,RAD1,RADIUS,OMEG2) (0620) CALL POLAR(X,Y,CIRC,RAD,5,OMEG2,OMEG1,0.,1) (0621) CALL PLOT(XR(1),YR(1),3) (0622) CALL PLOT(XR(2),YR(2),2) (0623) 82 CONTINUE (0624) (0625) C PLOT STAND.DEV. ONLY (0626) (0627) 311 IF(.NOT.LCONF0) GOTO 312 (0628) PAR(1) = 0. (0629) PAR(2) = 0. (0630) PAR(3) = 0. (0631) PAR(4) = 0. (0632) CALL NEWPEN(ICOL2) (0633) IF(LDILAT) CALL POLAR(X,Y,CCIRC,PAR,5,0.,PI2,0.,1) (0634) IF(LROSET.AND..NOT.NOSHR) (0635) 1 CALL POLAR(X,Y,CROSET,PAR,5,0.,PI2,0.,1) (0636) IF(LPEDAL) CALL POLAR(X,Y,CPEDAL,PAR,5,0.,PI2,0.,1) (0637) 312 CONTINUE (0638) (0639) C PLOT STAND.DEV. OF AVERAGE DIFF. ROTATION (0640) 481 IF(.NOT.LROTAT) GOTO 482 (0641) IF(CCHIPS(2,2).LE.0.) CCHIPS(2,2)=0. (0642) DOMEGA = SQRT(CCHIPS(2,2)) * SCALRO * 1.E-1 * CFACT (0643) CALL RECTA(XR,YR,X,Y,RAD1,RADIUS,DOMEGA) (0644) CALL PLOT(XR(1),YR(1),3) (0645) CALL PLOT(XR(2),YR(2),2) (0646) RAD(1) = RADIUS+0.03 (0647) CALL POLAR(X,Y,CIRC,RAD,5,0.,-DOMEGA,DOMEGA,0.,1) (0648) CALL RECTA(XR,YR,X,Y,RAD1,RADIUS,-DOMEGA) (0649) CALL PLOT(XR(1),YR(1),3) (0650) CALL PLOT(XR(2),YR(2),2) (0651) 482 CONTINUE (0652) (0653) C PLOT CONFIDENCE REGIONS (0654) 891 IF(.NOT.LCONF) GOTO 892 (0655) CFACT = CONFAC (0656) CALL NEWPEN(ICOL1) (0657) IF(LDILAT) CALL POLAR(X,Y,CCIRC,PAR,5,0.,PI2,0.,1) (0658) IF(LSHRAX.AND..NOT.NOSHR) (0659) 1 CALL POLAR(X,Y,QROSET,PAR,5,0.,PI2,0.,1) (0660) 381 IF(.NOT.LROTAT) GOTO 382 (0661) IF(CCHIPS(2,2).LT.0.) CCHIPS(2,2)=0. (0662) DOMEGA = SQRT(CCHIPS(2,2)) * SCALRO * 1.E-1 * CFACT (0663) CALL RECTA(XR,YR,X,Y,RAD1,RADIUS,DOMEGA) (0664) CALL PLOT(XR(1),YR(1),3) (0665) CALL PLOT(XR(2),YR(2),2) (0666) RAD(1) = RADIUS+0.03 (0667) CALL POLAR(X,Y,CIRC,RAD,5,-DOMEGA,DOMEGA,0.,1) (0668) CALL RECTA(XR,YR,X,Y,RAD1,RADIUS,-DOMEGA) (0669) CALL PLOT(XR(1),YR(1),3) (0670) CALL PLOT(XR(2),YR(2),2) (0671) 382 CONTINUE (0672) CFACT=1. (0673) CALL NEWPEN(ICOL2) (0674) 892 CONTINUE (0675) (0676) C PLOT THE ARC OF THE SECTOR (0677) C (0678) 83 CONTINUE (0679) IF(.NOT.LROTAT) GOTO 88 (0680) IF(OMEGA.EQ.0.0)GOTO 88 (0681) CALL NEWPEN(ICOL3) (0682) IF(OMEGA.LT.0.0)GOTO 73 (0683) RAD(1) = RADIUS (0684) CALL POLAR(X,Y,CIRC,RAD,5,0.,OMEGA,0.,0) (0685) C (0686) C PLOT SOLID LINES FOR THE RADII OF THE SEGMENT OF THE CIRCLE (0687) C FOR POSITIVE VALUES OF OMEGA AND DRAW THE SEGMENT OF THE CIRCLE (0688) C (0689) CALL PLOT(X,Y,3) (0690) CALL PLOT(X5,Y5,2) (0691) CALL PLOT(X,Y,3) (0692) CALL PLOT(X6,Y6,2) (0693) GOTO 88 (0694) (0695) 73 CONTINUE (0696) RAD(1) = RADIUS (0697) CALL POLAR(X,Y,CIRC,RAD,5,OMEGA,0.,0.,0) (0698) C (0699) C PLOT DASH LINES FOR THE RADII OF THE SEGMENT OF THE CIRCLE (0700) C FOR NEGATIVE VALUES OF OMEGA AND DRAW THE SEGMENT OF THE CIRCLE (0701) C (0702) CALL PLOT(X,Y,3) (0703) CALL DASHP(X,Y,0.2,X5,Y5) (0704) CALL PLOT(X,Y,3) (0705) CALL DASHP(X,Y,0.2,X6,Y6) (0706) 88 CONTINUE (0707) (0708) C PLOT DISPLACEMENT VECTORS: (0709) C (0710) C PLOT GIVEN DISPLACEMENTS (0711) 53 IF(.NOT.LDISPL.OR.NODXY1) GOTO 54 (0712) CALL NEWPEN(ICOL2) (0713) CALL PLOT(X,Y,3) (0714) CALL PLOT(X9,Y9,2) (0715) CALL ARROW(X,Y,X9,Y9,0.12,2,0) (0716) 54 CONTINUE (0717) (0718) C PLOT PREDICTED DISPLACEMENTS (0719) 27 IF(NODXY2.OR..NOT.LADISP)GOTO 28 (0720) CALL NEWPEN(ICOL1) (0721) CALL PLOT(X,Y,3) (0722) CALL PLOT(X8,Y8,2) (0723) CALL ARROW(X,Y,X8,Y8,0.12,1,0) (0724) 28 CONTINUE (0725) C (0726) C PLOT STATION NAMES BY CALLING SUBROUTINE 'SYMBOL' (0727) C (0728) IF(.NOT.LSTATN) GOTO 97 (0729) CALL NEWPEN(ICOL4) (0730) 51 DO 52 I=1,4 (0731) NSTAT(I) = N(J,I) (0732) 52 CONTINUE (0733) CALL SYMBOL(X7,Y,0.20,NSTAT,0.0,8) (0734) C (0735) C PLOT SYMBOL FOR STATIONS OR GRID POINTS (0736) 97 CONTINUE (0737) CALL NEWPEN(ICOL4) (0738) IF(N(J,1).NE.' ') CALL SYMBOL(X,Y,0.2,2,0.,-1) (0739) IF(N(J,1).EQ.' ') CALL SYMBOL(X,Y,0.2,1,0.,-1) (0740) GOTO 99 (0741) (0742) C PLOT FAULT LINES (0743) 122 CONTINUE (0744) IF(.NOT.LFAULT) GOTO 99 (0745) CALL NEWPEN(ICOL2) (0746) IF(NEWFLT) CALL PLOT(X,Y,3) (0747) CALL PLOT(X,Y,2) (0748) NEWFLT = .FALSE. (0749) GOTO 99 (0750) (0751) C PLOT RELATIVE BLOCK MOTION (0752) 124 CONTINUE (0753) IF(.NOT.LBLOCK) GOTO 99 (0754) CALL NEWPEN(ICOL2) (0755) X9 = X + DX (0756) Y9 = Y + DY (0757) CALL PLOT(X,Y,3) (0758) CALL PLOT(X9,Y9,2) (0759) CALL ARROW(X,Y,X9,Y9,0.3,2,0) (0760) GOTO 99 (0761) (0762) 126 CONTINUE (0763) IF(.NOT.LBLOCK) GOTO 99 (0764) CALL NEWPEN(ICOL2) (0765) X9 = X + DXID (0766) Y9 = Y + DXID (0767) NSTAT(1) = 'BL' (0768) NSTAT(2) = 'OC' (0769) NSTAT(3) = 'K#' (0770) NSTAT(4) = N(J,2) (0771) CALL SYMBOL(X,Y,0.01,1,0.,-1) (0772) CALL SYMBOL(X9,Y9,0.3,NSTAT,0.,8) (0773) GOTO 99 (0774) (0775) 99 CONTINUE (0776) C (0777) C (0778) C SUBROUTINE PLOT IS CALLED TO INDICATE THE END OF ALL PLOTTING (0779) C (0780) CALL NEWPEN(ICOL1) (0781) CALL PLOT(0.,0.,999) (0782) (0783) GOTO 9999 (0784) (0785) C ERROR MESSAGES (0786) 901 CONTINUE (0787) WRITE(1,1901) (0788) 1901 FORMAT('***FILE NOT OPEN***'/) (0789) GOTO 9999 (0790) (0791) C CLOSE FILES (0792) 9999 CONTINUE (0793) CALL CLOS$A(1) (0794) CALL TRNC$A(2) (0795) CALL CLOS$A(2) (0796) IF(LINPER) CALL CLOS$A(3) (0797) IF(LDISPL) CALL CLOS$A(5) (0798) (0799) CALL EXIT (0800) END A$READ I PARAMETER 0113S 0138 0231 0246 A$SAMF I PARAMETER 0113S 0138 0140 0231 0246 A$WRIT I PARAMETER 0113S 0140 ABS R EXTERNAL 000000 0458 0494 0502 AIMAG R EXTERNAL 000000 0432 0434 0452 ALFA1 R 021563 0152M 0155 0375A AMAX1 R EXTERNAL 000000 0314 0315 AMIN1 R EXTERNAL 000000 0312 0313 ARROW R EXTERNAL 000000 0525 0526 0529 0530 0536 0537 0540 0541 0569 0570 0573 0574 0578 0579 0581 0582 0715 0723 0759 CABS R EXTERNAL 000000 0548 CCHIPS R // 000000 0062S 0109S 0411M 0611M 0612A 0641M 0642A 0661M 0662A CCIRC R EXTERNAL 000000 0115S 0598A 0603A 0633A 0657A CFACT R // 000040 0109S 0117I 0602M 0607M 0612 0642 0655M 0662 0672M CHI C 021565 0078S 0411M 0431A 0432A 0451A 0452A CHI2 R /CONF/ 000000 0062S 0110S 0152M 0154A 0155 CIRC R EXTERNAL 000000 0115S 0588A 0620A 0647A 0667A 0684A 0697A CLOS$A L EXTERNAL 000000 0113S 0793 0795 0796 0797 CONFAC R 021571 0154M 0155 0655 COS R EXTERNAL 000000 0464 0484 0553 COSPHI R 021573 0464M 0466 0468 0553M 0555 CPEDAL R EXTERNAL 000000 0115S 0601A 0606A 0636A CROSET R EXTERNAL 000000 0115S 0599A 0604A 0634A DASHP R EXTERNAL 000000 0524 0535 0572 0580 0703 0705 DATAN D EXTERNAL 000000 0133 0134 DINT D EXTERNAL 000000 0236 0237 DOMEGA R 021605 0612M 0613 0614 0642M 0643A 0647A 0648 0662M 0663A 0667A 0668 DPER D 000030 0071S 0234M 0236 0237 DW R 021607 0332M 0333 0340 DX R 021611 0411M 0415M 0502A 0503 0509 0755 DXID R 000002 0117I 0482 0486 0765 0766 DY R 021613 0411M 0416M 0502A 0504 0509 0756 DZ R 021615 0334M 0335 0341 ELIPS R EXTERNAL 000000 0115S 0589A EVALU R EXTERNAL 000000 0451 EXIT R EXTERNAL 000000 0799 I I 021617 0233M 0236 0237 0239M 0241 0296M 0297 0300 0301 0306 0312 0313 0314 0315 0320 0331M 0391M 0393 0396 0397 0509M 0730M 0731 ICOL1 I 000024 0127I 0656A 0720A 0780A ICOL2 I 000025 0127I 0597A 0632A 0673A 0712A 0745A 0754A 0764A ICOL3 I 000026 0127I 0681A ICOL4 I 000027 0127I 0287A 0518A 0729A 0737A ICON I 021621 0278 IDIM I 021622 0152M 0155 IFIL2 I 000040 0055S 0246A IFILI I 000060 0055S 0138A IOPT I 021623 0186M 0187 IPEN I 021624 0392M 0393M 0398A J I 021625 0297M 0403M 0420 0421 0425 0427 0428 0447 0509 0731 0738 0739 0770 LADISP L 021627 0082S 0194M 0261 0368 0414 0500 0719 LBLOCK L 021630 0082S 0224M 0414 0753 0763 LCON L 021631 0082S 0210M 0279M LCONF L 021632 0082S 0216M 0373 0654 LCONF0 L 021633 0082S 0214M 0627 LCONFI L 021634 0082S 0212M 0596 LDILAT L 021635 0082S 0198M 0588 0598 0603 0633 0657 LDISPL L 021636 0082S 0192M 0245 0261 0437 0493 0711 0797 LELIPS L 021637 0082S 0202M 0589 LELLAX L 021640 0082S 0200M 0519 LFAULT L 021641 0082S 0222M 0744 LINPER L 021642 0082S 0218M 0230 0304 0796 LINPOL L EXTERNAL 000000 0082S 0305 LOPEN L 021643 0082S 0138M 0139 0140M 0141 0231M 0232 0246M 0247 LPEDAL L 021644 0082S 0208M 0590 0601 0606 0636 LPLTPR L 021645 0082S 0220M 0230 0390 LROSET L 021646 0082S 0206M 0457 0591 0599 0604 0634 LROTAT L 021647 0082S 0196M 0257 0363 0610 0640 0660 0679 LSHRAX L 021650 0082S 0204M 0457 0546 0658 LSTATN L 021651 0082S 0190M 0728 N I 000100 0055S 0297M 0306M 0425 0427 0428 0447 0509 0731 0738 0739 0770 NEWFLT L 021652 0082S 0402M 0426M 0746 0748M NEWPEN I EXTERNAL 000000 0287 0518 0597 0632 0656 0673 0681 0712 0720 0729 0737 0745 0754 0764 0780 NODXY1 L 021653 0082S 0405M 0443M 0493 0494M 0711 NODXY2 L 021654 0082S 0406M 0502M 0719 NOELPS L 021655 0082S 0404M 0458M 0512 0517 NORTH I EXTERNAL 000000 0387 NOSHR L 021656 0082S 0547M 0549M 0550 0591 0599 0604 0634 0658 NPER I 021657 0241M 0305A 0391 NS I 021660 0295M 0317M 0320M 0403 NSTAT I 005004 0055S 0731M 0733A 0767M 0768M 0769M 0770M 0772A NTITLE I 005010 0055S 0144M 0146 0357A 0358A NUMBER I EXTERNAL 000000 0360 0362 0365 0370 0375 OMEG1 R 021661 0613M 0615A 0620A OMEG2 R 021663 0614M 0619A 0620A OMEGA R 021665 0452M 0481M 0484A 0485A 0487 0613 0614 0680 0682 0684A 0697A OMEGON R 021667 0487M 0509 OPEN$A L EXTERNAL 000000 0113S 0140 0231 OPNP$A L EXTERNAL 000000 0113S 0138 0246 P R 005050 0062S 0300M 0301M 0312 0313 0314 0315 0420 0421 0509 PAR R 010770 0062S 0255M 0431M 0432M 0433M 0434M 0567A 0576A 0588A 0589A 0590A 0591A 0598A 0599A 0601A 0603A 0604A 0606A 0628M 0629M 0630M 0631M 0633A 0634A 0636A 0657A 0658A PARAM R EXTERNAL 000000 0589 PEDAL R EXTERNAL 000000 0115S 0590A PER D 011002 0071S 0236M 0237M 0305A 0396 0397 PHI R 021671 0451A 0464A 0465A 0488 0551 0552 PHI1 R 021673 0551M 0553A 0554A 0567A PHI2 R 021675 0552M 0576A PHIGON R 021677 0488M 0509 PI D 021701 0071S 0133M 0135 0551 0552 PI2 R 021705 0135M 0588A 0589A 0590A 0591A 0598A 0599A 0601A 0603A 0604A 0606A 0633A 0634A 0636A 0657A 0658A PLOT R EXTERNAL 000000 0290 0379 0382 0384 0398 0520 0528 0534 0539 0566 0568 0575 0577 0616 0617 0621 0622 0644 0645 0649 0650 0664 0665 0669 0670 0689 0690 0691 0692 0702 0704 0713 0714 0721 0722 0746 0747 0757 0758 0781 PLOTS R EXTERNAL 000000 0286 POLAR R EXTERNAL 000000 0588 0590 0591 0598 0599 0601 0603 0604 0606 0620 0633 0634 0636 0647 0657 0658 0667 0684 0697 PSI C 021707 0078S 0411M 0433A 0434A 0451A 0548A Q D 012442 0071S 0297M 0300 0301 0305A QROSET R EXTERNAL 000000 0115S 0658A RAD R 012452 0062S 0256M 0618M 0620A 0646M 0647A 0666M 0667A 0683M 0684A 0696M 0697A RAD1 R 021717 0267M 0615A 0619A 0643A 0648A 0663A 0668A RADIUS R 021721 0266M 0267 0270 0482 0484 0485 0615A 0618 0619A 0643A 0646 0648A 0663A 0666 0668A 0683 0696 REAL R EXTERNAL 000000 0431 0433 RECTA R EXTERNAL 000000 0615 0619 0643 0648 0663 0668 RHOGON D 021723 0071S 0134M 0487 0488 RMAJC R 021727 0466M 0470 0472 0555M 0557 0560 0561 0564 RMAJOR R 021731 0451A 0453M 0458A 0466 0467 0509 0524 0525 0526 0528 0529 0530 RMAJS R 021733 0467M 0471 0473 0556M 0558 0559 0562 0563 RMARG R 000004 0117I 0329 0330 0333 0335 0340 0341 0458 0494 0502 0549 RMINC R 021735 0468M 0475 0477 RMINOR R 021737 0451A 0454M 0458A 0468 0469 0509 0535 0536 0537 0539 0540 0541 RMINS R 021741 0469M 0474 0476 ROS1 R 021743 0567M 0568 0569 0570 0572 0573 0574 ROS2 R 021745 0576M 0577 0578 0579 0580 0581 0582 ROSET R EXTERNAL 000000 0115S 0567 0576 0591A SCALDX R 021747 0263M 0270 0370A 0387A 0415 0416 0495 0496 SCALE R 021751 0252M 0270 0333 0335 0342M 0343M 0347 0360A 0387A 0396 0397 0422 0423 SCALE1 R 021753 0340M 0342 0343 SCALE2 R 021755 0341M 0343 SCALEL R 021757 0254M 0255 0270 0362A 0387A 0453 0454 0548 SCALRO R 021761 0259M 0270 0365A 0481 0612 0642 0662 SHRM R 021763 0548M 0549 0555 0556 SIN R EXTERNAL 000000 0465 0485 0554 SINPHI R 021765 0465M 0467 0469 0554M 0556 SQRT R EXTERNAL 000000 0154 0612 0642 0662 SYMBOL R EXTERNAL 000000 0356 0357 0358 0359 0361 0364 0369 0374 0733 0738 0739 0771 0772 TNOUA R EXTERNAL 000000 0185 0251 0253 0258 0262 0265 TRNC$A L EXTERNAL 000000 0113S 0794 UNITS R 000006 0117I 0332 0334 0396 0397 0415 0416 0422 0423 0495 0496 W1 R 021767 0329M 0333 0396 0422 WM1 R 021771 0328M 0329 0340 0379A 0382A 0384A 0387A WM2 R 021773 0333M 0339 WMAX R 000012 0117I 0314M 0332 WMIN R 000010 0117I 0312M 0332 0396 0420 X R 021775 0396M 0398A 0420M 0422M 0470 0472 0474 0476 0482 0484 0495 0503 0509 0557 0559 0561 0563 0588A 0589A 0590A 0591A 0598A 0599A 0601A 0603A 0604A 0606A 0615A 0619A 0620A 0633A 0634A 0636A 0643A 0647A 0648A 0657A 0658A 0663A 0667A 0668A 0684A 0689A 0691A 0697A 0702A 0703A 0704A 0705A 0713A 0715A 0721A 0723A 0738A 0739A 0746A 0747A 0755 0757A 0759A 0765 0771A X1 R 021777 0470M 0520A 0524A 0525A 0526A 0529A 0530A X2 R 022001 0472M 0524A 0525A 0526A 0528A 0529A 0530A X21 R 022003 0557M 0566A 0569A 0570A 0572A 0573A 0574A X22 R 022005 0559M 0575A 0578A 0579A 0580A 0581A 0582A X23 R 022007 0561M 0568A 0569A 0570A 0572A 0573A 0574A X24 R 022011 0563M 0577A 0578A 0579A 0580A 0581A 0582A X3 R 022013 0474M 0535A 0536A 0537A 0539A 0540A 0541A X4 R 022015 0476M 0534A 0535A 0536A 0537A 0540A 0541A X5 R 022017 0482M 0486 0690A 0703A X6 R 022021 0484M 0692A 0705A X7 R 022023 0486M 0733A X8 R 022025 0503M 0722A 0723A X9 R 022027 0438M 0494A 0495M 0714A 0715A 0755M 0758A 0759A 0765M 0772A XMAX R 000014 0117I 0286A 0339 0340 XR R 012464 0062S 0615A 0616A 0617A 0619A 0621A 0622A 0643A 0644A 0645A 0648A 0649A 0650A 0663A 0664A 0665A 0668A 0669A 0670A Y R 022031 0397M 0398A 0421M 0423M 0471 0473 0475 0477 0483 0485 0496 0504 0509 0558 0560 0562 0564 0588A 0589A 0590A 0591A 0598A 0599A 0601A 0603A 0604A 0606A 0615A 0619A 0620A 0633A 0634A 0636A 0643A 0647A 0648A 0657A 0658A 0663A 0667A 0668A 0684A 0689A 0691A 0697A 0702A 0703A 0704A 0705A 0713A 0715A 0721A 0723A 0733A 0738A 0739A 0746A 0747A 0756 0757A 0759A 0766 0771A Y1 R 022033 0471M 0520A 0524A 0525A 0526A 0529A 0530A Y2 R 022035 0473M 0524A 0525A 0526A 0528A 0529A 0530A Y21 R 022037 0558M 0566A 0569A 0570A 0572A 0573A 0574A Y22 R 022041 0560M 0575A 0578A 0579A 0580A 0581A 0582A Y23 R 022043 0562M 0568A 0569A 0570A 0572A 0573A 0574A Y24 R 022045 0564M 0577A 0578A 0579A 0580A 0581A 0582A Y3 R 022047 0475M 0535A 0536A 0537A 0539A 0540A 0541A Y4 R 022051 0477M 0534A 0535A 0536A 0537A 0540A 0541A Y5 R 022053 0483M 0690A 0703A Y6 R 022055 0485M 0692A 0705A Y8 R 022057 0504M 0722A 0723A Y9 R 022061 0438M 0494A 0496M 0714A 0715A 0756M 0758A 0759A 0766M 0772A YMAX R 000016 0117I 0286A 0339 0341 YR R 012470 0062S 0615A 0616A 0617A 0619A 0621A 0622A 0643A 0644A 0645A 0648A 0649A 0650A 0663A 0664A 0665A 0668A 0669A 0670A Z1 R 022063 0330M 0335 0397 0423 ZM1 R 022065 0327M 0330 0341 0379A 0384A 0387A ZM2 R 022067 0335M 0339 0382A ZMAX R 000022 0117I 0315M 0334 ZMIN R 000020 0117I 0313M 0334 0397 0421 $1 015207 0339D $101 014035 0230D $102 014137 0230 0242D $103 014053 0233D $104 014124 0233 0238D $105 012571 0144 0145D $106 012604 0146 0147D $107 014055 0234D $108 014134 0234 0240D $109 015014 0304D $11 016750 0500D $110 015033 0304 0309D $111 013141 0162 0163D $112 012747 0152 0153D $113 016375 0441 0446D $12 017012 0500 0505D $121 016303 0425D $122 021332 0425 0743D $123 016312 0427D $124 021357 0427 0752D $125 016317 0428D $126 021424 0428 0762D $13 015145 0331D $14 015304 0331 0344D $155 017104 0509 0511D $156 017135 0512 0513D $1901 021521 0787 0788D $193 016433 0457D $194 016463 0457 0459D $1991 016022 0395D $2 015342 0339 0349D $202 014435 0270 0271D $204 014635 0280 0281D $22 015072 0296 0307 0316D $23 016673 0493D $24 016750 0493 0497D $25 014624 0278D $26 014704 0278 0283D $27 021206 0719D $28 021241 0719 0724D $291 016005 0390D $292 016137 0390 0400D $293 016010 0391D $294 016131 0391 0399D $301 015612 0363D $302 015656 0363 0366D $31 015656 0368D $311 020402 0627D $312 020475 0627 0637D $32 015717 0368 0371D $33 015717 0373D $34 015757 0373 0376D $341 014254 0257D $342 014314 0257 0260D $343 014314 0261D $344 014353 0261 0264D $35 015017 0305D $351 016213 0414D $352 016240 0414 0417D $36 015033 0305 0308D $37 014740 0297D $38 015102 0297 0319D $381 020672 0660D $382 021017 0660 0671D $39 014137 0245D $40 014166 0245 0248D $41 016347 0438D $415 016172 0411 0412D $42 016373 0438 0442D $43 016344 0437D $44 016372 0437 0440D $450 014771 0297 0298D $451 015321 0347 0348D $481 020475 0640D $482 020623 0640 0651D $500 013705 0184D 0226 $501 013747 0187 0190D $502 013752 0187 0192D $503 013755 0187 0194D $504 013760 0187 0196D $505 013763 0187 0198D $506 013766 0187 0200D $507 013771 0187 0202D $508 013774 0187 0204D $509 013777 0187 0206D $51 021246 0730D $510 014002 0187 0208D $511 014005 0187 0210D $5112 015120 0322 0323 0324D $512 014010 0187 0212D $513 014013 0187 0214D $514 014016 0187 0216D $515 014021 0187 0218D $516 014024 0187 0220D $517 014027 0187 0222D $518 014032 0187 0224D $52 021257 0730 0732D $53 021153 0711D $54 021206 0711 0716D $598 014034 0191 0193 0195 0197 0199 0201 0203 0205 0207 0209 0211 0213 0215 0217 0219 0221 0223 0225D $599 014035 0187 0189 0227D $612 013001 0155 0156D $615 015346 0350 0351D $701 014066 0234 0235D $73 021104 0682 0695D $81 020107 0596D $82 020402 0596 0610 0623D $83 021025 0517 0678D $86 017410 0519 0542D $88 021153 0679 0680 0693 0706D $891 020623 0654D $892 021025 0654 0674D $90 017410 0546D $9001 016363 0438 0439D $901 021515 0139 0141 0232 0247 0786D $91 020016 0546 0583D $93 017432 0550D $94 020016 0550 0584D $97 021275 0447 0728 0736D $98 016141 0403D $99 021477 0403 0740 0744 0749 0753 0760 0763 0773 0775D $9999 021537 0783 0789 0792D 0000 ERRORS [<.MAIN.>FTN-REV18.2] (0801) (0802) SUBROUTINE POLAR(XC,YC,FCT,PAR,NPAR,PHIB,PHIE,ORI,LINTYP) (0803) C (0804) C **************************************************************** (0805) C * * (0806) C * WRITTEN BY D.SCHNEIDER * (0807) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0808) C * WABERN, 1981 * (0809) C * * (0810) C **************************************************************** (0811) C (0812) C PLOTTING OF FUNCTIONS IN POLAR FORM (0813) (0814) INTEGER*2 (0815) I IPLT, /* PEN STATE CODE (0816) L LINTYP, (0817) N NPAR /* NUMBER OF PARAMETERS (0818) (0819) REAL*4 (0820) D DELPHI, /* ANGULAR INCREMENT FOR PLOTTING [RAD] (0821) F FCT, /* POLAR FUNCTION FCT(PHI,PAR) (0822) O ORI, /* ORIENTATION ANGLE OF FIGURE [RAD] (0823) P PAR(NPAR), /* PARAMETER VECTOR (0824) P PHI, /* ANGULAR PARAMETER OF FCT (0825) P PHIB,PHIE, /* LIMITS OF ARGUMENT PHI (0826) R R,RA, /* RADIUS (VALUE OF FCT) (0827) X XC,X, /* COORD. OF FIGURE ORIGINE / CURVE (0828) Y YC,Y /* COORD. OF FIGURE ORIGINE / CURVE (0829) (0830) DATA (0831) D DELPHI/0.08727/, (0832) D DPHI/0.04/ (0833) (0834) PHI = PHIB (0835) 1 DO 2 I=1,73 (0836) IF(PHI.GT.PHIE) PHI = PHIE (0837) R = FCT(PHI,PAR) (0838) RA = ABS(R) (0839) X = XC + RA*COS(PHI+ORI) (0840) Y = YC + RA*SIN(PHI+ORI) (0841) IPLT = 2 (0842) IF(I.EQ.1) IPLT = 3 (0843) (0844) C PLOT INETERRUPTED LINE FOR R<0. (0845) IF(R.LT.0.) IPLT = 2 + MOD(I,2) (0846) IF(LINTYP.EQ.1) IPLT=3 (0847) (0848) CALL PLOT(X,Y,IPLT) (0849) IF(PHI.EQ.PHIE) GOTO 4 (0850) (0851) C PLOT DASH LINE FOR LINTYP=1 (0852) 5 IF(LINTYP.NE.1) GOTO 6 (0853) IF(RA.LT.0.1) GOTO 6 (0854) PHI1 = PHI + DPHI/RA (0855) R = FCT(PHI1,PAR) (0856) RA = ABS(R) (0857) X = XC + RA*COS(PHI1+ORI) (0858) Y = YC + RA*SIN(PHI1+ORI) (0859) IPLT = 2 (0860) IF(R.LT.0.) IPLT=2+MOD(I,2) (0861) CALL PLOT(X,Y,IPLT) (0862) 6 CONTINUE (0863) (0864) PHI = PHI + DELPHI (0865) 2 CONTINUE (0866) (0867) 4 CONTINUE (0868) CALL PLOT(XC,YC,3) (0869) RETURN (0870) END ABS R EXTERNAL 000000 0838 0856 COS R EXTERNAL 000000 0839 0857 DELPHI R 000015 0819S 0830I 0864 DPHI R 000017 0830I 0854 FCT R ARGUMENT 000005 0802S 0819S 0837 0855 I I 000311 0835M 0842 0845 0860 IPLT I 000312 0814S 0841M 0842M 0845M 0846M 0848A 0859M 0860M 0861A LINTYP I ARGUMENT 000013 0802S 0814S 0846 0852 MOD I EXTERNAL 000000 0845 0860 ORI R ARGUMENT 000012 0802S 0819S 0839 0840 0857 0858 PAR R ARGUMENT 000006 0802S 0819S 0837A 0855A PHI R 000313 0819S 0834M 0836M 0837A 0839 0840 0849 0854 0864M PHI1 R 000315 0854M 0855A 0857 0858 PHIB R ARGUMENT 000010 0802S 0819S 0834 PHIE R ARGUMENT 000011 0802S 0819S 0836 0849 PLOT R EXTERNAL 000000 0848 0861 0868 R R 000317 0819S 0837M 0838A 0845 0855M 0856A 0860 RA R 000323 0819S 0838M 0839 0840 0853 0854 0856M 0857 0858 SIN R EXTERNAL 000000 0840 0858 X R 000325 0819S 0839M 0848A 0857M 0861A XC R ARGUMENT 000003 0802S 0819S 0839 0857 0868A Y R 000327 0819S 0840M 0848A 0858M 0861A YC R ARGUMENT 000004 0802S 0819S 0840 0858 0868A $1 000025 0835D $2 000271 0835 0865D $4 000277 0849 0867D $5 000151 0852D $6 000263 0852 0853 0862D 0000 ERRORS [FTN-REV18.2] (0871) (0872) SUBROUTINE PARAM(XC,YC,FCT,PAR,NPAR,PHIB,PHIE,ORI) (0873) C (0874) C **************************************************************** (0875) C * * (0876) C * WRITTEN BY D.SCHNEIDER * (0877) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0878) C * WABERN, 1981 * (0879) C * * (0880) C **************************************************************** (0881) C (0882) C PLOTTING OF FUNCTIONS IN PARAMETRIC FORM (0883) (0884) INTEGER*2 (0885) I IPLT, /* PEN STATE CODE (0886) N NPAR /* NUMBER OF PARAMETERS (0887) (0888) REAL*4 (0889) D DELPHI, /* ANGULAR INCREMENT FOR PLOTTING [RAD] (0890) O ORI, /* ORIENTATION ANGLE OF FIGURE [RAD] (0891) P PAR(NPAR), /* PARAMETER VECTOR (0892) P PHI, /* ANGULAR PARAMETER OF FCT (0893) P PHIB,PHIE, /* LIMITS OF ARGUMENT PHI (0894) X XC,X, /* COORD. OF FIGURE ORIGINE / CURVE (0895) Y YC,Y /* COORD. OF FIGURE ORIGINE / CURVE (0896) (0897) COMPLEX*8 (0898) F FCT /* POLAR FUNCTION FCT(PHI,PAR) (0899) (0900) DATA (0901) D DELPHI/0.08727/ (0902) (0903) PHI = PHIB (0904) 1 DO 2 I=1,73 (0905) IF(PHI.GT.PHIE) PHI = PHIE (0906) X = XC + REAL(FCT(PHI,PAR)) (0907) Y = YC + AIMAG(FCT(PHI,PAR)) (0908) IPLT = 2 (0909) IF(I.EQ.1) IPLT = 3 (0910) (0911) CALL PLOT(X,Y,IPLT) (0912) IF(PHI.EQ.PHIE) GOTO 4 (0913) PHI = PHI + DELPHI (0914) 2 CONTINUE (0915) (0916) 4 CONTINUE (0917) CALL PLOT(XC,YC,3) (0918) RETURN (0919) END AIMAG R EXTERNAL 000000 0907 DELPHI R 000014 0888S 0900I 0913 FCT C ARGUMENT 000005 0872S 0897S 0906 0907 I I 000142 0904M 0909 IPLT I 000143 0884S 0908M 0909M 0911A PAR R ARGUMENT 000006 0872S 0888S 0906A 0907A PHI R 000144 0888S 0903M 0905M 0906A 0907A 0912 0913M PHIB R ARGUMENT 000010 0872S 0888S 0903 PHIE R ARGUMENT 000011 0872S 0888S 0905 0912 PLOT R EXTERNAL 000000 0911 0917 REAL R EXTERNAL 000000 0906 X R 000146 0888S 0906M 0911A XC R ARGUMENT 000003 0872S 0888S 0906 0917A Y R 000150 0888S 0907M 0911A YC R ARGUMENT 000004 0872S 0888S 0907 0917A $1 000022 0904D $2 000116 0904 0914D $4 000124 0912 0916D 0000 ERRORS [FTN-REV18.2] (0920) (0921) REAL*4 FUNCTION PEDAL(PHI,PAR) (0922) C (0923) C **************************************************************** (0924) C * * (0925) C * WRITTEN BY D.SCHNEIDER * (0926) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0927) C * WABERN, 1981 * (0928) C * * (0929) C **************************************************************** (0930) C (0931) C RADIAL DISTANCE OF STRAIN PEDAL CURVE (FOR PLOTTING ROUTINE POLAR) (0932) (0933) REAL*4 (0934) P PAR(5), /* PARAMETER VECTOR (0935) P PHI, /* ANGULAR ARGUMENT [RAD] (0936) S SCALEP /* SCALE FACTOR (0937) (0938) COMPLEX*8 (0939) C C, (0940) C CHI, (0941) P PSI (0942) (0943) (0944) C = CMPLX(COS(PHI),SIN(PHI)) (0945) CHI = CMPLX(PAR(1),PAR(2)) (0946) PSI = CMPLX(PAR(3),PAR(4)) (0947) SCALEP = PAR(5) (0948) (0949) PEDAL = REAL(CHI + PSI * CONJG(C) **2 ) * SCALEP (0950) RETURN (0951) END C C 000110 0938S 0944M 0949A CHI C 000120 0938S 0945M 0949 CMPLX C EXTERNAL 000000 0944 0945 0946 CONJG C EXTERNAL 000000 0949 COS R EXTERNAL 000000 0944 PAR R ARGUMENT 000004 0921S 0933S 0945A 0946A 0947 PEDAL R 000124 0921S 0949M PHI R ARGUMENT 000003 0921S 0933S 0944A PSI C 000126 0938S 0946M 0949 REAL R EXTERNAL 000000 0949 SCALEP R 000136 0933S 0947M 0949 SIN R EXTERNAL 000000 0944 0000 ERRORS [FTN-REV18.2] (0952) (0953) COMPLEX*8 FUNCTION ELIPS(PHI,PAR) (0954) C (0955) C **************************************************************** (0956) C * * (0957) C * WRITTEN BY D.SCHNEIDER * (0958) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0959) C * WABERN, 1981 * (0960) C * * (0961) C **************************************************************** (0962) C (0963) C COMPLEX EQUATION OF AN ELLIPSE IN PARAMETRIC FORM (0964) (0965) REAL*4 (0966) P PAR(5), /* PARAMETER VECTOR (0967) P PHI /* ANGULAR ARGUMENT [RAD] (0968) (0969) COMPLEX*8 (0970) C C, (0971) C CHI, (0972) P PSI (0973) (0974) C = CMPLX(COS(PHI),SIN(PHI)) (0975) CHI = CMPLX(PAR(1),PAR(2)) (0976) PSI = CMPLX(PAR(3),PAR(4)) (0977) SCALEP = PAR(5) (0978) (0979) ELIPS = (REAL(CHI) * C + PSI * CONJG(C)) * SCALEP (0980) RETURN (0981) END C C 000114 0969S 0974M 0979A CHI C 000124 0969S 0975M 0979A CMPLX C EXTERNAL 000000 0974 0975 0976 CONJG C EXTERNAL 000000 0979 COS R EXTERNAL 000000 0974 ELIPS C 000130 0953S 0979M PAR R ARGUMENT 000004 0953S 0965S 0975A 0976A 0977 PHI R ARGUMENT 000003 0953S 0965S 0974A PSI C 000134 0969S 0976M 0979 REAL R EXTERNAL 000000 0979 SCALEP R 000144 0977M 0979 SIN R EXTERNAL 000000 0974 0000 ERRORS [FTN-REV18.2] (0982) (0983) REAL*4 FUNCTION ROSET(PHI,PAR) (0984) C (0985) C **************************************************************** (0986) C * * (0987) C * WRITTEN BY D.SCHNEIDER * (0988) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0989) C * WABERN, 1981 * (0990) C * * (0991) C **************************************************************** (0992) C (0993) C RADIAL DISTANCE OF ROSETTE CURVE (FOR PLOTTING ROUTINE POLAR) (0994) (0995) REAL*4 (0996) P PAR(5), (0997) P PHI, (0998) S SCALE (0999) (1000) COMPLEX*8 (1001) C C, (1002) C CHI, (1003) P PSI (1004) (1005) C = CMPLX(COS(PHI),SIN(PHI)) (1006) CHI = CMPLX(PAR(1),PAR(2)) (1007) PSI = CMPLX(PAR(3),PAR(4)) (1008) SCALE = PAR(5) (1009) ROSET = AIMAG(PSI*CONJG(C)**2)*SCALE (1010) RETURN (1011) END AIMAG R EXTERNAL 000000 1009 C C 000106 1000S 1005M 1009A CHI C 000116 1000S 1006M CMPLX C EXTERNAL 000000 1005 1006 1007 CONJG C EXTERNAL 000000 1009 COS R EXTERNAL 000000 1005 PAR R ARGUMENT 000004 0983S 0995S 1006A 1007A 1008 PHI R ARGUMENT 000003 0983S 0995S 1005A PSI C 000122 1000S 1007M 1009 ROSET R 000132 0983S 1009M SCALE R 000134 0995S 1008M 1009 SIN R EXTERNAL 000000 1005 0000 ERRORS [FTN-REV18.2] (1012) (1013) REAL*4 FUNCTION CIRC(PHI,PAR) (1014) C (1015) C **************************************************************** (1016) C * * (1017) C * WRITTEN BY D.SCHNEIDER * (1018) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1019) C * WABERN, 1981 * (1020) C * * (1021) C **************************************************************** (1022) C (1023) C CONSTANT RADIUS (TRIVIAL FUNCTION FOR PLOTTING ROUTINE POLAR) (1024) (1025) REAL*4 (1026) P PAR(5), (1027) P PHI, (1028) R RADIUS, (1029) S SCALE (1030) (1031) RADIUS = PAR(1) (1032) SCALE = PAR(5) (1033) CIRC = RADIUS*SCALE (1034) RETURN (1035) END CIRC R 000023 1013S 1033M PAR R ARGUMENT 000004 1013S 1025S 1031 1032 RADIUS R 000025 1025S 1031M 1033 SCALE R 000027 1025S 1032M 1033 0000 ERRORS [FTN-REV18.2] (1036) (1037) SUBROUTINE EVALU(RMAJ,RMIN,THETA,CHI,PSI) (1038) C (1039) C **************************************************************** (1040) C * * (1041) C * WRITTEN BY D.SCHNEIDER * (1042) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1043) C * WABERN, 1981 * (1044) C * * (1045) C **************************************************************** (1046) C (1047) (1048) C LENGTH AND ORIENTATION OF SEMI-MAJOR AND MINOR AXES OF THE STRAIN (1049) C ELLIPSE FROM COMPLEX STRAIN COMPONENTS (1050) (1051) COMPLEX*8 (1052) C CHI, (1053) P PSI (1054) (1055) SQR = SQRT(REAL(PSI)**2 + AIMAG(PSI)**2) (1056) RMAJ = REAL(CHI) + SQR (1057) RMIN = REAL(CHI) - SQR (1058) 881 IF(SQR.LE.1.E-12)GOTO 882 (1059) THETA = ATAN2(AIMAG(PSI),REAL(PSI))/2. (1060) (1061) RETURN (1062) 882 THETA = 0. (1063) RETURN (1064) END AIMAG R EXTERNAL 000000 1055 1059 ATAN2 R EXTERNAL 000000 1059 CHI C ARGUMENT 000006 1037S 1051S 1056A 1057A PSI C ARGUMENT 000007 1037S 1051S 1055A 1059A REAL R EXTERNAL 000000 1055 1056 1057 1059 RMAJ R ARGUMENT 000003 1037S 1056M RMIN R ARGUMENT 000004 1037S 1057M SQR R 000123 1055M 1056 1057 1058 SQRT R EXTERNAL 000000 1055 THETA R ARGUMENT 000005 1037S 1059M 1062M $881 000060 1058D $882 000112 1058 1062D 0000 ERRORS [FTN-REV18.2] (1065) (1066) LOGICAL FUNCTION LINPOL(Q,P,N,ICODE) (1067) C (1068) C **************************************************************** (1069) C * * (1070) C * WRITTEN BY D.SCHNEIDER * (1071) C * UNIVERSITY OF NEW BRUNSWICK * (1072) C * FREDERICTON, 1980 * (1073) C * * (1074) C **************************************************************** (1075) C (1076) C DETERMINES WHETHER A POINT IS OUTSIDE,INSIDE,ON A VERTICE OR ON A (1077) C SIDE OF A POLYGON (1078) C (1079) C ICODE IN ON SIDE ON VERTICE OUT (1080) C 1 .TRUE. .FALSE. .FALSE. .FALSE. (1081) C 2 .TRUE. .TRUE. .TRUE. .FALSE. (1082) C (1083) C VARIABLES: P(X,Y): POLYGON VERTICES (1084) C Q(X,Y): TESTPOINTS, CR: RESULT CODE (1085) C A(I),B: AREA*2 OF TRIANGLE (1086) C XMIN,XMAX,YMIN,YMAX: COORD. OF CIRCUMRECTANGLE (1087) C CIN: NUMBER OF SAMEORIENTED TRIANGLES WHERE Q IS IN (1088) (1089) IMPLICIT REAL*8(A-H,O-Z) (1090) (1091) REAL*8 (1092) A A(100), (1093) A ARE2, (1094) C C,CIN,CR, (1095) P P(100,2), (1096) Q Q(2),Q1,Q2, (1097) X XMAX,XMIN, (1098) Y YMAX,YMIN (1099) (1100) LOGICAL LREP (1101) (1102) COMMON /INPOL/A,XMIN,XMAX,YMIN,YMAX,AREA,LREP (1103) (1104) DATA LREP/.FALSE./ (1105) (1106) C STATEMENT FUNCTION DEFINITION (1107) ARE2(X1,Y1,X2,Y2,X3,Y3)=- X1*Y2-X2*Y3-X3*Y1+Y1*X2+Y2*X3+Y3*X1 (1108) N1 = N-1 (1109) C (1110) C DETERMINE AREA (ORIENT.) OF TRIANGEL(1,I,I+1) AND CIRCUMRECTANGLE (1111) 31 IF(LREP) GOTO 32 (1112) XMIN=P(1,1) (1113) XMAX=P(1,1) (1114) YMIN=P(1,2) (1115) YMAX=P(1,2) (1116) AREA=0.D0 (1117) 3 DO 4 I=1,N1 (1118) XMIN=DMIN1(XMIN,P(I,1)) (1119) XMAX=DMAX1(XMAX,P(I,1)) (1120) YMIN=DMIN1(YMIN,P(I,2)) (1121) YMAX=DMAX1(YMAX,P(I,2)) (1122) A(I)=ARE2(P(1,1),P(1,2),P(I,1),P(I,2),P(I+1,1),P(I+1,2)) (1123) AREA=AREA+A(I) (1124) 4 CONTINUE (1125) AREA=AREA/2.D0 (1126) LREP = .TRUE. (1127) 32 CONTINUE (1128) C (1129) Q1 = DINT(Q(1)/1.D1) (1130) Q2 = DINT(Q(2)/1.D1) (1131) CIN=0.D0 (1132) CR=0.D0 (1133) C (1134) C IS POINT Q IN CIRCUMRECTANGLE (1135) IF(Q1.LT.XMIN.OR.Q1.GT.XMAX.OR.Q2.LT.YMIN.OR.Q2.GT.YMAX)GOTO 6 (1136) C (1137) C IS Q IN TRIANGLE 1,I,I+1 (1138) 7 DO 8 I=1,N1 (1139) B=ARE2(P(1,1),P(1,2),P(I,1),P(I,2),Q1,Q2) (1140) IF(DABS(A(I))-DABS(B).LT.0.D0)GOTO 8 (1141) C=1.D0 (1142) S = A(I)*B (1143) IF(DABS(S).LT.1.D-4)GOTO 20 (1144) 19 IF(S)8,20,21 (1145) 20 C=0.5D0 (1146) 21 I1=I+1 (1147) B=ARE2(P(I1,1),P(I1,2),P(1,1),P(1,2),Q1,Q2) (1148) IF(DABS(A(I))-DABS(B).LT.0.D0)GOTO 8 (1149) S = A(I)*B (1150) IF(DABS(S).LT.1.D-4) GOTO 23 (1151) 22 IF(S)8,23,24 (1152) 23 C=0.5D0 (1153) 24 B=ARE2(P(I,1),P(I,2),P(I1,1),P(I1,2),Q1,Q2) (1154) S = A(I)*B (1155) IF(DABS(S).LT.1.D-4) GOTO 26 (1156) 25 IF(S)8,26,27 (1157) C (1158) C SPECIAL CASE: AREA(TRIANGLE)=0 (1159) 26 IF(DABS(A(I)).GT.1.D-3)GOTO 29 (1160) S=(Q1-P(I,1))*(Q1-P(I1,1))+(Q2-P(I,2))*(Q2-P(I1,2)) (1161) IF(DABS(S).LT.1.D-4) GOTO 29 (1162) IF(S)30,29,8 (1163) 30 C=1.D0 (1164) 29 CONTINUE (1165) CR = 2.D0*C + 1.D0 (1166) 5 GOTO 6 (1167) 27 CIN=CIN+DSIGN(C,A(I)*AREA) (1168) 8 CONTINUE (1169) CR=CIN (1170) 6 CONTINUE (1171) C (1172) C SET LOGICAL VARIABLE (1173) LINPOL = .FALSE. (1174) IF(ICODE.EQ.1.AND.CR.EQ.1.D0) LINPOL = .TRUE. (1175) IF(ICODE.EQ.2.AND.CR.GT.0.D0) LINPOL = .TRUE. (1176) C WRITE(1,1001)CR (1177) 1001 FORMAT(F4.2) (1178) (1179) RETURN (1180) END A D /INPOL/ 000000 1091S 1102S 1122M 1123 1140A 1142 1148A 1149 1154 1159A 1167 ARE2 D 000010 1091S 1107I 1122 1139 1147 1153 AREA D /INPOL/ 000640 1102S 1116M 1123M 1125M 1167 B D 001056 1139M 1140A 1142 1147M 1148A 1149 1153M 1154 C D 001062 1091S 1141M 1145M 1152M 1163M 1165 1167A CIN D 001066 1091S 1131M 1167M 1169 CR D 001072 1091S 1132M 1165M 1169M 1174 1175 DABS D EXTERNAL 000000 1140 1143 1148 1150 1155 1159 1161 DINT D EXTERNAL 000000 1129 1130 DMAX1 D EXTERNAL 000000 1119 1121 DMIN1 D EXTERNAL 000000 1118 1120 DSIGN D EXTERNAL 000000 1167 I I 001132 1117M 1118 1119 1120 1121 1122 1123 1138M 1139 1140 1142 1146 1148 1149 1153 1154 1159 1160 1167 I1 I 001135 1146M 1147 1153 1160 ICODE I ARGUMENT 000006 1066S 1174 1175 LINPOL L 001141 1066S 1173M 1174M 1175M LREP L /INPOL/ 000644 1100S 1102S 1104I 1111 1126M N I ARGUMENT 000005 1066S 1108 N1 I 001142 1108M 1117 1138 P D ARGUMENT 000004 1066S 1091S 1112 1113 1114 1115 1118A 1119A 1120A 1121A 1122A 1139A 1147A 1153A 1160 Q D ARGUMENT 000003 1066S 1091S 1129 1130 Q1 D 001143 1091S 1129M 1135 1139A 1147A 1153A 1160 Q2 D 001147 1091S 1130M 1135 1139A 1147A 1153A 1160 S D 001153 1142M 1143A 1144 1149M 1150A 1151 1154M 1155A 1156 1160M 1161A 1162 X1 D 000000 1107 X2 D 000000 1107 X3 D 000000 1107 XMAX D /INPOL/ 000624 1091S 1102S 1113M 1119M 1135 XMIN D /INPOL/ 000620 1091S 1102S 1112M 1118M 1135 Y1 D 000000 1107 Y2 D 000000 1107 Y3 D 000000 1107 YMAX D /INPOL/ 000634 1091S 1102S 1115M 1121M 1135 YMIN D /INPOL/ 000630 1091S 1102S 1114M 1120M 1135 $1001 001042 1177D $19 000436 1144D $20 000445 1143 1144 1145D $21 000451 1144 1146D $22 000540 1151D $23 000547 1150 1151 1152D $24 000553 1151 1153D $25 000624 1156D $26 000633 1155 1156 1159D $27 000751 1156 1167D $29 000740 1159 1161 1162 1164D $3 000126 1117D $30 000734 1162 1163D $31 000102 1111D $32 000245 1111 1127D $4 000227 1117 1124D $5 000750 1166D $6 001004 1135 1166 1170D $7 000343 1138D $8 000772 1138 1140 1144 1148 1151 1156 1162 1168D 0000 ERRORS [FTN-REV18.2] (1181) (1182) REAL*4 FUNCTION CPEDAL(PHI,PAR) (1183) C (1184) C **************************************************************** (1185) C * * (1186) C * WRITTEN BY D.SCHNEIDER * (1187) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1188) C * WABERN, 1981 * (1189) C * * (1190) C **************************************************************** (1191) C (1192) (1193) C RADIAL DISTANCE OF BOUNDARY OF CONFIDENCE REGION OF (1194) C STRAIN PEDAL CURVE (1195) (1196) REAL*4 (1197) A AR(2,4), (1198) C CART(4,2), (1199) C CCHIPS(4,4), (1200) C CE(2,2), (1201) C CFACT, (1202) P PAR(5), (1203) P PHI, (1204) S SCALE (1205) (1206) COMPLEX*8 (1207) A A(1,2), (1208) C C (1209) (1210) COMMON CCHIPS,CFACT (1211) (1212) C = CMPLX(COS(PHI),SIN(PHI)) (1213) SCALE = PAR(5) (1214) A(1,1) = (1.,0.) (1215) A(1,2) = CONJG(C)**2 (1216) CALL MREAL(A,AR,1,2,2,4,1,2) (1217) CALL MTMLT(CART,CCHIPS,AR,4,4,2,4,4,2,2) (1218) CALL MTMLT(CE,AR,CART,2,4,2,2,4,2,0) (1219) IF(CE(1,1).LT.0.) CE(1,1)=0. (1220) SIG = SQRT(CE(1,1)) (1221) CPEDAL = PEDAL(PHI,PAR) + SIG*CFACT*SCALE (1222) RETURN (1223) END A C 000006 1206S 1214M 1215M 1216A AR R 000016 1196S 1216A 1217A 1218A C C 000232 1206S 1212M 1215A CART R 000036 1196S 1217A 1218A CCHIPS R // 000000 1196S 1210S 1217A CE R 000056 1196S 1218A 1219M 1220A CFACT R // 000040 1196S 1210S 1221 CMPLX C EXTERNAL 000000 1212 CONJG C EXTERNAL 000000 1215 COS R EXTERNAL 000000 1212 CPEDAL R 000242 1182S 1221M MREAL I EXTERNAL 000000 1216 MTMLT I EXTERNAL 000000 1217 1218 PAR R ARGUMENT 000004 1182S 1196S 1213 1221A PEDAL R EXTERNAL 000000 1221 PHI R ARGUMENT 000003 1182S 1196S 1212A 1221A SCALE R 000250 1196S 1213M 1221 SIG R 000252 1220M 1221 SIN R EXTERNAL 000000 1212 SQRT R EXTERNAL 000000 1220 0000 ERRORS [FTN-REV18.2] (1224) (1225) SUBROUTINE MTMLT(C,A,B,DIMN,DIMM,DIML,N,M,L,NT) (1226) C (1227) C **************************************************************** (1228) C * * (1229) C * WRITTEN BY D.SCHNEIDER * (1230) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1231) C * WABERN, 1981 * (1232) C * * (1233) C **************************************************************** (1234) C (1235) C% (1236) C% PRODUKT ZWEIER MATRIZEN IN ALLEN ERLAUBTEN TRANSPONIERTEN (1237) C% KOMBINATIONEN (REAL*4) (1238) C% NT=0) C(DIMN,DIML) = A(DIMN,DIMM) * B(DIMM,DIML) (1239) C% NT=1) C(DIMN,DIML) = A(DIMM,DIMN)T * B(DIMM,DIML) (1240) C% NT=2) C(DIMN,DIML) = A(DIMN,DIMM) * B(DIML,DIMM)T (1241) C% NT=3) C(DIMN,DIML) = A(DIMM,DIMN)T * B(DIML,DIMM)T (1242) C% N,M,L: AKTUELLE PARAMETER (1243) C% DIMN,DIMM,DIML: DIMENSIONEN IM HAUPTPROGRAMM (1244) (1245) C BUNDESAMT FUER LANDESTOPOGRAPHIE (1246) C D.SCHNEIDER (1247) C WABERN, 1981 (1248) (1249) C% (1250) INTEGER*2 N,M,L,DIMN,DIMM,DIML,NT (1251) INTEGER*2 I,J,K,NT1,NADA,NADB (1252) REAL*4 C,A,B (1253) DIMENSION C(DIMN,DIML),A(1),B(1) (1254) (1255) C TEST DER ARRAYDIMENSIONEN: (1256) 21 IF(N.LE.DIMN.AND.M.LE.DIMM.AND.L.LE.DIML)GOTO 22 (1257) WRITE(1,9901)N,DIMN,M,DIMM,L,DIML (1258) 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTMLT***'/ (1259) 1 'N = ',I4,' DIMN = ',I4/ (1260) 2 'M = ',I4,' DIMM = ',I4/ (1261) 3 'L = ',I4,' DIML = ',I4/) (1262) 22 CONTINUE (1263) (1264) NT1 = NT+1 (1265) 1 DO 2 I=1,N (1266) 3 DO 4 J=1,L (1267) C(I,J) = 0. (1268) 5 DO 6 K=1,M (1269) GOTO (100,101,102,103),NT1 (1270) (1271) 100 CONTINUE (1272) C A*B (1273) NADA =I+(K-1)*DIMN (1274) NADB =K+(J-1)*DIMM (1275) GOTO 104 (1276) (1277) 101 CONTINUE (1278) C AT*B (1279) NADA =K+(I-1)*DIMM (1280) NADB =K+(J-1)*DIMM (1281) GOTO 104 (1282) (1283) 102 CONTINUE (1284) C A*BT (1285) NADA =I+(K-1)*DIMN (1286) NADB =J+(K-1)*DIML (1287) GOTO 104 (1288) (1289) 103 CONTINUE (1290) C AT*BT (1291) NADA =K+(I-1)*DIMM (1292) NADB =J+(K-1)*DIML (1293) (1294) 104 CONTINUE (1295) (1296) C(I,J) = C(I,J)+A(NADA)*B(NADB) (1297) (1298) 6 CONTINUE (1299) 4 CONTINUE (1300) 2 CONTINUE (1301) RETURN (1302) END A R ARGUMENT 000004 1225S 1252S 1253S 1296 B R ARGUMENT 000005 1225S 1252S 1253S 1296 C R ARGUMENT 000003 1225S 1252S 1253S 1267M 1296M DIML I ARGUMENT 000010 1225S 1250S 1253S 1256 1257 1286 1292 DIMM I ARGUMENT 000007 1225S 1250S 1256 1257 1274 1279 1280 1291 DIMN I ARGUMENT 000006 1225S 1250S 1253S 1256 1257 1273 1285 I I 000404 1251S 1265M 1267 1273 1279 1285 1291 1296 J I 000410 1251S 1266M 1267 1274 1280 1286 1292 1296 K I 000411 1251S 1268M 1273 1274 1279 1280 1285 1286 1291 1292 L I ARGUMENT 000013 1225S 1250S 1256 1257 1266 M I ARGUMENT 000012 1225S 1250S 1256 1257 1268 N I ARGUMENT 000011 1225S 1250S 1256 1257 1265 NADA I 000414 1251S 1273M 1279M 1285M 1291M 1296 NADB I 000415 1251S 1274M 1280M 1286M 1292M 1296 NT I ARGUMENT 000014 1225S 1250S 1264 NT1 I 000416 1251S 1264M 1269 $1 000201 1265D $100 000231 1269 1271D $101 000246 1269 1277D $102 000263 1269 1283D $103 000300 1269 1289D $104 000314 1275 1281 1287 1294D $2 000373 1265 1300D $21 000015 1256D $22 000176 1256 1262D $3 000203 1266D $4 000365 1266 1299D $5 000220 1268D $6 000357 1268 1298D $9901 000076 1257 1258D 0000 ERRORS [FTN-REV18.2] (1303) (1304) SUBROUTINE MREAL(CPXA,A,MDIM,NDIM,M2DIM,N2DIM,M,N) (1305) C (1306) C **************************************************************** (1307) C * * (1308) C * WRITTEN BY D.SCHNEIDER * (1309) C * UNIVERSITY OF NEW BRUNSWICK * (1310) C * FREDERICTON, 1980 * (1311) C * * (1312) C **************************************************************** (1313) C (1314) COMPLEX*8 CPXA(MDIM,NDIM),CPXAIJ (1315) REAL*4 A(M2DIM,N2DIM) (1316) 1 DO 2 I=1,M (1317) I2=2*I (1318) I1=I2-1 (1319) 3 DO 4 J=1,N (1320) J2=2*J (1321) J1=J2-1 (1322) CPXAIJ=CPXA(I,J) (1323) A(I1,J1)=REAL(CPXAIJ) (1324) A(I1,J2)=-AIMAG(CPXAIJ) (1325) A(I2,J1)=AIMAG(CPXAIJ) (1326) A(I2,J2)=REAL(CPXAIJ) (1327) 4 CONTINUE (1328) 2 CONTINUE (1329) RETURN (1330) END A R ARGUMENT 000004 1304S 1315S 1323M 1324M 1325M 1326M AIMAG R EXTERNAL 000000 1324 1325 CPXA C ARGUMENT 000003 1304S 1314S 1322 CPXAIJ C 000146 1314S 1322M 1323A 1324A 1325A 1326A I I 000152 1316M 1317 1322 I1 I 000156 1318M 1323 1324 I2 I 000157 1317M 1318 1325 1326 J I 000160 1319M 1320 1322 J1 I 000161 1321M 1323 1325 J2 I 000162 1320M 1321 1324 1326 M I ARGUMENT 000011 1304S 1316 N I ARGUMENT 000012 1304S 1319 REAL R EXTERNAL 000000 1323 1326 $1 000013 1316D $2 000136 1316 1328D $3 000021 1319D $4 000130 1319 1327D 0000 ERRORS [FTN-REV18.2] (1331) (1332) REAL*4 FUNCTION CROSET(PHI,PAR) (1333) C (1334) C **************************************************************** (1335) C * * (1336) C * WRITTEN BY D.SCHNEIDER * (1337) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1338) C * WABERN, 1981 * (1339) C * * (1340) C **************************************************************** (1341) C (1342) (1343) C RADIAL DISTANCE OF BOUNDARY OF STANDARD COFIDENCE REGION OF (1344) C SHEAR IN A GIVEN DIRECTION (1345) (1346) REAL*4 (1347) A AR(2,4), (1348) C CART(4,2), (1349) C CCHIPS(4,4), (1350) C CE(2,2), (1351) C CFACT, (1352) P PAR(5), (1353) P PHI, (1354) S SCALE (1355) (1356) COMPLEX*8 (1357) A A(1,2), (1358) C C (1359) (1360) COMMON CCHIPS,CFACT (1361) (1362) C = CMPLX(COS(PHI),SIN(PHI)) (1363) SCALE = PAR(5) (1364) A(1,1) = (0.,0.) (1365) A(1,2) = CONJG(C)**2 (1366) CALL MREAL(A,AR,1,2,2,4,1,2) (1367) CALL MTMLT(CART,CCHIPS,AR,4,4,2,4,4,2,2) (1368) CALL MTMLT(CE,AR,CART,2,4,2,2,4,2,0) (1369) IF(CE(2,2).LT.0.) CE(2,2)=0. (1370) SIG = SQRT(CE(2,2)) (1371) CROSET = ROSET(PHI,PAR) + SIG*CFACT*SCALE (1372) RETURN (1373) END A C 000006 1356S 1364M 1365M 1366A AR R 000016 1346S 1366A 1367A 1368A C C 000232 1356S 1362M 1365A CART R 000036 1346S 1367A 1368A CCHIPS R // 000000 1346S 1360S 1367A CE R 000056 1346S 1368A 1369M 1370A CFACT R // 000040 1346S 1360S 1371 CMPLX C EXTERNAL 000000 1362 CONJG C EXTERNAL 000000 1365 COS R EXTERNAL 000000 1362 CROSET R 000242 1332S 1371M MREAL I EXTERNAL 000000 1366 MTMLT I EXTERNAL 000000 1367 1368 PAR R ARGUMENT 000004 1332S 1346S 1363 1371A PHI R ARGUMENT 000003 1332S 1346S 1362A 1371A ROSET R EXTERNAL 000000 1371 SCALE R 000250 1346S 1363M 1371 SIG R 000252 1370M 1371 SIN R EXTERNAL 000000 1362 SQRT R EXTERNAL 000000 1370 0000 ERRORS [FTN-REV18.2] (1374) (1375) REAL*4 FUNCTION CCIRC(PHI,PAR) (1376) C (1377) C **************************************************************** (1378) C * * (1379) C * WRITTEN BY D.SCHNEIDER * (1380) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1381) C * WABERN, 1981 * (1382) C * * (1383) C **************************************************************** (1384) C (1385) (1386) C RADIAL DISTANCE OF BOUNDARY OF CONFIDENCE REGION OF (1387) C DILATION CIRCLE (1388) (1389) REAL*4 (1390) C CCHIPS(4,4), (1391) C CFACT, (1392) P PAR(5), (1393) P PHI, (1394) S SCALE (1395) COMMON CCHIPS,CFACT (1396) (1397) SCALE = PAR(5) (1398) IF(CCHIPS(1,1).LT.0.) CCHIPS(1,1)=0. (1399) SIG = SQRT(CCHIPS(1,1)) (1400) CCIRC = CIRC(PHI,PAR) + SIG*CFACT*SCALE (1401) RETURN (1402) END CCHIPS R // 000000 1389S 1395S 1398M 1399A CCIRC R 000052 1375S 1400M CFACT R // 000040 1389S 1395S 1400 CIRC R EXTERNAL 000000 1400 PAR R ARGUMENT 000004 1375S 1389S 1397 1400A PHI R ARGUMENT 000003 1375S 1389S 1400A SCALE R 000056 1389S 1397M 1400 SIG R 000060 1399M 1400 SQRT R EXTERNAL 000000 1399 0000 ERRORS [FTN-REV18.2] (1403) (1404) SUBROUTINE DASHP(XE,YE,RINTER,XS,YS) (1405) C (1406) C **************************************************************** (1407) C * * (1408) C * WRITTEN BY D.SCHNEIDER * (1409) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1410) C * WABERN, 1981 * (1411) C * * (1412) C **************************************************************** (1413) C (1414) (1415) C PLOT DASHLINES (1416) (1417) INTEGER*2 (1418) I IMAX, (1419) I IPEN (1420) (1421) REAL*4 (1422) C COSA, (1423) D DX,DY, (1424) R RINTER, (1425) S S, (1426) S SINA, (1427) X X,XS,XE, (1428) Y Y,YS,YE (1429) (1430) DX = XE-XS (1431) DY = YE-YS (1432) S = SQRT(DX*DX + DY*DY) (1433) IMAX = S/RINTER (1434) 3 IF(IMAX.EQ.0) GOTO 4 (1435) SINA = DY/S (1436) COSA = DX/S (1437) X = XS (1438) Y = YS (1439) (1440) CALL PLOT(X,Y,3) (1441) 1 DO 2 I=1,IMAX (1442) X = X + COSA*RINTER (1443) Y = Y + SINA*RINTER (1444) IPEN = 2 + MOD(I+1,2) (1445) CALL PLOT(X,Y,IPEN) (1446) 2 CONTINUE (1447) (1448) IPEN = 2 + MOD(IMAX+2,2) (1449) CALL PLOT(XE,YE,IPEN) (1450) CALL SYMBOL(XE,YE,0.005,2,0.,-1) (1451) 4 CONTINUE (1452) CALL PLOT(XE,YE,2) (1453) RETURN (1454) END COSA R 000214 1421S 1436M 1442 DX R 000216 1421S 1430M 1432 1436 DY R 000220 1421S 1431M 1432 1435 I I 000222 1441M 1444 IMAX I 000223 1417S 1433M 1434 1441 1448 IPEN I 000224 1417S 1444M 1445A 1448M 1449A MOD I EXTERNAL 000000 1444 1448 PLOT R EXTERNAL 000000 1440 1445 1449 1452 RINTER R ARGUMENT 000005 1404S 1421S 1433 1442 1443 S R 000227 1421S 1432M 1433 1435 1436 SINA R 000231 1421S 1435M 1443 SQRT R EXTERNAL 000000 1432 SYMBOL R EXTERNAL 000000 1450 X R 000233 1421S 1437M 1440A 1442M 1445A XE R ARGUMENT 000003 1404S 1421S 1430 1449A 1450A 1452A XS R ARGUMENT 000006 1404S 1421S 1430 1437 Y R 000235 1421S 1438M 1440A 1443M 1445A YE R ARGUMENT 000004 1404S 1421S 1431 1449A 1450A 1452A YS R ARGUMENT 000007 1404S 1421S 1431 1438 $1 000104 1441D $2 000142 1441 1446D $3 000050 1434D $4 000202 1434 1451D 0000 ERRORS [FTN-REV18.2] (1455) (1456) REAL*4 FUNCTION QROSET(PHI,PAR) (1457) C (1458) C **************************************************************** (1459) C * * (1460) C * WRITTEN BY D.SCHNEIDER * (1461) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1462) C * WABERN, 1981 * (1463) C * * (1464) C **************************************************************** (1465) C (1466) C (1467) C RADIAL DISTANCE OF BOUNDARY OF CONFIDENCE REGION OF TOTAL SHEAR (1468) C (1469) (1470) REAL*4 (1471) C C(2,2),CI(2,2), (1472) C CHI2, (1473) C CCHIPS(4,4), (1474) C CFACT, (1475) Q Q(2,1),QTCI(1,2),QTCIQ(1,1), (1476) P PAR(5), (1477) P PHI, (1478) S SCALE (1479) (1480) COMMON CCHIPS,CFACT (1481) COMMON /CONF/ CHI2 (1482) (1483) SCALE = PAR(5) (1484) Q(1,1) = SIN(2.*PHI) (1485) Q(2,1) = -COS(2.*PHI) (1486) C(1,1) = CCHIPS(3,3) (1487) C(2,1) = CCHIPS(4,3) (1488) C(1,2) = CCHIPS(3,4) (1489) C(2,2) = CCHIPS(4,4) (1490) CALL MTINV(CI,C,2,2,ISING) (1491) CALL MTMLT(QTCI,Q,CI,1,2,2,1,2,2,1) (1492) CALL MTMLT(QTCIQ,QTCI,Q,1,2,1,1,2,1,0) (1493) IF(QTCIQ(1,1).LE.0) QTCIQ(1,1)=1.D-6 (1494) QROSET = SCALE * SQRT(CHI2/QTCIQ(1,1)) (1495) RETURN (1496) END C R 000006 1470S 1486M 1487M 1488M 1489M 1490A CCHIPS R // 000000 1470S 1480S 1486 1487 1488 1489 CHI2 R /CONF/ 000000 1470S 1481S 1494 CI R 000016 1470S 1490A 1491A COS R EXTERNAL 000000 1485 ISING I 000175 1490A MTINV I EXTERNAL 000000 1490 MTMLT I EXTERNAL 000000 1491 1492 PAR R ARGUMENT 000004 1456S 1470S 1483 PHI R ARGUMENT 000003 1456S 1470S 1484 1485 Q R 000026 1470S 1484M 1485M 1491A 1492A QROSET R 000176 1456S 1494M QTCI R 000032 1470S 1491A 1492A QTCIQ R 000036 1470S 1492A 1493M 1494 SCALE R 000202 1470S 1483M 1494 SIN R EXTERNAL 000000 1484 SQRT R EXTERNAL 000000 1494 0000 ERRORS [FTN-REV18.2] (1497) (1498) SUBROUTINE MTINV(AIN,A,DIMN,N,ISING) (1499) C (1500) C **************************************************************** (1501) C * * (1502) C * WRITTEN BY D.SCHNEIDER * (1503) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1504) C * WABERN, 1981 * (1505) C * * (1506) C **************************************************************** (1507) C (1508) C% (1509) C% INVERTIEREN DER MATRIX A(N,N) (REAL*4) (1510) C% NACH DER DIAGONAL STRATEGIE (1511) C% MAX.DIMENSION : N=200 (1512) C% (1513) C% N,M: AKTUELLE DIMENSIONEN VON A UND AIN (1514) C% DIMN,DIMM: DIMENSIONEN VON A UND AIN IM HAUPTPROGRAMM (1515) INTEGER*2 N,DIMN,ISING (1516) INTEGER*2 I,J,P (1517) REAL*4 A,AIN (1518) REAL*4 KZ (1519) DIMENSION A(DIMN,DIMN),AIN(DIMN,DIMN) (1520) DIMENSION KZ(200) (1521) (1522) C TEST DER ARRAYDIMENSIONEN: (1523) 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 (1524) WRITE(1,9901)N,DIMN,M,DIMM (1525) 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTINV***'/ (1526) 1 'N = ',I4,' DIMN = ',I4/ (1527) 2 'M = ',I4,' DIMM = ',I4/) (1528) 22 CONTINUE (1529) (1530) ISING = 0 (1531) 1 DO 2 I=1,N (1532) 3 DO4 J=1,N (1533) AIN(I,J)=A(I,J) (1534) 4 CONTINUE (1535) 2 CONTINUE (1536) (1537) C AUSTAUSCHVERFAHREN (1538) C (1539) 7 DO 8 P=1,N (1540) C TEST DER PIVOTS (1541) 31 IF((ABS(AIN(P,P)).GT.1.E-16.OR.ABS(AIN(P,P)).LT.1.E16).AND. (1542) 1 (ABS(AIN(P,P)).GT.ABS(A(P,P))*1.E-12)) GOTO 32 (1543) WRITE(1,2001)P,P,AIN(P,P) (1544) ISING=P (1545) 5 DO 6 I=1,N (1546) AIN(P,I)=0. (1547) AIN(I,P)=0. (1548) 6 CONTINUE (1549) AIN(P,P)=1.E30 (1550) GOTO 8 (1551) 32 CONTINUE (1552) (1553) C PIVOTELEMENT (1554) AIN(P,P)=1./AIN(P,P) (1555) (1556) C KELLERZEILE SETZEN (1557) 11 DO 12 I=1,N (1558) KZ(I)=-AIN(P,I)*AIN(P,P) (1559) 12 CONTINUE (1560) (1561) C UEBRIGE ELEMENTE BERECHNEN (1562) 13 DO 14 I=1,N (1563) 23 IF(I.EQ.P) GOTO 24 (1564) 15 DO 16 J=1,N (1565) 25 IF(J.EQ.P)GOTO 26 (1566) AIN(I,J)=KZ(J)*AIN(I,P)+AIN(I,J) (1567) 26 CONTINUE (1568) 16 CONTINUE (1569) 24 CONTINUE (1570) 14 CONTINUE (1571) (1572) C ELEMENTE IN DER PIVOTZEILE (1573) 17 DO 18 J=1,N (1574) 27 IF(J.EQ.P)GOTO 28 (1575) AIN(P,J)=-AIN(P,J)*AIN(P,P) (1576) 28 CONTINUE (1577) 18 CONTINUE (1578) (1579) C ELEMENTE IN DER PIVOTKOLONNE (1580) 19 DO 20 I=1,N (1581) 29 IF(I.EQ.P)GOTO 30 (1582) AIN(I,P)=AIN(I,P)*AIN(P,P) (1583) 30 CONTINUE (1584) 20 CONTINUE (1585) 8 CONTINUE (1586) RETURN (1587) 2001 FORMAT(1H ,'***PIVOT(',I3,',',I3,') = ',E12.4,' UND WIRD = 1E30 ', (1588) 1'GESETZT***'/) (1589) END A R ARGUMENT 000004 1498S 1517S 1519S 1533 1541A ABS R EXTERNAL 000000 1541 AIN R ARGUMENT 000003 1498S 1517S 1519S 1533M 1541A 1543 1546M 1547M 1549M 1554M 1558 1566M 1575M 1582M DIMM R 001675 1523 1524 DIMN I ARGUMENT 000005 1498S 1515S 1519S 1523 1524 I I 001677 1516S 1531M 1533 1545M 1546 1547 1557M 1558 1562M 1563 1566 1580M 1581 1582 ISING I ARGUMENT 000007 1498S 1515S 1530M 1544M J I 001704 1516S 1532M 1533 1564M 1565 1566 1573M 1574 1575 KZ R 000011 1518S 1520S 1558M 1566 M I 001707 1523 1524 N I ARGUMENT 000006 1498S 1515S 1523 1524 1531 1532 1539 1545 1557 1562 1564 1573 1580 P I 001710 1516S 1539M 1541 1543 1544 1546 1547 1549 1554 1558 1563 1565 1566 1574 1575 1581 1582 $1 000763 1531D $11 001305 1557D $12 001344 1557 1559D $13 001353 1562D $14 001447 1562 1570D $15 001361 1564D $16 001440 1564 1568D $17 001456 1573D $18 001527 1573 1577D $19 001536 1580D $2 001024 1531 1535D $20 001605 1580 1584D $2001 001625 1543 1587D $21 000631 1523D $22 000760 1523 1528D $23 001355 1563D $24 001447 1563 1569D $25 001363 1565D $26 001440 1565 1567D $27 001460 1574D $28 001527 1574 1576D $29 001540 1581D $3 000765 1532D $30 001605 1581 1583D $31 001035 1541D $32 001254 1541 1551D $4 001015 1532 1534D $5 001174 1545D $6 001227 1545 1548D $7 001033 1539D $8 001614 1539 1550 1585D $9901 000674 1524 1525D 0000 ERRORS [FTN-REV18.2] (1590) (1591) SUBROUTINE RECTA(X,Y,X0,Y0,RAD1,RAD2,ALFA) (1592) C (1593) C **************************************************************** (1594) C * * (1595) C * WRITTEN BY D.SCHNEIDER * (1596) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (1597) C * CH-3084 WABERN, 1981 * (1598) C * * (1599) C **************************************************************** (1600) C (1601) C RECTANGULAR COORDINATES OF SECTOR CORNERS (1602) (1603) REAL*4 (1604) A ALFA, (1605) R RAD1,RAD2, (1606) X X0, (1607) X X(2), (1608) Y Y0, (1609) Y Y(2) (1610) (1611) SALFA = SIN(ALFA) (1612) CALFA = COS(ALFA) (1613) X(1) = X0 + RAD1 * CALFA (1614) Y(1) = Y0 + RAD1 * SALFA (1615) X(2) = X0 + RAD2 * CALFA (1616) Y(2) = Y0 + RAD2 * SALFA (1617) (1618) RETURN (1619) END ALFA R ARGUMENT 000011 1591S 1603S 1611A 1612A CALFA R 000066 1612M 1613 1615 COS R EXTERNAL 000000 1612 RAD1 R ARGUMENT 000007 1591S 1603S 1613 1614 RAD2 R ARGUMENT 000010 1591S 1603S 1615 1616 SALFA R 000070 1611M 1614 1616 SIN R EXTERNAL 000000 1611 X R ARGUMENT 000003 1591S 1603S 1613M 1615M X0 R ARGUMENT 000005 1591S 1603S 1613 1615 Y R ARGUMENT 000004 1591S 1603S 1614M 1616M Y0 R ARGUMENT 000006 1591S 1603S 1614 1616 0000 ERRORS [FTN-REV18.2] (1620) (1621) (1622) SUBROUTINE ARROW(X1,Y1,X2,Y2,W,ICOL,ICODE) (1623) (1624) C PLOT ARROW TO STRAIGHT LINE (1625) (1626) INTEGER*2 (1627) I ICODE, /* 0: PLOT AT LINE END, +-1 OR +-2: PLOT WITHIN LINE (1628) I ICOL /* PEN COLOR STATE (1629) (1630) REAL*4 (1631) A A, /* LINE DIRECTION (1632) D DA, (1633) D DX,DY, (1634) W W, /* LENGTH [CM] OF ARROW (1635) X XA,YA, (1636) X X1,Y1, /* BEGIN OF LINE (1637) Y Y1,Y2 /* END OF LINE (1638) (1639) DATA (1640) D DA/0.4/ (1641) (1642) C INLINE FUNCTIONS (1643) XA(ICODE,W,A) = - ISIGN(1,ICODE) * W * COS(A) (1644) YA(ICODE,W,A) = - ISIGN(1,ICODE) * W * SIN(A) (1645) (1646) C LINE DIRECTION (1647) DX = X2 - X1 (1648) DY = Y2 - Y1 (1649) IF(ABS(DX).LT.W.AND.ABS(DY).LT.W) RETURN (1650) A = ATAN2(DY,DX) (1651) (1652) GOTO(1,2,3),(IABS(ICODE)+1) (1653) RETURN (1654) (1655) C PLOT ARROW AT LINE END (1656) 1 CONTINUE (1657) A = A + DA (1658) X3 = X2 + XA(ICODE,W,A) (1659) Y3 = Y2 + YA(ICODE,W,A) (1660) A = A - 2*DA (1661) X4 = X2 + XA(ICODE,W,A) (1662) Y4 = Y2 + YA(ICODE,W,A) (1663) GOTO 9 (1664) (1665) C PLOT ARROW WITHIN LINE (1666) 2 CONTINUE (1667) X2 = X1 + 0.85 * DX (1668) Y2 = Y1 + 0.85 * DY (1669) GOTO 1 (1670) (1671) C PLOT ARROW WITHIN LINE, PERPENDICULAR TO LINE (1672) 3 CONTINUE (1673) A = A + 1.507 (1674) GOTO 2 (1675) (1676) C EXECUTE PLOTTING (1677) 9 CONTINUE (1678) CALL NEWPEN(ICOL) (1679) CALL PLOT(X3,Y3,3) (1680) CALL PLOT(X2,Y2,2) (1681) CALL PLOT(X4,Y4,2) (1682) RETURN (1683) END A R 000330 1630S 1643A 1644A 1650M 1657M 1658A 1659A 1660M 1661A 1662A 1673M ABS R EXTERNAL 000000 1649 ATAN2 R EXTERNAL 000000 1650 COS R EXTERNAL 000000 1643 DA R 000013 1630S 1639I 1657 1660 DX R 000332 1630S 1647M 1649A 1650A 1667 DY R 000334 1630S 1648M 1649A 1650A 1668 IABS I EXTERNAL 000000 1652 ICODE I ARGUMENT 000011 1622S 1626S 1643 1644 1652 1658A 1659A 1661A 1662A ICOL I ARGUMENT 000010 1622S 1626S 1678A ISIGN I EXTERNAL 000000 1643 1644 NEWPEN I EXTERNAL 000000 1678 PLOT R EXTERNAL 000000 1679 1680 1681 SIN R EXTERNAL 000000 1644 W R ARGUMENT 000007 1622S 1630S 1643 1644 1649 1658A 1659A 1661A 1662A X1 R ARGUMENT 000003 1622S 1630S 1647 1667 X2 R ARGUMENT 000005 1622S 1647 1658 1661 1667M 1680A X3 R 000343 1658M 1679A X4 R 000345 1661M 1681A XA R 000015 1630S 1643I 1658 1661 Y1 R ARGUMENT 000004 1622S 1630S 1648 1668 Y2 R ARGUMENT 000006 1622S 1630S 1648 1659 1662 1668M 1680A Y3 R 000347 1659M 1679A Y4 R 000351 1662M 1681A YA R 000045 1630S 1644 1659 1662 $1 000152 1652 1656D 1669 $2 000250 1652 1666D 1674 $3 000271 1652 1672D $9 000300 1663 1677D 0000 ERRORS [FTN-REV18.2] (1684) (1685) SUBROUTINE NORTH(WM1,ZM1,SCALE,SCALDX,SCALEL) (1686) (1687) C PLOT SCALE BARS AND NORTH ARROW (1688) (1689) CALL NEWPEN(4) (1690) CALL PLOT(WM1,ZM1,-3) (1691) (1692) C NORTH ARROW (1693) CALL PLOT(2.,8.,3) (1694) CALL PLOT(1.8,6.,2) (1695) CALL PLOT(2.2,6.,2) (1696) CALL PLOT(2.,8.,2) (1697) CALL PLOT(1.8,4.3,3) (1698) CALL PLOT(1.8,5.,2) (1699) CALL PLOT(2.2,4.3,2) (1700) CALL PLOT(2.2,5.,2) (1701) (1702) C MAP SCALE BAR (1703) CALL PLOT(2.,2.3,3) (1704) CALL PLOT(2.,2.1,2) (1705) DS = 1.E5/SCALE (1706) S = 2.+DS (1707) 1 DO 2 I=1,5 (1708) CALL PLOT(S,2.1,2) (1709) CALL PLOT(S,2.2,2) (1710) CALL PLOT(S,2.1,3) (1711) S = S + DS (1712) 2 CONTINUE (1713) S = S - DS (1714) CALL PLOT(S,2.3,3) (1715) CALL SYMBOL(1.8,2.5,0.3,'0',0.,1) (1716) CALL SYMBOL(3.8,2.9,0.3,'MAP',0.,3) (1717) S = S - 0.5 (1718) CALL SYMBOL(S,2.5,0.3,'5KM',0.,3) (1719) (1720) C DISPLACEMENT SCALE (1721) CALL NEWPEN(1) (1722) CALL PLOT(2.,1.7,3) (1723) CALL PLOT(2.,1.9,2) (1724) DS = 1./SCALDX (1725) S = 2. + DS (1726) 3 DO 4 I=1,5 (1727) CALL PLOT(S,1.9,2) (1728) CALL PLOT(S,1.8,2) (1729) CALL PLOT(S,1.9,3) (1730) S = S + DS (1731) 4 CONTINUE (1732) S = S - DS (1733) CALL PLOT(S,1.7,3) (1734) CALL SYMBOL(1.8,1.2,0.3,'0',0.,1) (1735) CALL SYMBOL(3.8,0.8,0.3,'DISPL.',0.,6) (1736) S = S - 0.5 (1737) CALL SYMBOL(S,1.2,0.3,'5CM',0.,3) (1738) (1739) C STRAIN SCALE (1740) CALL NEWPEN(4) (1741) S1 = S+1.5 (1742) CALL PLOT(S1,1.7,3) (1743) CALL PLOT(S1,1.9,2) (1744) DS = SCALEL/5. (1745) S = S1 + DS (1746) 13 DO 14 I=1,5 (1747) CALL PLOT(S,1.9,2) (1748) CALL PLOT(S,1.8,2) (1749) CALL PLOT(S,1.9,3) (1750) S = S + DS (1751) 14 CONTINUE (1752) S = S - DS (1753) CALL PLOT(S,1.7,3) (1754) CALL SYMBOL(S1-0.2,1.2,0.3,'0',0.,1) (1755) CALL SYMBOL(S1+1.8,0.8,0.3,'STRAIN',0.,6) (1756) S = S - 0.5 (1757) CALL SYMBOL(S,1.2,0.3,'1PPM',0.,4) (1758) CALL PLOT(0.,0.,-3) (1759) RETURN (1760) END DS R 000546 1705M 1706 1711 1713 1724M 1725 1730 1732 1744M 1745 1750 1752 I I 000550 1707M 1726M 1746M NEWPEN I EXTERNAL 000000 1689 1721 1740 PLOT R EXTERNAL 000000 1690 1693 1694 1695 1696 1697 1698 1699 1700 1703 1704 1708 1709 1710 1714 1722 1723 1727 1728 1729 1733 1742 1743 1747 1748 1749 1753 1758 S R 000553 1706M 1708A 1709A 1710A 1711M 1713M 1714A 1717M 1718A 1725M 1727A 1728A 1729A 1730M 1732M 1733A 1736M 1737A 1741 1745M 1747A 1748A 1749A 1750M 1752M 1753A 1756M 1757A S1 R 000555 1741M 1742A 1743A 1745 1754 1755 SCALDX R ARGUMENT 000006 1685S 1724 SCALE R ARGUMENT 000005 1685S 1705 SCALEL R ARGUMENT 000007 1685S 1744 SYMBOL R EXTERNAL 000000 1715 1716 1718 1734 1735 1737 1754 1755 1757 WM1 R ARGUMENT 000003 1685S 1690A ZM1 R ARGUMENT 000004 1685S 1690A $1 000117 1707D $13 000415 1746D $14 000444 1746 1751D $2 000146 1707 1712D $3 000253 1726D $4 000302 1726 1731D 0000 ERRORS [FTN-REV18.2] (1761) $$$ C PROGRAM UTMELPL C THIS PROGRAM TRANSFORMS GEODETIC COORDINATES INTO UTM-COORDINATES INTEGER NET(4),STAT(4),ICM,IFILI(16) REAL*8 LATD,LATM,LATS,LOND,LONM,LONS,D,M,S,PHI,DLAM,SF,X0,PI,H 1,RAD,A,B,X,Y,CMRAD,Y0,X00,Y00,P0(3,4),DISTQ(3),P(2),DELTA LOGICAL LOPEN $INSERT SYSCOM>A$KEYS C INLINE FUNCTION RAD(D,M,S)=DSIGN(DABS(D)+(DABS(M)+DABS(S)/6.D1)/6.D1,D)*PI/18.D1 C FILES EROEFFNEN 801 LOPEN = OPNP$A('INPUTFILE',9,A$READ+A$SAMF,IFILI,32,1) IF(.NOT.LOPEN) GOTO 801 LOPEN = OPEN$A(A$WRIT+A$SAMF,'O_UTMELPL',9,2) IF(.NOT.LOPEN) GOTO 901 LOPEN = OPEN$A(A$WRIT+A$SAMF,'T$COORD',7,3) IF(.NOT.LOPEN) GOTO 901 PI=DATAN(1.D0)*4.D0 SF=0.9996D0 X0=5.D5 Y0=4.D6 A=6378206.4D0 B=6356583.8D0 DELTA = 1.D4 READ(5,1000)NUTM WRITE(6,2000)NUTM 1000 FORMAT(I2) 2000 FORMAT(1H1,'UTM-ZONE:',2X,I2/) ICM=-(180-(3+6*(NUTM-1))) CMRAD=ICM*PI/180.D0 WRITE(6,2003)ICM 2003 FORMAT(1H ,'CENTRAL MERIDIAN (DEG):',I4/) WRITE(6,2004) 2004 FORMAT(1H ,'NETWORK',3X,'STATION',9X,'LATITUDE',9X,'LONGITUDE',16X 1,'HEIGHT',11X,'X',16X,'Y'/) 1 DO 2 J=1,1000 READ(5,1001,END=999)NET,STAT,LATD,LATM,LATS,LOND,LONM,LONS,H WRITE(6,2001)NET,STAT,LATD,LATM,LATS,LOND,LONM,LONS,H 1001 FORMAT(8A2,2(2F4.0,F8.4),F8.4) 2001 FORMAT(1H ,2(4A2,2X),2(F5.0,2X,F3.0,2X,F8.4,2X),F9.4) PHI=RAD(LATD,LATM,LATS) DLAM=RAD(LOND,LONM,LONS)-CMRAD C CALL TMPLXY(PHI,DLAM,A,B,SF,X0,CMRAD,X,Y) C COMPUTE INVERSE FUNCTIONAL VALUES USING REGULA FALSI C APPROXIMATE VALUES X00 = DLAM*B + X0 Y00 = PHI*B P(1) = DLAM P(2) = PHI C WRITE(1,1991)X00,Y00,P P0(1,3) = X00 - DELTA P0(1,4) = Y00 - DELTA P0(2,3) = X00 + DELTA P0(2,4) = Y00 + DELTA C TRANSFORM APPROX. POINTS CALL TMXYPL(P0(1,3),P0(1,4),A,B,SF,X0,CMRAD,P0(1,2),P0(1,1)) P0(1,1) = P0(1,1) - CMRAD CALL TMXYPL(P0(2,3),P0(2,4),A,B,SF,X0,CMRAD,P0(2,2),P0(2,1)) P0(2,1) = P0(2,1) - CMRAD C REGULA FALSI 301 DO 302 I=1,20 C DRITTEN PUNKT INTERPOLIEREN 303 DO 304 J=1,2 J2=J+2 P0(3,J2)=P0(1,J2)-(P0(1,J)-P(J))/(P0(2,J)-P0(1,J))* 1(P0(2,J2)-P0(1,J2)) 304 CONTINUE C DRITTEN PUNKT ABBILDEN CALL TMXYPL(P0(3,3),P0(3,4),A,B,SF,X0,CMRAD,P0(3,2),P0(3,1)) P0(3,1) = P0(3,1) - CMRAD C ABBRUCHWERT TESTEN 305 DO 306 J=1,3 DISTQ(J)=(P0(J,1)-P(1))**2+(P0(J,2)-P(2))**2 C WRITE(1,1991) (P0(J,K),K=1,4),DISTQ(J) 1991 FORMAT(5E12.5) 306 CONTINUE 311 IF(DISTQ(3).LT.1.D-20)GOTO 312 C AUSSCHEIDEN DES ENTFERNTEREN PUNKTES 307 IF(DISTQ(1).LT.DISTQ(2)) GOTO 308 309 DO 310 J=1,4 310 P0(1,J)=P0(3,J) GOTO 302 308 CONTINUE 315 DO 316 J=1,4 316 P0(2,J)=P0(3,J) 302 CONTINUE WRITE(1,1902) WRITE(6,1902) 1902 FORMAT('***CRITERION FOR ITERATION TERMINATION NOT REACHED***'/) 312 CONTINUE X = P0(3,3) Y = P0(3,4) - Y0 WRITE(6,2002)X,Y WRITE(7,3001)STAT,X,Y,H 3001 FORMAT(2X,4A2,2F15.3,F10.3) 2002 FORMAT(1H+,T78,2(F15.4,2X)/) 2 CONTINUE GOTO 999 901 CONTINUE WRITE(1,1901) 1901 FORMAT('***FILE NOT OPEN***'//) 999 CONTINUE CALL CLOS$A(1) CALL TRNC$A(2) CALL CLOS$A(2) CALL TRNC$A(3) CALL CLOS$A(3) CALL EXIT END 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 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 $$$ $$$ C PROGRAM CRUSTRAIN (VERS.3.82) C ***************** C GENERAL METHOD FOR THE CRUSTAL STRAIN ANALYSIS FROM REPEATED C OBSERVATIONS OF HORIZONTAL GEODETIC NETWORKS (VERSION FOR C STRAIN APPROXIMATION IN SPACE AND TIME) C **************************************************************** C * * C * PROGRAM CRUSTRAIN (VERSION 3.82) * C * DEVELOPED BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981-82 * C * (C) D.SCHNEIDER, 1982 * C * * C **************************************************************** C C FILES: C FILE NAME FTN# PRIMOS# CONTENT C C IFILI 5 1 INPUT FILE (RESULTS FROM PROG. GEOPAN) C 'O_STRAIN' 6 2 OUTPUT-LIST C 'P_STRAIN' 7 3 PLOT-INFO (FOR PROG. STRAINPLOT) C 'T$STRAIN' 8 4 SCRATCH-FILE C 'P_PREDICT' 9 5 COEFF. AND COV. FOR PREDICTION C 'P_ISOLIN1' 10 6 PLOT-INFO (FOR PROG. ISOLIN) C 'P_ISOLIN2' 11 7 PLOT-INFO (FOR PROG. ISOLIN) INTEGER*2 I IDAT(3), /* DATE OF COMPUTATION I IDIM, I IFILI(16), /* NAME OF INPUT FILE I ISING, /* SINGULARITY CODE I ISPACE(4), /* OPTION CODE OF SPACE MODEL I ISTAT(2), /* OPTION CODE OF STATISTICAL MODEL I ITIM(15), I ITIME1(2), /* TIME OF COMPUTATION I ITOPT, /* # OF STATISTICAL TEST OPTION I IUSER(3), /* USER NAME M MANTIC, /* POWER OF ANTICONFORMAL POLYNOMIAL M MCONF, /* NUMBER OF TERMS IN CONFORMAL BASE M MCONF1, /* POWER OF CONFORMAL POLYNOMIAL N NAME(30,4), /* IDENTIFICATION OF POINTS N NAMFIX(4), /* IDENTIFICATION OF FIXED POINT N NELIM(13), /* VECTOR CONTAINING NO. OF CONSTRAINED PAR. N NPROJ1(20), /* TITLE OF PROJECT N NPROJ2(20), /* SUB-TITLE OF PROJECT N NONET(50), /* NUMBER OF OBSERVATIONS OF EACH NETWORK N NPER(5,2), /* BEGIN AND END ADDRESS OF BLOCK PERIMETER VERTICES N NUNET(50), /* NUMBER OF UNKNOWNS OF EACH NETWORK N NTIT(40), /* TITLE OF EACH NETWORK N NUIPAR(50,2) /* VECTOR OF NUISANCE PARAMETER CODES OF EACH NET REAL*4 A ALPHP, A APVARF, /* A POST. VARIANCE FACTOR A AZSHR, /* AZIMUTH OF PREDICTED SHEAR B BLOCA(5), /* AZIMUTH OF "ABSOLUTE" BLOCK MOTION F FACTK, /* CRIT. FACTOR FOR VAR. OF FOURIERCOEFF. G GRIDW, /* TEST GRID INTERVAL G GRIDL, /* TEST GRID INTERVAL [M] R RHOGON, P PBLOC(5), S SIG(20), /* STD.DEV. OF COEFF. S SIGCHI(2), /* STD.DEV. OF STRAIN S SIGPSI(2), /* STD.DEV. OF STRAIN S SIGDA(2), /* STD.DEV. OF DISPLACEMENT OR VELOCITY T TIME(50), /* OBSERVATION TIMES [YR] OF EACH EPOCH T TIME0, /* REFERENCE TIME T TIMINT, /* TIME INTERVAL OF PREDICTION T TIMSPA /* TOTAL TIME SPAN OF OBSERVATIONS REAL*8 A A(60,48), /* REAL DESIGN MATRIX OF APPROXIMATION A A2R(60,2), /* FIRST TWO COLUMNS OF "A" A ALIN, /* AZIMUTH OF FAULT LINE A ALFT, /* LEVEL OF SIGNIFICANCE A ALPH, /* LEVEL OF CONFIDENCE B BLCREF(2), /* BLOCK REFERENCE POINT B BLOCAZ(15), /* AZIMUTH OF REL. BLOCK MOTIONS OR VELOCITIES B B(60,40), /* DESIGN MATRIX OF NUISANCE PARAMETERS B BE(10,2), /* BEGIN AND END OF EPISODES C CCBLOC(2,2), /* COV. OF BLOC MOTION C CCHIPS(4,4), /* COV. OF STRAINS OR STRAIN RATES C CDA(2,2), /* COV. OF DISPLACEMENTS OR VELOCITIES C CRXON, C CX(240,240), /* COV. OF REAL COEFFICIENTS D D0(2), /* MEAN DISPLACEMENTS D DNEWTO, D DTIME, /* TIME DIFFERENCE BETWEEN OBS. EPOCHS D DTIMN, /* SCALED TIME DIFFERENCE F FAULT(15,4), /* N NEPOC(50,2), /* TITLES OF NETWORKS P P(30,2),P0(2), /* POSITIONS OF ALL STATIONS / MEAN POSITION P PER(50,2), /* BLOCK PERIMETER VETICES P PR(2), /* COORD. OF GRID POINTS S SCALP,SCALD, /* SCALE FACTOR OF POSITIONS/DISPLAC. S SCALR, /* RATIO OF DISPLACEMENT AND POSITION SCALES S SCALDI, S SCALD2, S SSHRAZ, /* STD.DEV. OF SHEAR AZ S STSHR, /* STD.DEV. OF TOTAL SHEAR S SXPER,SYPER, S SXYBLC(15,2), /* STD. DEV. OF RELATIVE BLOC DISPLACEMENT T TPRE, /* TIME OF PREDICTION T TPRED(30), /* TIMES OF PREDICTION V VARF(50), /* VAR.FACTOR OF NETWORKS X X1,X2, X XICHI, X XPER, /* COORD. OF BLOCK PERIMETER VERTICES X XR(240,1), /* REAL VECTOR OF ORIG. COEFFICIENTS X XYBLOC(15,2), Y Y1,Y2, Y YPER /* COORD. OF BLOCK PERIMETER VERTICES COMPLEX*8 C CBLOC, /* COMPLEX BLOC MOTION C CHI, /* CONFORMAL COMPLEX STRAIN COMPONENT C CPXA(30,24), /* COMPLEX DESIGN MATRIX OF APPROX. C CPXX(120,1), /* ORIGINAL COMPLEX COEFFICIENTS D DA(1,1), /* COMPLEX REL. DISPLACEMENT OR VELOCITY P PHI(1,12), /* COMPLEX SPACE BASE FUNCTION P PSI, /* COMPLEX STRAIN COMPONENT Z Z(30), /* COMPLEX POSITIONS OF STATIONS Z ZBLC(50), /* COMPLEX COORD. OF BLOCK PERIMETER VERTICES Z ZC, /* COMPLEX CONJUGATE POSITION Z ZG /* COMPLEX COORD. OF GRID POINT LOGICAL L LBLOCA, /* CONSTRAIN AZ. OF REL. BLOCK MOTION L LCOVAR, /* COMPUTE COVARIANCE OF PREDICTED QUANTITIES L LOPEN, /* FILE SUCCESSFULLY OPENED L LPRINT, /* PRINT INTERMEDIATE RESULTS L JANEIN, L LPREAN, /* PREANALYSIS ONLY L LPREDI, /* PREDICTION ONLY L LPLTG /* DO PLOT STRAIN AT GRID POINTS COMMON /COM0/ CPXA COMMON /COM2/ CX COMMON /COM10/ A,B,A2R COMMON /COM14/ NAME,VARF COMMON /EPISOD/ BE,NTPOLY COMMON /BLOCK/ ZBLC,NPER,BLOCA EXTERNAL DCNORM,DNORM $INSERT SYSCOM>A$KEYS DATA A AMASQ/-999./, /* VALUE FOR MASKING OUT IN ISOLINE PLOTTING B BLOCA/5*0./, F FAULT/60*0.D0/, I ISPACE/4*0/, L LPRINT/.FALSE./, M MDIM/12/, /* DIMENSION OF SPACE BASE N NDEDIM/130/, /* DIMENSION OF VECTOR OF ELIMINATED PARAMETERS N NELIM/13*0/, /* VECTOR CONTAINING ELIMINATION CODES FOR PARAM. N NPDIM/30/, /* MAX. NUMBER OF STATIONS N NP2DIM/60/, /* MAX. NUMBER OF STAT.COORD. N NP2HDI/90/, /* MAX. NUMBER OF STAT.COORD. + HEIGHTS N NUDIM/24/, /* DIMENSION OF COMPLEX VECTOR OF ORIG. COEFF. N NU2DIM/48/, /* DIMENSION OF REAL VECTOR OF ORIG. COEFF. N NCCDIM/120/, /* MAX. NUMBER OF TOTAL COMPLEX COEFF. N NRCDIM/240/, /* MAX. NUMBER OF TOTAL REAL COEFF. N N12DIM/90/, S SCALD/3.D-1/ RHOGON = 50.D0/DATAN(1.D0) C OPEN OUTPUT FILE LOPEN = OPEN$A(A$WRIT+A$SAMF,'O_STRAIN',8,2) IF(.NOT.LOPEN)GOTO 901 C WRITE TITLE WRITE(6,6900) WRITE(6,6901) WRITE(6,6000) WRITE(1,6000) 6000 FORMAT(1H ,'PROGRAM CRUSTRAIN (VERS.3.82)'/1H ,17(1H*)/ 1' (MULTI-EPOCH VERSION FOR STRAIN APPROX. IN SPACE AND TIME)'// 2' (C) D.SCHNEIDER, 1982'//) C WRITE USER, DATE AND TIME CALL TIMREG(IDAT,ITIME1,IUSER) WRITE(6,6991) IUSER,IDAT,ITIME1 6991 FORMAT(1H ,T100,'USER: ',3A2/T100,'DATE: ',A2,'.',A2,'.',A2/T100, 1 'TIME: ',I2,'.',I2/) C SELECTION OF APPROXIMATION OPTION WRITE(6,6061) WRITE(1,6061) 6061 FORMAT(1H ,'SELECTION OF APPROX. OPTION:'// 1 ' OPT.# OPTION:'/ 2 ' 0 PREANALYSIS ONLY'/ 3 ' 1 LEAST SQ. APPROX.'/ 4 ' 2 PREDICTION ONLY'//) CALL TNOUA('OPT.# : ',8) READ(1,*) IOPTAP WRITE(6,6062) IOPTAP 6062 FORMAT(' OPT.# : ',I2) LPREAN = (IOPTAP.EQ.0) LPREDI = (IOPTAP.EQ.2) C OPEN INPUT FILE 708 IF(LPREDI) GOTO 709 801 LOPEN = OPNP$A('INPUTFILE',9,A$READ+A$SAMF,IFILI,32,1) IF(.NOT.LOPEN)GOTO 801 WRITE(6,6023) IFILI 6023 FORMAT(1H /' INPUT-FILE: ',16A2) 709 CONTINUE C OPEN FILE FOR DATA TRANSFER TO PROGRAMM STRAINPLOT LOPEN = OPEN$A(A$WRIT+A$SAMF,'P_STRAIN',8,3) IF(.NOT.LOPEN) GOTO 901 C OPEN FILE FOR DATA TRANSFER TO PROGRAM ISOLINE LOPEN = OPEN$A(A$WRIT+A$SAMF,'P_ISOLIN1',9,6) IF(.NOT.LOPEN) GOTO 901 LOPEN = OPEN$A(A$WRIT+A$SAMF,'P_ISOLIN2',9,7) IF(.NOT.LOPEN) GOTO 901 C FILE FOR DATA STORAGE FOR PREDICTION AFTER THE APPROXIMATION IF(.NOT.LPREDI)LOPEN = OPEN$A(A$WRIT+A$SAMF,'P_PREDICT',9,5) IF(LPREDI) LOPEN = OPEN$A(A$READ+A$SAMF,'P_PREDICT',9,5) IF(.NOT.LOPEN) GOTO 901 C READ STORED COEFFICIENTS FOR PREDICTION 703 IF(.NOT.LPREDI) GOTO 704 READ(9,9091)(NPROJ1(I),I=1,20),(NPROJ2(I),I=1,20) READ(9,9087) ALPHP,XICHI,IDIM 9087 FORMAT(2F8.4,I4) READ(9,9092) NU,NU2,MCONF,MANTIC,NCC,NRC,MT,MBLOC,MCONF1,MDIM,NP1, 1 NNET,JJBLOC,NEPIS,NRC2,NTPOLY IF(MBLOC.NE.0) READ(9,9096) ((NPER(I,J),J=1,2),I=1,MBLOC) IF(MBLOC.NE.0) READ(9,9097) ((PER(I,J),J=1,2),I=1,JJBLOC) IF(MBLOC.NE.0) READ(9,9095) (BLOCA(I),I=1,MBLOC) READ(9,9093) ((NAME(I,J),J=1,4),I=1,NP1) READ(9,9095) (Z(I),I=1,NP1),(ZBLC(J),J=1,JJBLOC) READ(9,9095) (TIME(I),I=1,NNET),TIMSPA,TIME0,BE READ(9,9095) D0,P,P0,SCALP,SCALD,SCALR READ(9,9095) (CPXX(I,1),I=1,NCC) 181 DO 182 I=1,NRC2 READ(9,9095) (CX(I,J),J=I,NRC2) 182 CONTINUE CALL DMTSYM(CX,NRCDIM,NRC2) 704 CONTINUE C READ TITLE AND SUBTITLE OF PROJECT IF(.NOT.LPREDI) READ(5,1001) NPROJ1 CALL TNOUA('SUBTITLE OF PROJECT:',20) READ(1,1001)NPROJ2 1001 FORMAT(20A2) WRITE(6,6031)NPROJ1,NPROJ2 6031 FORMAT(T69,42(1H-)/T68,1H[,1X,'PROJECT:',T111,1H]/ 1 2(T68,1H[,1X,20A2,1X,1H]/),T69,42(1H-)//) WRITE(7,7003)NPROJ1,NPROJ2 WRITE(10,7003)NPROJ1,NPROJ2 7003 FORMAT(20A2,20A2) C OPEN SCRATCH FILE 701 IF(LPREDI) GOTO 702 LOPEN = OPEN$A(A$RDWR+A$SAMF,'T$STRAIN',8,4) IF(.NOT.LOPEN) GOTO 901 C DEFINE APPROXIMATION FUNCTION IN SPACE WRITE(6,6025) 6025 FORMAT(1H //' APPROXIMATION FUNCTION IN SPACE:'/1H ,32(1H-)/ 1' (MAX.NUM.: N.BLOCKS<=5, N.BLOCKS+N.CONF<=12, N.A.-CONF.<=12)'//) CALL TNOUA('POWER OF APPROX. POLYN.(BLOCKS/CONF./ANTICONF.): ',49) READ(1,*) MBLOC,MCONF,MANTIC WRITE(6,6013) MBLOC,MCONF,MANTIC 6013 FORMAT(1H /' POWER OF THE APPROXIMATION POLYNOMIALS : '/ 1 ' NUMB. OF BLOCKS: CONFORMAL TERMS: ANTICONF.TERMS:'/ 2 7X,I2,14X,I2,20X,I2//) WRITE(6,6057) 46 CONTINUE WRITE(1,6057) 6057 FORMAT(1H ,'CONSTRAIN PARAMETER # ? [#1: SCALE, #2: ORIENT.]:'/) READ(1,*) IPAR 43 IF(IPAR.EQ.0) GOTO 44 NELIM(IPAR) = IPAR WRITE(6,6050) IPAR 6050 FORMAT(1H /' CONSTRAINED PARAMETER # ',I2) 45 GOTO 46 44 CONTINUE C ENTER COORDINATES OF RIGID BLOCK PERIMETER POYGON VERTICES 95 IF(MBLOC.EQ.0) GOTO 96 WRITE(1,6071) WRITE(6,6071) 6071 FORMAT(1H //' MASKING FUNCTIONS: DEFINITION OF BLOCK PERIMETERS:' 1 /' INPUT OF POLYGON VERTICES: '//' BLOCK:',8X,'X[M]',5X,'Y[M]', 2 5X,'REF.POINT: X[M]',2X,'Y[M]',4X,'AZ.[GON]'//) JJ=1 37 DO 38 I=1,MBLOC NPER(I,1) = JJ WRITE(1,6072) I 6072 FORMAT(1H ,'BLOCK #',I1,': ') CALL TNOUA('COORD. OF BLOCK REFERENCE POINT : ',34) READ(1,*) BLCREF WRITE(1,1005) 1005 FORMAT('AZIMUTH OF REL. BLOCK MOTION TO BE CONSTRAINED TO:'/) CALL TNOUA('AZIMUTH [GON]: (NO CONSTR.:AZ=999):',35) READ(1,*) BLOCA(I) WRITE(6,6074) I,BLCREF,BLOCA(I) 6074 FORMAT(3X,I2,32X,2F9.0,F9.2/) BLOCA(I) = (100.-BLOCA(I))/RHOGON SXPER = 0.D0 SYPER = 0.D0 IF(BLOCA(I).GT.-6.283) NELIM(2*I+2) = 2*(MCONF+I) 39 DO 40 J=1,10 READ(1,*) XPER,YPER WRITE(6,6073) XPER,YPER 6073 FORMAT(12X,2F9.0/) PER(JJ,1) = XPER PER(JJ,2) = YPER 83 IF(XPER.EQ.PER(NPER(I,1),1).AND.YPER.EQ.PER(NPER(I,1),2) 1 .AND.J.NE.1) GOTO 84 SXPER = SXPER + XPER SYPER = SYPER + YPER JJ=JJ+1 40 CONTINUE 84 CONTINUE NPER(I,2)=JJ C BLOCK REFERENCE POINTS JJ=JJ+1 PER(JJ,1) = SXPER/(J-1) PER(JJ,2) = SYPER/(J-1) IF(BLCREF(1).NE.0.D0) PER(JJ,1) = BLCREF(1) IF(BLCREF(2).NE.0.D0) PER(JJ,2) = BLCREF(2) JJ=JJ+1 IF(JJ.GT.50)GOTO 902 38 CONTINUE JJBLOC = JJ 96 CONTINUE C NUMBER OF UNKNOWN COEFFICIENTS MCONF1 = MCONF MCONF = MBLOC + MCONF NU = MCONF + MANTIC C DEFINE APPROXIMATION FUNCTION IN TIME WRITE(6,6028) 6028 FORMAT(1H //' APPROXIMATION FUNCTION IN TIME:'/1H ,31(1H-)//) WRITE(1,6015) 6015 FORMAT(' SELECTION OF TIME FUNCTION: '/) CALL TNOUA('POWER OF TIME POLYN.: ,NUMBER OF EPISODES: ',43) CALL TNOUA(' NP+NE < 10',13) READ(1,*) NTPOLY,NEPIS MT = NTPOLY + NEPIS WRITE(6,6016) NTPOLY,NEPIS,MT 6016 FORMAT(1H ,'POWER OF THE TIME APPROX. POLYNOMIAL : ',T48,I2/ 1 ' NUMBER OF LINEAR EPISODES : ',T48,I2/ 2 ' TOTAL POWER OF GENERALIZED TIME POLYNOMIAL : ',T48,I2//) 91 IF(NEPIS.EQ.0) GOTO 92 WRITE(1,6026) WRITE(6,6026) 6026 FORMAT(1H /' DEFINITION OF LINEAR EPISODES :'/) 93 DO 94 I=1,NEPIS CALL TNOUA(' BEGIN, END OF EPISODE [YR] : ',30) READ(1,*) (BE(I,J),J=1,2) WRITE(6,6027) I,(BE(I,J),J=1,2) 6027 FORMAT(1H /' EPISODE # ',I2,' BEGIN : ',F8.3,' END : ',F8.3/) 94 CONTINUE 92 CONTINUE C SELECT REJECTION CRITERIA FOR FOURIER COEFFICIENTS 201 IF(LPREAN) GOTO 202 WRITE(6,6018) 6018 FORMAT(1H /' TEST OPTIONS:'/1H ,13(1H-)//) CALL TNOUA('LEVEL OF SIGNIFIC. FOR TEST OF FOURIER COEFF.[%]:',49) READ(1,*)ALFAT ALFT = ALFAT/200.D0 FACTK = 2.D0 * ALFT FACTK = DNEWTO(DCNORM,DNORM,ALFT,FACTK) WRITE(6,6019)ALFAT,FACTK WRITE(1,6019)ALFAT,FACTK 6019 FORMAT(1H ,'LEVEL OF SIGNIFIC. FOR TEST OF FOURIER COEFF.[%]:', 1 T55,F8.4/' VAR. FACTOR FOR TESTING FOURIER COEFF.: ',T55, 2 F8.4/) CALL TNOUA('LEVEL OF CONFIDENCE (CONF. REGIONS) [%]:',40) READ(1,*)ALPH WRITE(6,6081) ALPH 6081 FORMAT(1H ,'LEVEL OF CONFIDENCE [%] :',T55,F8.4//) ALPH = ALPH/100.D0 C TEST OPTIONS WRITE(6,6082) WRITE(1,6082) 6082 FORMAT(' TEST ON THE ORTHO-NORMAL COEFFICIENTS:'// 1 'OPT.# STATISTICS: TEST CRIT.: ADDITIONAL COMPUT.:'/ 2/' 0 NO REJECTION NONE'/ 3 ' 1 X(ON)**2 > VAR. A PRIORI VAR.FACT.'/ 4 ' -1 X(ON)**2 > VAR. A PRIORI NONE'/ 5 ' 2 X(ON)**2 > VAR. A POST. VAR.FACT. CHI-SQ.T.' 6/' -2 X(ON)**2 > VAR. A POST. VAR.FACT.'/ 7 ' 3 X(ON)**2 > VAR. A PRI/POST. VAR.FACT. CHI-SQ.T.' 8/' -3 X(ON)**2 > VAR. A POST.'//) CALL TNOUA('OPT.# : ',8) READ(1,*) ITOPT WRITE(6,6083) ITOPT 6083 FORMAT(1H ,' OPTION # : ',I4///) 645 IF(ITOPT.NE.-3) GOTO 646 CALL TNOUA('CRIT. VALUE FOR X(ON) TESTING',29) READ(1,*) CRXON 646 CONTINUE C OPTIONS OF STATISTICAL MODEL WRITE(6,6088) WRITE(6,6089) 6088 FORMAT(1H /' OPTIONS OF STATISTICAL MODEL:'/1X,29(1H-)//) CALL TNOUA('STATISTICAL OPTION:',19) WRITE(1,6089) 6089 FORMAT(1H /' OPT.# OPTION:'/ 1 ' VAR.FACT.: COV. MATRIX OF COEFF.:'/ 2 ' UNKNOWN KNOWN A PRIORI A POST.'/ 3/' A=0 B=0'/ 4 ' A=1 B=1'/) CALL TNOUA('OPT.#: A,B: ',12) READ(1,*)ISTAT WRITE(6,6087) ISTAT 6087 FORMAT(1H ,'A=',I2,4X,'B=',I2) C SELECT PLOTTING OPTIONS 202 CONTINUE 702 CONTINUE WRITE(6,6029) 6029 FORMAT(1H //' PLOTTING OPTIONS:'/1H ,17(1H-)//) WRITE(6,6204) WRITE(1,6204) 6204 FORMAT(1H ,'OPTIONAL PLOTTING OF ISOLINES:'// + ' (WITHOUT PLOTTING OF STRAIN FIGURES AT GRID POINTS!)'// 1 ' OPTION: OPTION #:'// 2 ' LINE OF EQUAL: STRAIN VALUE: ITS VARIANCE:'// 3 ' NO PLOTTING 0 0'/ 4 ' DILATION 1 -1'/ 5 ' AV. ROTATION 2 -2'/ 6 ' TOTAL SHEAR 3 -3'/ 7 ' SHEAR IN AZ. 4 -4'//) CALL TNOUA('OPT. # : ',9) READ(1,*) IISO WRITE(6,6206) IISO 6206 FORMAT(1H ,'OPTION # :',I3//) LPLTG = (IISO.EQ.0) 105 IF(IISO.EQ.0) GOTO 106 109 IF(IABS(IISO).NE.4) GOTO 110 CALL TNOUA('AZIMUTH IN WHICH SHEAR IS TO BE PREDICTED [GON]:',48) READ(1,*) AZSHR WRITE(6,6090) AZSHR 6090 FORMAT(1H ,'AZIMUTH OF PREDICTED SHEAR [GON]: ',F10.4//) AZSHR = (100.-AZSHR)/RHOGON 110 CONTINUE CALL TNOUA('LOWER/UPPER LIMIT OF SCALAR PLOT FUNCTION: ',43) READ(1,*) SLOW,SUP WRITE(6,6091) SLOW,SUP 6091 FORMAT(1H ,'LOWER/UPPER LIMIT OF SCALAR PLOT FUNCTION: ',2F10.4/ 1 //) 106 CONTINUE C DEFINE GRID OF PREDICTION IN SPACE AND TIME WRITE(6,6030) 6030 FORMAT(1H //' PREDICTION OPTIONS:'/1H ,19(1H-)//) WRITE(1,1004) 1004 FORMAT(1H // 1 ' PREDICTION IN TIME: AT REGUL.INTERV. AT FIXED TIMES'/ 2/' NO PREDICTION #0 # 0'/ 3 ' ACCUMULATED STRAIN #1 #-1'/ 4 ' STRAIN RATES #2 #-2'//) CALL TNOUA('OPT.# : ',8) READ (1,*) IPREDO CALL TNOUA('REFERENCE TIME [YR] : ',22) READ(1,*) TIME0 WRITE(6,6109) TIME0 6109 FORMAT(1H /' REFERENCE TIME [YR] : ',F9.3//) C PREDICTION IN SPACE WRITE(1,6086) WRITE(6,6086) 6086 FORMAT(1H / 1 ' PREDICTION IN SPACE: WITH PRINT: STORE ONLY:'// 2 ' AT ALL STATIONS # 1 # -1'/ 3 ' AT GRID POINTS # 2 # -2'/ 4 ' AT GIVEN LOCATIONS # 3'/ 5 ' AT BLOC BOUNDARIES # 4'/ 6 ' TERMINATE SELECTION : # 0'//) 107 DO 108 I=1,4 CALL TNOUA('OPTION #: ',10) READ(1,*) J 113 IF(J.EQ.0) GOTO 114 WRITE(6,6085) J 6085 FORMAT(' OPTION #: ',I3/) IF(IABS(J).EQ.1) ISPACE(1)=J IF(IABS(J).EQ.2) ISPACE(2)=J IF(IABS(J).EQ.3) ISPACE(3)=J IF(IABS(J).EQ.4) ISPACE(4)=J 108 CONTINUE 114 CONTINUE 115 IF(ISPACE(2).EQ.0) GOTO 116 CALL TNOUA('NUMBER OF GRID INTERVALS ',26) READ(1,*) NGRID 116 CONTINUE 117 IF(ISPACE(4).EQ.0) GOTO 118 WRITE(6,6092) WRITE(1,6092) 6092 FORMAT(1H ,'ACTIVE FAULT LINE:'/ 1' BLOCK LEFT # BLOCK RIGHT # FROM: X Y TO: X Y'/) IJ=1 MBLOC1= MBLOC-1 121 DO 122 IBLOC=0,MBLOC1 IBLOC1=IBLOC+1 123 DO 124 JBLOC=IBLOC1,MBLOC WRITE(1,6093) IBLOC,JBLOC 6093 FORMAT(4X,2(I2,4X)) READ(1,*) X1,Y1,X2,Y2 187 IF(X1.EQ.0.D0.AND.Y1.EQ.0.D0) GOTO 188 SXPER = (X1+X2)/2.D0 SYPER = (Y1+Y2)/2.D0 ALIN = DATAN2(Y2-Y1,X2-X1) FAULT(IJ,1) = SXPER + DSIN(ALIN)*1.D2 FAULT(IJ,2) = SYPER - DCOS(ALIN)*1.D2 FAULT(IJ,3) = SXPER - DSIN(ALIN)*1.D2 FAULT(IJ,4) = SYPER + DCOS(ALIN)*1.D2 WRITE(6,6094) IBLOC,JBLOC,X1,Y1,X2,Y2 6094 FORMAT(11X,I2,14X,I2,2X,2(2F9.0,2X)) 188 CONTINUE IJ = IJ+1 124 CONTINUE 122 CONTINUE 118 CONTINUE 47 IF(IPREDO.LE.0) GOTO 48 CALL TNOUA('NUMBER OF TIME INTERVALS FOR PREDICTION : ',42) READ(1,*) NTIMIN 49 GOTO 50 48 CONTINUE 51 DO 52 I=1,30 CALL TNOUA('PREDICTION TIMES [YR] (END=-9): ',32) READ(1,*) TPRED(I) 53 IF(TPRED(I).EQ.-9.D0) GOTO 54 52 CONTINUE 54 CONTINUE NTIMIN = I-1 50 CONTINUE WRITE(6,1004) WRITE(6,6017) IPREDO,NTIMIN,NGRID 6017 FORMAT(1H ,'OPTION # ',I2// 1 ' NUMBER OF TIME INTERVALS: ',I2/ 2 ' NUMBER OF GRID INTERVALS: ',I2//) 706 IF(LPREDI) GOTO 707 C READ NUMBER OF OBSERVATION EPOCHS, OBSERVATION TIME [YR], C NUMBER OF NUISANCE PARAMETERS, VARIANCE FACTOR WRITE(6,6032) 6032 FORMAT(1H //' OBSERVATION DATA:'/1H ,17(1H-)//) READ(5,5101) NNET 5101 FORMAT(I2) WRITE(6,6201) NNET 6201 FORMAT(1H /' NUMBER OF OBSERVATION EPOCHS: ',I4//) WRITE(6,6203) 6203 FORMAT(' OBSERVATION EPOCHS:'//' #',3X,'EPOCH',15X,'TIME[YR]'1X, 1 'NUIS.PAR.',2X,'VAR.FACT.'/) NN = 0 101 DO 102 I=1,NNET READ(5,5102) (NEPOC(I,J),J=1,2),TIME(I),(NUIPAR(I,J),J=1,2), 1 VARF(I) 5102 FORMAT(2A8,F10.3,2I2,F10.6) IF(ISTAT(1).EQ.0) VARF(I) = 1.D0 WRITE(6,6202)I,(NEPOC(I,J),J=1,2),TIME(I),(NUIPAR(I,J),J=1,2), 1 VARF(I) 6202 FORMAT(I4,2X,2A8,2X,F10.3,2X,I1,2X,I1,4X,F10.6) NN = NN + NUIPAR(I,1) + NUIPAR(I,2) 102 CONTINUE C NUMBER OF NUISANCE PARAMETERS WRITE(6,6005) NN 6005 FORMAT(1H /' NUMBER OF NUISANCE PARAMETERS: ',I2//) C TOTAL TIME SPAN OF OBSEVATIONS AND TIME INTERVAL OF PREDICTION TIMSPA = TIME(I) - TIME(1) TIMINT = 0.D0 58 IF(NTIMIN.EQ.0.OR.IPREDO.LE.0) GOTO 59 TIMINT = TIMSPA / NTIMIN 59 CONTINUE IF(NGRID.NE.0) GRIDWM = 2./NGRID * SCALP WRITE(6,6007) TIMSPA,TIMINT,GRIDWM 6007 FORMAT(1H /' TOTAL TIME SPAN OF OBSERVATION [YR] : ',T44,F8.3/ 1 ' TIME INTERVAL OF PREDICTION [YR] : ',T44,F8.3/ 2 ' GRID INTERVAL OF PREDICTION [M] : ',T44,F8.3//) C SCALE TIME OF EPISODES 97 DO 98 I = 1,NEPIS BE(I,1) = (BE(I,1)-TIME0)/(TIMSPA/2.) BE(I,2) = (BE(I,2)-TIME0)/(TIMSPA/2.) 98 CONTINUE C READ TITLE OF NETWORKS, NUMBER, IDENT. AND COORD. OF FIXED POINTS INPAR = 1 ISOBS = 0 ISNU = 0 71 DO 72 INET=1,NNET C CALL TIMDAT(ITIM,15) C WRITE(1,1691)(ITIM(JT),JT=4,10) 1691 FORMAT('#1',7I6) CALL RDNET(INET,NP,NP1,P0,NAME,P,NFIX,LPRINT,NONET,NUNET, 1 NH,NUH,NNOR,NTIT) ISOBS = ISOBS + NONET(INET) ISNU = ISNU + NUNET(INET) WRITE(1,6042) INET,NTIT 6042 FORMAT(/' NETWORK # ',I3,' : ',40A2) WRITE(6,6041)NP,NONET(INET),NUNET(INET),NH,NUH WRITE(1,6041)NP,NONET(INET),NUNET(INET),NH,NUH 6041 FORMAT(1H ,'NUMBER OF POINTS: ',T38,I3,2X, 1 'TOTAL NUMBER OF OBSERVATIONS:',T76,I3/ 2 ' NUMBER OF NETWORK NUISANCE PARAM.:',T38,I3,2X,'NUMBER OF OBSERV 3ED HEIGHTS:',T76,I3/' NUMBER OF HEIGHT UNKNOWNS:',T38,I3//) 31 IF(INET.GE.2) GOTO 32 C CONVERT POSITON INTO COMPLEX VARIABLES CALL CPLXPO(Z,P,P0,SCALP,NP1,NFIX) SCALR = SCALP/SCALD D0(1) = 0.D0 D0(2) = 0.D0 C CONVERT PERIMETER POLYGON VERTICES INTO COMPLEX VARIABLES 87 DO 88 I=1,JJBLOC ZBLC(I) = CMPLX(SNGL((PER(I,1)-P0(1))/SCALP),SNGL((PER(I,2)- 1 P0(2))/SCALP)) 88 CONTINUE C CHECK IF STATION IS IN BLOCK WRITE(6,6002) 6002 FORMAT(1H //' NAME',9X,'COMPLEX POSITIONS:',T40,'IN BLOCK:(0=OUTSI 1DE,1=INSIDE,0.5=ON SIDE OR VERTICE)'//T40,'#1',4X,'#2',4X,'#3',4X, 2 '#4',4X,'#5'//) 11 DO 12 I=1,NP 75 IF(MBLOC.EQ.0) GOTO 76 73 DO 74 IBLOC=1,MBLOC PBLOC(IBLOC)=PINPOL(Z(I),ZBLC,NPER(IBLOC,1),NPER(IBLOC,2),3) 74 CONTINUE 76 CONTINUE WRITE(6,6003) (NAME(I,J),J=1,4),Z(I),(PBLOC(J),J=1,MBLOC) 6003 FORMAT(1H ,4A2,4X,2F8.4,10X,5(F3.1,3X)) 12 CONTINUE WRITE(6,6004)P0,D0,SCALP,SCALD,SCALR 6004 FORMAT(1H //' LOCAL ORIGINES: ',T55,'SCALE FACTORS:',13X, 1 'RATIO:' //6X,'X0',11X,'Y0',11X,'U0',9X,'V0',T55,'POSITIONS',7X, 2 'DISPLACEM.'//7F13.4//) C COMPLEX OBSERVATION EQUATIONS 5 DO 6 I=1,NP CPXA(I,1) = (1.,0.) CALL CALPOL(PHI,Z(I),MDIM,MCONF1,MCONF) 7 DO 8 J=1,MCONF CPXA(I,J) = PHI(1,J) 8 CONTINUE ZC = CONJG(Z(I)) CALL CALPOL(PHI,ZC,MDIM,MANTIC,MANTIC) 9 DO 10 J=1,MANTIC CPXA(I,MCONF+J) = PHI(1,J) 10 CONTINUE 6 CONTINUE IF(LPRINT)WRITE(6,2002) 2002 FORMAT(1H ,'COMPLEX A-MATRIX'/) 1 DO 2 I=1,NP 1003 FORMAT(8F10.3) IF(LPRINT)WRITE(6,2003)(CPXA(I,J),J=1,NU) 2003 FORMAT(1H /4(F11.3,2X,F11.3,4X)) 2 CONTINUE NP2 = NP*2 NP2H = NP2 + NUH NU2 = NU*2 NDE = NP2 + NN + NUH C COMPUTE REAL A-MATRIX CALL DMREAL(CPXA,A,NPDIM,NUDIM,NP2DIM,NU2DIM,NP,NU) IF(LPRINT)WRITE(6,2015) 2015 FORMAT(1H /' REAL A-MATRIX'/) IF(LPRINT)CALL DMTOUT(A,NP2DIM,NU2DIM,NP2,NU2,6,'D','5') C STORE FIRST TWO COLUMNS OF A 25 DO 26 I=1,NP2 27 DO 28 J=1,2 A2R(I,J) = A(I,J) 28 CONTINUE 26 CONTINUE WRITE(1,1877) NELIM 1877 FORMAT(I4) 77 DO 78 I=1,13 J=14-I CALL DELROW(A,A,NELIM(J),NP2DIM,NU2DIM,NP2,NU2) 78 CONTINUE IF(LPRINT) CALL DMTOUT(A,NP2DIM,NU2DIM,NP2,NU2,6,'D','5') 32 CONTINUE C TIME DIFFERENCE DTIME = TIME(INET) - TIME0 WRITE(6,6001)TIME(INET),DTIME 6001 FORMAT(1H ,'OBSERVATION TIME',4X,'TIME DIFFERENCE'/4X,F10.3,10X, 1 F10.3///) C NORMAL EQUATIONS OF I TH EPOCH C CALL TIMDAT(ITIM,15) C WRITE(1,1692)(ITIM(JT),JT=4,10) 1692 FORMAT('#2',7I6) NDE2 = NDE-NP2H NDE2DI = NDEDIM-NP2HDI CALL BMAT(B,A2R,NUIPAR,INET,INPAR,NP2DIM,NP2HDI,NDE,NDEDIM,NP2, 1 NP2H,NN,NDE2DI,NDE2) IF(LPRINT) CALL DMTOUT(B,NP2DIM,NDE2DI,NP2,NDE2,6,'D','5') C CALL TIMDAT(ITIM,15) C WRITE(1,1693)(ITIM(JT),JT=4,10) 1693 FORMAT('#2A',7I6) NRC = NU2 * MT NCC = NU * MT DTIMN = DTIME/(TIMSPA/2.) CALL NORMAL(INET,NP2,NP2H,NU2,NDE,LPRINT,SCALD,DTIMN,VARF(INET), 1 MT,NRC) 72 CONTINUE WRITE(6,6901) WRITE(6,6020) 6020 FORMAT(1H ,'LEAST SQUARES APPROXIMATION'/1H ,27(1H*)//) C ELIMINATE NUISANCE PARAMETERS CALL DELCYC(NDE,NRC,IERR,LPRINT) C PERFORM LEAST SQUARES ADJUSTMENT CALL LSQUA(XR,APVARF,ISING,NP,NU,NU2,NN,NNET,NUIPAR,FACTK,SCALD, 1 TIME,ITOPT,LPRINT,NONET,NUNET,LPREAN,NUH,ALPH,NRC,ISTAT, 2 TIMSPA,MT,ISOBS,ISNU,TIME0,ALPHP,XICHI,IDIM,CRXON) C COMPLEX PARAMETERS NU22 = 2*NU NRC2 = NU22*MT CALL CPXPAR(CPXX,XR,NU,NU2,NELIM,MT) IF(LPRINT) WRITE(6,6058) 6058 FORMAT(1H ,'X'/) IF(LPRINT) CALL DMTOUT(XR,NRCDIM,1,NRC2,1,6,'D','5') C STORE COEFFICIENTS AND THEIR COV.-MATRIX ON FILE "P_PREDICT" WRITE(9,9091)(NPROJ1(I),I=1,20),(NPROJ2(I),I=1,20) 9091 FORMAT(20A2,20A2) WRITE(9,9087) ALPHP,XICHI,IDIM WRITE(9,9092)NU,NU2,MCONF,MANTIC,NCC,NRC,MT,MBLOC,MCONF1,MDIM,NP1, 1 NNET,JJBLOC,NEPIS,NRC2,NTPOLY 9092 FORMAT(I4) IF(MBLOC.NE.0) WRITE(9,9096) ((NPER(I,J),J=1,2),I=1,MBLOC) 9096 FORMAT(2I2) IF(MBLOC.NE.0) WRITE(9,9097) ((PER(I,J),J=1,2),I=1,JJBLOC) 9097 FORMAT(2F12.0) IF(MBLOC.NE.0) WRITE(9,9095) (BLOCA(I),I=1,MBLOC) WRITE(9,9093) ((NAME(I,J),J=1,4),I=1,NP1) 9093 FORMAT(A2) WRITE(9,9095) (Z(I),I=1,NP1),(ZBLC(J),J=1,JJBLOC) WRITE(9,9095) (TIME(I),I=1,NNET),TIMSPA,TIME0,BE 9095 FORMAT(E20.13) WRITE(9,9095) D0,P,P0,SCALP,SCALD,SCALR WRITE(9,9095) (CPXX(I,1),I=1,NCC) 81 DO 82 I=1,NRC2 WRITE(9,9095) (CX(I,J),J=I,NRC2) 82 CONTINUE 707 CONTINUE C WRITE CONF.LEVEL, XICHI AND DIM. OF SAMPLE INTO FILE 'P_STRAIN' WRITE(7,7011) ALPHP,XICHI,IDIM 7011 FORMAT(2F8.4,I4) 758 IF(NTIMIN.EQ.0.OR.IPREDO.LE.0) GOTO 759 TIMINT = TIMSPA/NTIMIN 759 CONTINUE C COMPLEX COEFFICIENTS AND STANDARD DEVIATIONS WRITE(6,6901) WRITE(6,6006) 6006 FORMAT(1H //' COMPLEX COEFFICIENTS OF THE APPROX. POLYNOMIAL:'/ 1 1H ,47(1H-)//) WRITE(6,6008) 6008 FORMAT(1H //' CONFORMAL TERM:'//) WRITE(6,6024) 6024 FORMAT(2X,'I',7X,'T1',12X,'T2',12X,'T3',12X,'T4',12X,'T5',12X, 1 'T6',12X,'T7',12X,'T8',12X,'T9'/5X,9('REAL',3X,'IMAG',3X)) 15 DO 16 I=1,MCONF IF(I.EQ.MCONF1+1) WRITE(6,6043) 6043 FORMAT(6X,'BLOCK MOTION COEFFICIENTS:'/) WRITE(6,6011) I,(CPXX(J,1),J=I,NCC,NU) 6011 FORMAT(1H ,I2,1X,18F7.4/4X,18F7.4) 16 CONTINUE 288 IF(MANTIC.EQ.0) GOTO 289 WRITE(6,6009) 6009 FORMAT(1H ,//' ANTICONFORMAL TERM:'//) WRITE(6,6024) 17 DO 18 I=1,MANTIC MCONFI = MCONF+I WRITE(6,6011) I,(CPXX(J,1),J=MCONFI,NCC,NU) 18 CONTINUE 289 CONTINUE WRITE(6,6159) 6159 FORMAT(1H //' STANDARD DEVIATIONS OF THESE COEFFICIENTS:'//) WRITE(6,6008) WRITE(6,6024) 33 DO 34 I=1,MCONF JJ=1 61 DO 62 J=I,NCC,NU JR = 2*J-1 65 DO 66 II=1,2 SIG(JJ) = CX(JR,JR) IF(SIG(JJ).LT.0.) SIG(JJ)=0. SIG(JJ) = SQRT(SIG(JJ)) JJ=JJ+1 JR=JR+1 66 CONTINUE 62 CONTINUE WRITE(6,6011) I,(SIG(2*J-1),SIG(2*J),J=1,MT) 34 CONTINUE 286 IF(MANTIC.EQ.0) GOTO 287 WRITE(6,6009) WRITE(6,6024) 35 DO 36 I=1,MANTIC JJ=1 MCONFI = MCONF+I 63 DO 64 J=MCONFI,NCC,NU JR = 2*J-1 69 DO 70 II=1,2 SIG(JJ) = CX(JR,JR) IF(SIG(JJ).LT.0.) SIG(JJ)=0. SIG(JJ) = SQRT(SIG(JJ)) JJ=JJ+1 JR=JR+1 70 CONTINUE 64 CONTINUE WRITE(6,6011) I,(SIG(2*J-1),SIG(2*J),J=1,MT) 36 CONTINUE 287 CONTINUE C APPROX. DISPLACEMENT, RESIDUALS AND COMPLEX STRAIN COMPONENTS IF(IPREDO.EQ.0) GOTO 9999 DTIME = -1.D0*TIMSPA/2.D0 41 DO 42 ITIME = 1,NTIMIN WRITE(6,6901) IF(IPREDO.LE.0) DTIME = TPRED(ITIME)-TIME0 TPRE = TIME0 + DTIME WRITE(6,6014) ITIME,TPRE,DTIME WRITE(1,1014) ITIME,TPRE 1014 FORMAT(I2,'-TH PREDICTION: T= ',F8.3/) DTIMN = DTIME/(TIMSPA/2.) 6014 FORMAT(1H ,I2,'-TH PREDICTION OF STRAIN TENSOR FIELD AT TIME : ', 1 F8.3,10X,' DT [YR] = ',F8.3//) C PREDICTION OF RIGID BLOC MOTIONS 55 IF(MBLOC.EQ.0) GOTO 56 WRITE(6,6096) 6096 FORMAT(1H //' PREDICTION OF RIGID BLOC MOTIONS:'//) IF(IABS(IPREDO).EQ.2) WRITE(6,6076) 6076 FORMAT(1H /' RELATIVE BLOCK MOTION VELOCITIES: '//' FOR',T10, 1'REL.TO',T20,'VELOCITIES',T64,'STD.DEV.',T80,'AZIMUTH OF VELOC.'// 2' BLOCK #',T10,'BLOCK #',T20,'VX[MM/YR]',4X,'VY[MM/YR]',6X, @ 'VS[MM/YR]',T64,'SVX', 3 6X,'SVY',T80,'AZ[GON]'//) IF(IABS(IPREDO).EQ.1) WRITE(6,6077) 6077 FORMAT(1H /' ACCUMULATED RELATIVE BLOCK DISPLACEMENTS: '//' FOR', 1 T10,'REL.TO',T20,'DISPLACEMENTS',T64,'STD.DEV.',T80, 2 'AZIMUTH OF DISPLACEMENT'//' BLOCK #',T10,'BLOCK #', 3 T20,'DX[MM]',6X,'DY[MM]',6X,'DS[MM]',T64,'SDX',6X,'SDY',6X, @'AZ[GON]'/) CALL BLOC(ZBLC,NPER,MBLOC,XYBLOC,SXYBLC,BLOCAZ,CPXX, 1MDIM,MCONF,MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1) IJ=1 MBLOC1 = MBLOC-1 85 DO 86 IBLOC=0,MBLOC1 IBLOC1 = IBLOC+1 J1 = NPER(IBLOC1,1) J2 = NPER(IBLOC1,2) IF(ISPACE(4).NE.0) WRITE(7,7006) IBLOC1,(PER(J2+1,J),J=1,2) 7006 FORMAT(' %',I2,4X,2F10.2,52X/80X/80X) IF(ISPACE(4).NE.0) WRITE(7,7005)((PER(I,J),J=1,2),I=J1,J2) 7005 FORMAT(' $',6X,2F10.2,52X/80X/80X) 185 DO 186 JBLOC=IBLOC1,MBLOC X1 = XYBLOC(IJ,1)/2.D0 Y1 = XYBLOC(IJ,2)/2.D0 281 DO 282 J=1,2 XYBLOC(IJ,J) = XYBLOC(IJ,J)*1.E3 SXYBLC(IJ,J) = SXYBLC(IJ,J)*1.E3 282 CONTINUE X2 = DSQRT(XYBLOC(IJ,1)**2 + XYBLOC(IJ,2)**2) WRITE(6,6097) JBLOC,IBLOC,(XYBLOC(IJ,J),J=1,2),X2, 1 (SXYBLC(IJ,J),J=1,2),BLOCAZ(IJ) 6097 FORMAT(2X,I2,T10,2X,I2,T20,3F10.4,T60,2F10.4,T80,F8.2) 125 IF(FAULT(IJ,1).EQ.0.D0) GOTO 126 IF(DABS(X1).GT.1.D2.OR.DABS(Y1).GT.1.D2) GOTO 126 X2 = -X1 Y2 = -Y1 IF(ISPACE(4).NE.0)WRITE(7,7007) JBLOC,IBLOC, 1 (FAULT(IJ,J),J=1,2),X1,Y1 IF(ISPACE(4).NE.0)WRITE(7,7008) (FAULT(IJ,J),J=3,4),X2,Y2 7007 FORMAT(' #',I2,'-',I2,1X,2F10.2,2F8.4,36X,/80X/80X) 7008 FORMAT(' #',6X,2F10.2,2F8.4,36X/80X/80X) 126 CONTINUE IJ=IJ+1 186 CONTINUE 86 CONTINUE 56 CONTINUE 103 IF(ISPACE(1).EQ.0) GOTO 104 IF(IABS(IPREDO).EQ.2)WRITE(6,6010) 6010 FORMAT(1H //' STRAIN RATE TENSOR FIELD AND DISPLACEMENT RATES:' 1 //' NAME',5X,'POSITION',16X,'APPROX.DISPL.RATES [MM/YR]' 2 ,3X,'COMPLEX STRAIN RATE COMPONENTS [MICROSTRAIN/YR]'// 3 34X,'VARIANCE',T64,'VARIANCE'// 4 16X,'X',11X,'Y',11X,'U',11X,'V',10X,'SIGMA',7X,'OMEGA',8X,'TAU', 5 7X,'YPSILON',5X,'T.SHEAR',4X,'SHEAR-AZ.'/1X,T123,'[GON]'//) IF(IABS(IPREDO).EQ.1)WRITE(6,6051) 6051 FORMAT(1H //' ACCUMULATED STRAIN TENSOR FIELD AND DISPLACEMENTS:' 1 //' NAME',5X,'POSITION',16X,'APPROX.DISPL. [MM] ' 2 ,3X,'COMPLEX STRAIN COMPONENTS [MICROSTRAIN] '// 3 34X,'VARIANCE',T64,'VARIANCE'// 4 16X,'X',11X,'Y',11X,'U',11X,'V',10X,'SIGMA',7X,'OMEGA',8X,'TAU', 5 7X,'YPSILON',5X,'T.SHEAR',4X,'SHEAR-AZ.'/1X,T123,'[GON]'//) LCOVAR = .TRUE. IF(IISO.NE.0) LCOVAR = (IISO.LT.0) 19 DO 20 I=1,NP1 C PREDICTED VALUES AND THEIR COVARIANCE MATRICES CALL PREDIC(DA,CHI,PSI,CDA,CCHIPS,Z(I),CPXX,MDIM,MCONF, 1 MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1, 2 LCOVAR) IF(.NOT.LPREAN)CALL TSHEAR(TSHR,SHRAZ,STSHR,SSHRAZ,PSI,CCHIPS) IF(ABS(REAL(DA(1,1))).GE.100..OR.ABS(AIMAG(DA(1,1))).GE.100.) 1 DA(1,1)=(0.,0.) WRITE(7,7001)(NAME(I,J),J=1,4),(P(I,J),J=1,2),DA,CHI,PSI, 1 CCHIPS 7001 FORMAT(4A2,2F10.2,2F8.4,4F9.4/8E10.3/8E10.3) DA(1,1) = DA(1,1)*1.E3 CALL DMTSCL(CDA,CDA,1.D6,2,2,2,2) CALL SIGMAS(SIGDA,SIGCHI,SIGPSI,CDA,CCHIPS) WRITE(6,6012)(NAME(I,J),J=1,4),(P(I,J),J=1,2),DA,CHI,PSI,TSHR, 1 SHRAZ 6012 FORMAT(1H ,4A2,10F12.4) IF(ISPACE(1).GT.0)WRITE(6,6103)SIGDA,SIGCHI,SIGPSI,STSHR,SSHRAZ 6103 FORMAT(1H ,32X,8F12.4//) C WRITE SCALAR VALUES ON FILE "P_ISOLIN2" FOR PLOTTING ISO-LINES GOTO(911,912,913,914),IABS(IISO) GOTO 921 911 IF(IISO.GT.0)SCALAR = REAL(CHI) IF(IISO.LT.0)SCALAR = SIGCHI(1) GOTO 920 912 IF(IISO.GT.0)SCALAR = AIMAG(CHI) IF(IISO.LT.0)SCALAR = SIGCHI(2) GOTO 920 913 IF(IISO.GT.0)SCALAR = TSHR IF(IISO.LT.0)SCALAR = STSHR GOTO 920 914 IF(IISO.GT.0)SCALAR = DROSET(AZSHR,PSI) IF(IISO.LT.0)SCALAR = CROSET(AZSHR,CCHIPS) GOTO 920 920 CONTINUE IF(SCALAR.LT.SLOW.OR.SCALAR.GT.SUP) SCALAR = AMASQ WRITE(11,8002) P(I,1),P(I,2),SCALAR 8002 FORMAT(3E20.13) 921 CONTINUE 20 CONTINUE SEND = 999. IF(IISO.NE.0)WRITE(11,8002)P(1,1),P(1,2),SEND 104 CONTINUE C INTERPOLATION OF GRID POINTS 67 IF(IPREDO.EQ.0.OR.NGRID.EQ.0.OR.ISPACE(2).EQ.0) GOTO 68 GRIDW = 2./NGRID GRIDL = GRIDW * SCALP PR(1) = -SCALP + P0(1) PR(2) = SCALP + P0(2) WRITE(6,6021) PR,GRIDL 6021 FORMAT(1H //' INTERPOLATED GRID POINTS:'// 1 ' COORD. OF UPPER LEFT CORNER OF GRID: X = ',F10.2,' Y = ',F10.2/ 2 ' GRID INTERVAL [M] = ',F10.2//) WRITE(6,6010) Y = 1. LCOVAR = (IISO.LT.0) 21 DO 22 I=1,NGRID X = -1. PR(2) = Y * SCALP + P0(2) 23 DO 24 J=1,NGRID PR(1) = X * SCALP + P0(1) ZG = CMPLX(X,Y) C PREDICTE VALUES AND THEIR COVARIANCE MATRICES CALL PREDIC(DA,CHI,PSI,CDA,CCHIPS,ZG,CPXX,MDIM,MCONF, 1 MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1, 2 LCOVAR) IF(.NOT.LPREAN)CALL TSHEAR(TSHR,SHRAZ,STSHR,SSHRAZ,PSI, 1 CCHIPS) IF(ABS(REAL(DA(1,1))).GE.100..OR.ABS(AIMAG(DA(1,1))) 1 .GE.100.) DA(1,1)=(0.,0.) IF(IISO.EQ.0) WRITE(7,7002)I,J,PR,DA,CHI,PSI,CCHIPS 7002 FORMAT(2X,I2,1X,I2,1X,2F10.2,2F8.4,4F9.4/8E10.3/8E10.3) DA(1,1) = DA(1,1)*1.E3 CALL DMTSCL(CDA,CDA,1.D6,2,2,2,2) CALL SIGMAS(SIGDA,SIGCHI,SIGPSI,CDA,CCHIPS) IF(ISPACE(2).GT.0.AND.IISO.EQ.0) 1 WRITE(6,6022) I,J,PR,DA,CHI,PSI,TSHR,SHRAZ 6022 FORMAT(1H ,I2,1X,I2,3X,10F12.4) IF(ISPACE(2).GT.0.AND.IISO.EQ.0) 1 WRITE(6,6103) SIGDA,SIGCHI,SIGPSI,STSHR, 2 SSHRAZ C WRITE SCALAR VALUES ON FILE "P_ISOLIN1" FOR PLOTTING ISO-LINES GOTO(811,812,813,814),IABS(IISO) GOTO 821 811 IF(IISO.GT.0)SCALAR = REAL(CHI) IF(IISO.LT.0)SCALAR = SIGCHI(1) GOTO 820 812 IF(IISO.GT.0)SCALAR = AIMAG(CHI) IF(IISO.LT.0)SCALAR = SIGCHI(2) GOTO 820 813 IF(IISO.GT.0)SCALAR = TSHR IF(IISO.LT.0)SCALAR = STSHR GOTO 820 814 IF(IISO.GT.0)SCALAR = DROSET(AZSHR,PSI) IF(IISO.LT.0)SCALAR = CROSET(AZSHR,CCHIPS) 820 CONTINUE IF(SCALAR.LT.SLOW.OR.SCALAR.GT.SUP) SCALAR = AMASQ WRITE(10,8001) SCALAR 8001 FORMAT(8E10.3) 821 CONTINUE X = X + GRIDW 24 CONTINUE Y = Y - GRIDW 22 CONTINUE 68 CONTINUE 111 IF(ISPACE(3).EQ.3) GOTO 112 WRITE(7,7004) IF(IISO.NE.0) WRITE(10,7004) IF(IISO.NE.0) WRITE(11,7004) 7004 FORMAT('$$') DTIME = DTIME + TIMINT 42 CONTINUE GOTO 9999 C PREDICTION OF INDIVIDUAL POINTS 112 CONTINUE WRITE(1,6098) WRITE(6,6098) 6098 FORMAT(1H /' PREDICTION OF STRAIN FIELD AT INDIVIDUAL POINTS:'//) WRITE(1,1021) 1021 FORMAT(4X,'U',7X,'V',4X,'SIGMA',4X,'OMEGA',4X,'TAU',3X,'YPSILON', 1 3X,'T.SHEAR',3X,'SHEAR-AZ.'//) IF(IABS(IPREDO).EQ.1) WRITE(6,6051) IF(IABS(IPREDO).EQ.2) WRITE(6,6010) LCOVAR = .FALSE. 89 DO 90 I=1,20 CALL TNOUA(' POINT: ID# [END: ID#=0] :',26) READ(1,1088) (NAME(1,J),J=1,4) IF(NAME(1,1).EQ.'0 ') GOTO 9999 CALL TNOUA(' X[M] Y[M] :',12) 1088 FORMAT(4A2) READ(1,*) X,Y ZG = CMPLX(SNGL((X-P0(1))/SCALP),SNGL((Y- 1 P0(2))/SCALP)) CALL PREDIC(DA,CHI,PSI,CDA,CCHIPS,ZG,CPXX,MDIM,MCONF, 1 MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1, 2 LCOVAR) IF(.NOT.LPREAN)CALL TSHEAR(TSHR,SHRAZ,STSHR,SSHRAZ,PSI, 1 CCHIPS) DA(1,1) = DA(1,1)*1.E3 CALL DMTSCL(CDA,CDA,1.D6,2,2,2,2) CALL SIGMAS(SIGDA,SIGCHI,SIGPSI,CDA,CCHIPS) WRITE(6,6022) (NAME(1,J),J=1,4),X,Y,DA,CHI,PSI,TSHR,SHRAZ WRITE(1,1022) DA,CHI,PSI,TSHR,SHRAZ 1022 FORMAT(8F10.4) 90 CONTINUE GOTO 9999 C ERROR MESSAGES 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' ***FILE NOT OPEN***'/) GOTO 9999 902 CONTINUE WRITE(1,1902) 1902 FORMAT(' ***NUMBER OF BLOCK PERIMETER VERTICES EXCEEDED***'/) C WRITE TIME OF TERMINATION 9999 CONTINUE CALL TIMREG(IDAT,ITIME1,IUSER) WRITE(6,6981) ITIME1 6981 FORMAT(1H ,'END OF COMPUTATION: ',I2,'.',I2) C CLOSE FILES CALL CLOS$A(1) CALL TRNC$A(2) CALL CLOS$A(2) CALL TRNC$A(3) CALL CLOS$A(3) IF(.NOT.LPREDI)CALL TRNC$A(4) IF(.NOT.LPREDI)CALL CLOS$A(4) IF(.NOT.LPREDI)CALL TRNC$A(5) CALL CLOS$A(5) CALL TRNC$A(6) CALL CLOS$A(6) CALL TRNC$A(7) CALL CLOS$A(7) IF(.NOT.LPREDI) CALL DELE$A('T$STRAIN',8) CALL EXIT C NEW PAGE COMMAND 6900 FORMAT(' PROGRAM CRUSTRAIN (VERS.3.82)') 6901 FORMAT(' '/) END $$$ SUBROUTINE BMAT(B,A2R,NUIPAR,INET,INPAR,NP2DIM,NP2HDI,NDE,NDEDIM, 1 NP2,NP2H,NN,NDE2DI,NDE2) C GENERATE DESIGN SUBMATRIX "B" INTEGER*2 I INET,INPAR, N NUIPAR(50,2) REAL*8 A A2R(NP2DIM,2), B B(NP2DIM,NDE2DI) CALL DMTSCL(B,B,0.D0,NP2DIM,NDE2DI,NP2,NDE2) 3 DO 4 K=1,2 11 IF(NUIPAR(INET,K).NE.1) GOTO 12 5 DO 6 I=1,NP2 B(I,INPAR) = A2R(I,K) 6 CONTINUE INPAR = INPAR + 1 12 CONTINUE 4 CONTINUE RETURN END SUBROUTINE NORMAL(INET,NP2,NP2H,NU2,NDE,LPRINT,SCALD,DTIME,VARF, 1 MT,NRC) C GENERATES NORMAL EQUATIONS FOR EACH EPOCH AND ADDS THEM INTEGER*2 N NP2,NP2H,NU2,NDE,NDE1,NDE2,NRC,MT REAL*8 A A(60,48), A A2R(60,2), A ATN11(48,60), B B(60,40), B BTN11(40,60), D D(130,130), D D21I(40,90),D22I(40,40),D12I(90,40), D DTIME, E E(130,240), E E11I(90,48),E21I(40,48), G G(240,240),GI(48,48), H H(130,1), H H2I(40,1), K K(240,1),KI(48,1), N NI(90,90),N1(60,90),N11(60,60), S SCALD,SCALD2,SCAL, T TI,TJ,T2, U UI(90,1),U1I(60,1), V VARF LOGICAL LPRINT COMMON /COM10/ A,B,A2R COMMON /COM3/ NI,UI COMMON /COM6/ D,E,G,H,K COMMON /COM7/ D12I,D21I,D22I,E11I,E21I,GI,N1,N11,ATN11,BTN11 NDE1 = NP2H NDE2 = NDE - NP2H NP2H1 = NP2H + 1 C CLEAR SUBMATRICES 7 IF(INET.GT.1) GOTO 8 CALL DMTSCL(G,G,0.D0,240,240,NRC,NRC) CALL DMTSCL(K,K,0.D0,240,1,NRC,1) CALL DMTSCL(D,D,0.D0,130,130,NDE,NDE) CALL DMTSCL(E,E,0.D0,130,240,NDE,NRC) CALL DMTSCL(H,H,0.D0,130,1,NDE,1) 8 CONTINUE C SCALE NI AND UI SCAL = -SCALD/VARF SCALD2 = SCALD*SCALD/VARF CALL DMTSCL(NI,NI,SCALD2,90,90,NP2H,NP2H) CALL DMTSCL(UI,UI,SCAL,90,1,NP2H,1) 11 DO 12 I=1,NP2 U1I(I,1) = UI(I,1) 12 CONTINUE 13 DO 14 I=1,NP2 15 DO 16 J=1,NP2H N1(I,J) = NI(I,J) 17 IF(J.GT.NP2) GOTO 18 N11(I,J) = NI(I,J) 18 CONTINUE 16 CONTINUE 14 CONTINUE C GENERATE NORMAL SUBMATRICES CALL DMTMLT(D21I,B,N1,40,60,90,NDE2,NP2,NDE1,1) CALL DMTMLT(BTN11,B,N11,40,60,60,NDE2,NP2,NP2,1) CALL DMTMLT(D22I,BTN11,B,40,60,40,NDE2,NP2,NDE2,0) CALL DMTMLT(H2I,B,U1I,40,60,1,NDE2,NP2,1,1) CALL DMTMLT(E11I,N1,A,90,60,48,NP2H,NP2,NU2,1) CALL DMTMLT(E21I,BTN11,A,40,60,48,NDE2,NP2,NU2,0) CALL DMTMLT(ATN11,A,N11,48,60,60,NU2,NP2,NP2,1) CALL DMTMLT(GI,ATN11,A,48,60,48,NU2,NP2,NU2,0) CALL DMTMLT(KI,A,U1I,48,60,1,NU2,NP2,1,1) C SUMMATION OF NORMAL SUBMATRICES CALL DMTSAD(D,NI,1.D0,1,1,NDE,NDE,NP2H,NP2H,130,130,90,90) CALL DMTSAD(D,D21I,1.D0,NP2H1,1,NDE,NDE,NDE2,NP2H,130,130,40,90) CALL DMTSAD(D,D22I,1.D0,NP2H1,NP2H1,NDE,NDE,NDE2,NDE2,130,130,40, 1 40) CALL DMTTRS(D12I,D21I,NP2H,NDE2,90,40) CALL DMTSAD(D,D12I,1.D0,1,NP2H1,NDE,NDE,NP2H,NDE2,130,130,90,40) CALL DMTSAD(H,UI,1.D0,1,1,NDE,1,NP2H,1,130,1,90,1) CALL DMTSAD(H,H2I,1.D0,NP2H1,1,NDE,1,NDE2,1,130,1,40,1) ICOL = 1 21 DO 22 I=1,MT TI = THETA(DTIME,I) CALL DMTSAD(E,E11I,TI,1,ICOL,NDE,NRC,NP2H,NU2,130,240,90,48) CALL DMTSAD(E,E21I,TI,NP2H1,ICOL,NDE,NRC,NDE2,NU2,130,240,40, 1 48) CALL DMTSAD(K,KI,TI,ICOL,1,NRC,1,NU2,1,240,1,48,1) IROW = 1 23 DO 24 J=1,MT TJ = THETA(DTIME,J) T2 = TI * TJ CALL DMTSAD(G,GI,T2,IROW,ICOL,NRC,NRC,NU2,NU2,240,240,48,48) IROW = IROW + NU2 24 CONTINUE ICOL = ICOL + NU2 22 CONTINUE C OUTPUT 5 IF(.NOT.LPRINT) GOTO 6 C CALL DMTOUT(D11,90,90,NDE1,NDE1,6,'D','5') C CALL DMTOUT(D21,40,90,NDE2,NDE1,6,'D','5') C CALL DMTOUT(D22,40,40,NDE2,NDE2,6,'D','5') CALL DMTOUT(E,130,240,NDE,NRC,6,'D','5') CALL DMTOUT(G,240,240,NRC,NRC,6,'D','5') CALL DMTOUT(H,130,1,NDE,1,6,'D','5') CALL DMTOUT(K,240,1,NRC,1,6,'D','5') 6 CONTINUE RETURN END SUBROUTINE DELCYC(NE,NA,IERR,LPRINT) C ELIMINATION CYCLE OF NORMAL-HYPERMATRIX INTEGER*2 I IERR REAL*8 D D(130,130), D DINV(130,130), D DINVE(130,240), D DINVH(130,1), E E(130,240), G G(240,240), H H(130,1), K K(240,1), N NORM(240,240), U UMAT(240,1) LOGICAL LPRINT COMMON /COM6/D,E,G,H,K COMMON /COM8/NORM,UMAT COMMON /COM9/DINV,DINVE,DINVH CALL DMTINV(DINV,D,130,NE,IERR) 900 IF(IERR.NE.0) GOTO 901 IF(LPRINT) CALL DMTOUT(DINV,130,130,NE,NE,6,'D','5') CALL DMTMLT(DINVE,DINV,E,130,130,240,NE,NE,NA,0) CALL DMTMLT(NORM,E,DINVE,240,130,240,NA,NE,NA,1) IF(LPRINT) CALL DMTOUT(NORM,240,240,NA,NA,6,'D','5') CALL DMTSUB(NORM,G,NORM,240,240,NA,NA) CALL DMTMLT(DINVH,DINV,H,130,130,1,NE,NE,1,0) CALL DMTMLT(UMAT,E,DINVH,240,130,1,NA,NE,1,1) CALL DMTSUB(UMAT,K,UMAT,240,1,NA,1) C OUTPUT IF(.NOT.LPRINT) GOTO 9 CALL DMTOUT(NORM,240,240,NA,NA,6,'D','5') CALL DMTOUT(UMAT,240,1,NA,1,6,'D','5') 9 CONTINUE RETURN C ERROR MESSAGE 901 CONTINUE WRITE(1,1901) 1901 FORMAT('*** D SINGULAR IN DELCYC***'/) RETURN END SUBROUTINE LSQUA(X,APVARF,ISING,NO,NU,NU2,NN,NNET,NUIPAR,FACTK, 1 SCALD,TIME,ITEST,LPRINT,NONET,NUNET,LPREAN,NUH,ALPH,NRC,ISTAT, 2 TIMSPA,MT,ISOBS,ISNU,TIME0,ALPHP,XICHI,IDIM,CRXON) C LEAST SQUARES ADJUSTMENT INTEGER*2 I ISING, /* SINGULARITY CODE I ISTAT(2), I ITEST, /* TEST OPTION # N NAME(30,4), N NO,NU, /* NUMBER OF OBSERVATIONS/UNKNOWNS, N NONET(50), N NUNET(50), N NUIPAR(50,2) REAL*4 A APVARF, /* A POST.VARIANCEFACTOR F FACTK, R RTPR, S SQRVAR, T TIME(50), T TIME0, T TIMSPA, X X0I REAL*8 A A(60,48), A A2R(60,2), A ALPH, A APVAR2, B B(60,40), C CRXON, C CX(240,240), D DELTA2(90,1), D DELTAE(130,1), D DTIME, D DTIMN, N NORM(240,240), R RMESS, R RMOD, R RC(240,240), S SCALD, S S0, U UMAT(240,1), V V(160,1), V VARF(50), V VARFI, X X(240,1), X X0(240,1), X XFACT, X XICHI, X XICHIV LOGICAL LPRINT,LCHIST,LPREAN,LTSTOP COMMON /COM10/ A,B,A2R COMMON /COM2/ CX COMMON /COM4/ RC COMMON /COM8/ NORM,UMAT COMMON /COM14/ NAME,VARF COMMON /COML/ X0,DELTAE COMMON /STAT/ NDF1,NDF2 DATA N NDEDIM/130/, N NDE2DI/40/, N NODIM/30/, N NO2DIM/60/, N NO2HDI/90/, N NUDIM/24/, N NU2DIM/48/, N NRCDIM/240/, N NCCDIM/120/ TSTART = CRXON NO2 = 2*NO NO2H = NO2 + NUH NDE = NO2 + NN + NUH NDE1 = NO2H NDE2 = NDE - NO2H C WRITE(1,1961) NO2,NU2,NRC 1961 FORMAT('L.S. APPROX.: ',I3,'OBS. COORD. ',I3,'REAL SPACE COEFF. ', 1 I3,'TOTAL REAL COEFFICIENTS'//) C COMPUTE DIRECT SOLUTION 33 IF(.NOT.LPRINT) GOTO 34 CALL DMTINV(CX,NORM,NRCDIM,NRC,ISING) IF(ISING.NE.0) GOTO 902 9993 CONTINUE 6003 FORMAT(' NORM SINGULAR'/) CALL DMTMLT(X,CX,UMAT,NRCDIM,NRCDIM,1,NRC,NRC,1,0) WRITE(6,6004) 6004 FORMAT(' INV(NORM)'/) CALL DMTOUT(CX,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') WRITE(6,6005) 6005 FORMAT(' X'/) CALL DMTOUT(X,NRCDIM,1,NRC,1,6,'D','5') 34 CONTINUE C CHOLESKY DECOMPOSITION OF THE NORMAL MATRIX CALL DCHOL1(RC,NORM,NRCDIM,NRC,INDEF) IF(LPRINT) WRITE(6,6006) 6006 FORMAT(' RC'/) IF(LPRINT) CALL DMTOUT(RC,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') IF(INDEF.NE.0) GOTO 904 C TEST DECOMPOSITION 35 IF(.NOT.LPRINT) GOTO 36 CALL DMTMLT(CX,RC,RC,NRCDIM,NRCDIM,NRCDIM,NRC,NRC,NRC,1) WRITE(6,6007) 6007 FORMAT(' RTR'/) CALL DMTOUT(CX,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') 36 CONTINUE C INVERT RC-MATRIX CALL DRMINV(RC,RC,NRCDIM,NRC,IERR) IF(LPRINT) WRITE(6,6008) 6008 FORMAT(' INV(RC)'/) IF(LPRINT) CALL DMTOUT(RC,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') IF(IERR.GT.0) GOTO 903 C COMPUTE ORTHO-NORMAL SOLUTION VECTOR CALL DMTMLT(X0,RC,UMAT,NRCDIM,NRCDIM,1,NRC,NRC,1,1) C SORT ORTHONORMALIZED SOLUTION VECTOR AND RE-ARANGE R1-MATRIX CALL DSISRT(X0,RC,NRCDIM,NRCDIM,NRC,NRC) IF(LPRINT)WRITE(6,2009) 2009 FORMAT(1H ,'X0-VECTOR'/) IF(LPRINT)CALL DMTOUT(X0,NRCDIM,1,NRC,1,6,'D','5') C STATISTICAL TEST PROCEDURE OF FOURIER COEFFICIENTS 401 IF(LPREAN) GOTO 402 WRITE(6,2016) 2016 FORMAT(1H //' FOURIER COEFFICIENTS:'/' NO',9X,'COEFF.',3X, 1 'VAR.(SQRT)',6X,'TEST-CRIT.',4X,'REJECT.',5X,'RTPR',6X, 2 'POST.VAR.F.',2X, 'D.F.'/21X,'PRIOR',2X,'POSTERIOR'//) NC = 0 IDIM = -1 PRIVAR = 1. STEST = 0. LTSTOP = .FALSE. CALL DMTSCL(X,X,0.D0,NRCDIM,1,NRC,1) 13 DO 14 I=0,NRC IDIM = IDIM + 1 C TRANSFORM BACK TO ORIGINAL POLYNOMIAL COEFFICIENTS 19 IF(I.EQ.0) GOTO 20 CALL DMTMLT(X,RC,X0,NRCDIM,NRCDIM,1,NRC,I,1,0) 20 CONTINUE C BACK SOLUTION OF ELIMINATED PARAMETERS, ADJUSTED PSEUDO OBS. CALL BACKS(DELTAE,X,NRC,NDE) CALL DMTSCL(DELTAE,DELTAE,SCALD,NDEDIM,1,NDE,1) IF(LPRINT) WRITE(6,6991) 6991 FORMAT(1H ,'DELTAE'/) IF(LPRINT)CALL DMTOUT(DELTAE,NDEDIM,1,NDE,1,6,'D','5') INPAR = 1 RTPR = 0. X0I = X0(I,1) 15 IF(ITEST.EQ.-1.OR.(ITEST.EQ.-3.AND.(ABS(X0I).GT.TSTART.OR. 1 LTSTOP))) GOTO 16 REWIND 8 41 DO 42 INET=1,NNET C ADJUSTED PSEUDO-OBSERVABLES DTIME = TIME(INET) - TIME0 IF(LPRINT) WRITE(6,6994) DTIME 6994 FORMAT(1H ,'DTIME=',F10.4/) CALL BMAT(B,A2R,NUIPAR,INET,INPAR,NO2DIM,NO2HDI,NDE,NDEDIM, 1 NO2,NO2H,NN,NDE2DI,NDE2) DTIMN = DTIME/(TIMSPA/2.) CALL ADJCOR(INET,DELTA2,DELTAE,X,A,B,NO2HDI,NO2H,NRCDIM,NRC, 1 NDEDIM,NDE,NDE2DI,NDE2,NO2DIM,NO2,DTIMN,SCALD,MT,NU2DIM,NU2) IF(LPRINT)WRITE(6,6995) 6995 FORMAT(1H ,'DELTAI'/) IF(LPRINT)CALL DMTOUT(DELTA2,1,NO2HDI,1,NO2H,6,'D','5') C CALL ASTOR2(INET) CALL AREADB(1,8) CALL DMTSCL(DELTA2,DELTA2,-1.D0,NO2HDI,1,NO2H,1) CALL RESID(NOBS,DELTA2,V,NV,NPG,S0) S0 = S0 / VARF(INET) IF(LPRINT) WRITE(6,6015)S0 6015 FORMAT(1H ,F12.4) IF(LPRINT)WRITE(6,2011) 2011 FORMAT(1H ,'RESIDUALS'/) IF(LPRINT)CALL DMTOUT(V,1,160,1,NV,6,'D','5') RTPR = RTPR + S0 42 CONTINUE 16 CONTINUE IDF = ISOBS - ISNU + NC - NDE -I APVARF = 1. 301 IF(IDF.LE.0) GOTO 302 APVARF = SQRT(RTPR/IDF) C CHI-SQUARE TEST ON THE VARIANCE FACTOR C IF(LCHIST(IDF,SALPH,PRIVAR,APVARF)) STEST = FACTK*APVARF 302 CONTINUE C SET INSIGNIFICANT FOURIER COEFFICIENTS TO ZERO RMESS = ' ' X0I = 0. IF(I.EQ.0) GOTO 304 X0I = X0(I,1) IF(LTSTOP) GOTO 210 303 GOTO(200,201,202,203,204,205), IABS(ITEST)+1 200 CONTINUE GOTO 304 201 CONTINUE STEST = FACTK*PRIVAR IF(ABS(X0I).GT.STEST) GOTO 304 GOTO 210 202 CONTINUE STEST = FACTK*APVARF IF(ABS(X0I).GT.STEST) GOTO 304 GOTO 210 203 CONTINUE STEST = FACTK*PRIVAR IF(ABS(X0I).LT.TSTART) STEST = FACTK*APVARF IF(ABS(X0I).GT.STEST) GOTO 304 GOTO 210 204 CONTINUE IF(RTPR.LT.RTPROL) GOTO 304 GOTO 210 205 CONTINUE IF(ABS(X0I).GT.FACTK*PRIVAR.AND.ABS(X0I).GT.FACTK*APVARF 1 .AND.APVARF.LT.APVOLD) GOTO 304 210 CONTINUE LTSTOP = .TRUE. X0(I,1) = 0.D0 IDIM = IDIM - 1 17 DO 18 J=1,NRC RC(J,I) = 0.D0 18 CONTINUE RMESS = 'SET TO 0' NC = NC + 1 307 GOTO 308 304 CONTINUE APVOLD = APVARF RTPROL = RTPR 308 CONTINUE 9991 WRITE(6,2017)I,X0I,PRIVAR,APVARF,STEST,RMESS,RTPR,APVARF,IDF 2017 FORMAT(I3,4X,F12.4,3F8.4,4X,A8,4X,2(F10.3,3X),I3) 14 CONTINUE C TRANSFORM BACK TO ORIGINAL POLYNOMIAL COEFFICIENTS CALL DMTMLT(X,RC,X0,NRCDIM,NRCDIM,1,NRC,NRC,1,0) C COMPUTE FINAL RESIDUALS AND A POSTERIORI VARIANCE FACTOR C BACK SOLUTION OF ELIMINATED PARAMETERS CALL BACKS(DELTAE,X,NRC,NDE) CALL DMTSCL(DELTAE,DELTAE,SCALD,NDEDIM,1,NDE,1) C PRINT ELIMINATED PARAMETERS WRITE(6,6025) 6025 FORMAT(1H /' ELIMINATED PARAMETERS: '/) CALL DMTOUT(DELTAE,1,NDEDIM,1,NDE,6,'F','3') C RESIDUALS OF ORIGINAL OBSERVATIONS 402 CONTINUE INPAR = 1 RTPR = 0. IDF = ISOBS - ISNU + NC - NDE - NRC REWIND 8 43 DO 44 INET=1,NNET 403 IF(LPREAN) GOTO 404 C ADJUSTED COORDINATES DTIME = TIME(INET) - TIME0 DTIMN = DTIME/(TIMSPA/2.) CALL BMAT(B,A2R,NUIPAR,INET,INPAR,NO2DIM,NO2HDI,NDE,NDEDIM, 1 NO2,NO2H,NN,NDE2DI,NDE2) CALL ADJCOR(INET,DELTA2,DELTAE,X,A,B,NO2HDI,NO2H,NRCDIM,NRC, 1 NDEDIM,NDE,NDE2DI,NDE2,NO2DIM,NO2,DTIMN,SCALD,MT,NU2DIM,NU2) C PRINT ADJUSTED COORDINATES OF THE I-TH EPOCH C WRITE(6,6901) WRITE(6,6021) INET 6021 FORMAT(1H //' ADJUSTED COORDINATES OF THE ',I2,' -TH EPOCH'// 1' STATION',6X,'X',10X,'Y'//) 45 DO 46 J=1,NO J2=2*J J1=J2-1 WRITE(6,6022) (NAME(J,K),K=1,4),DELTA2(J1,1),DELTA2(J2,1) 6022 FORMAT(1H ,4A2,2F12.4/) 46 CONTINUE C RESIDUALS C CALL ASTOR2(INET) CALL AREADB(1,8) CALL DMTSCL(DELTA2,DELTA2,-1.D0,NO2HDI,1,NO2H,1) CALL RESID(NOBS,DELTA2,V,NV,NPG,S0) S0 = S0 / VARF(INET) C PRINT RESIDUALS OF THE I-TH EPOCH WRITE(6,6023) 6023 FORMAT(1H ,/' RESIDUALS OF ORIGINAL OBSERVATIONS:'/) CALL DMTOUT(V,1,160,1,NV,6,'F','4') VARFI = 0.D0 305 IF(IDF.LE.0) GOTO 306 VARFI = S0 * ISOBS / (INTL(IDF)*INTL(NOBS)) IF(VARFI.LE.0.D0) GOTO 306 VARFI = DSQRT(VARFI) 306 CONTINUE WRITE(6,6024) NOBS,S0,VARFI 6024 FORMAT(1H /' NUMBER OF OBSERVATIONS:',I3/ 1 ' QUADRATIC FORM OF WEIGHTED RESIDUALS: ',F12.4/ 2 ' APPROX. OF GROUP VAR. FACTOR: ',F9.6//) RTPR = RTPR + S0 404 CONTINUE 44 CONTINUE APVARF = 1. 311 IF(IDF.LE.0) GOTO 312 APVAR2 = RTPR/IDF APVARF = SQRT(APVAR2) NDF1 = IDF XICHIV = DICCHI(ALPH)/IDF RMOD = ' FAILS ' IF(APVAR2.LT.XICHIV) RMOD = ' PASSES ' C XTXS = XTX(1,1)/APVAR2 312 CONTINUE NDF1 = IDIM XICHI = DICCHI(ALPH) XFACT = DSQRT(XICHI) C WRITE DEGREE OF FREEDOM AND A POSTERIORI VARIANCE FACTOR IF(.NOT.LPREAN)WRITE(6,6901) WRITE(6,6014) ISOBS,ISNU,NC,NDE,NRC,IDF,APVARF 6014 FORMAT(1H ,'DEGREES OF FREEDOM AND COVARIANCE MATRIX'// 1' TOTAL NUMBER OF ORIGINAL OBSERVATIONS: ',T55,I3/ 2' NUMBER OF NUISANCE PARAMETERS OF NETWORK ADJUSTMENT: ',T55,I3/ 3' NUMBER OF CONSTRAINED PARAMETERS: ',T55,I3/ 4' NUMBER OF ELIMINATED PARAMETERS: ',T55,I3/ 5' NUMBER OF UNKNOWN COEFFICIENTS: ',T55,I3/ 6 ' DEGREE OF FREEDOM: ',T55,I3/' A POST. VARIANCE FACTOR (SQRT):', 7 T55,F12.4//) ALPHP = ALPH * 100. IF(LPRINT)CALL DMTOUT(X,NRCDIM,1,NRC,1,6,'D','5') C COVARIANCE MATRIX OF COEFFICIENTS CALL DMTMLT(CX,RC,RC,NRCDIM,NRCDIM,NRCDIM,NRC,NRC,NRC,2) IF(ISTAT(2).EQ.1)CALL DMTSCL(CX,CX,APVAR2,NRCDIM,NRCDIM,NRC,NRC) 691 IF(NRC.GT.10) GOTO 692 WRITE(6,6017) 6017 FORMAT(1H /' COVARIANCE MATRIX OF THE COEFFICIENTS'/) IF(ISTAT(2).EQ.1) WRITE(6,6013) IF(ISTAT(2).EQ.0) WRITE(6,6012) 6013 FORMAT(1H ,'A POST.'/) 6012 FORMAT(1H ,'A PRIORI'/) CALL DMTOUT(CX,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') 692 CONTINUE GOTO 9999 C ERROR MESSAGES 902 CONTINUE WRITE(1,9902) WRITE(6,9902) 9902 FORMAT(' ***NORM-MATRIX SINGULAR***'/) GOTO 9993 903 CONTINUE WRITE(1,9903) WRITE(6,9903) 9903 FORMAT(' ***RA-MATRIX SINGULAR***'/) GOTO 9999 904 CONTINUE WRITE(1,9904) WRITE(6,9904) 9904 FORMAT(' ***NORM-MATRIX INDEFINIT***'/) 9999 CONTINUE RETURN C NEW PAGE COMMAND 6901 FORMAT(' '/) END SUBROUTINE BACKS(DELTAE,X,NRC,NDE) C BACKSOLUTION OF ELIMINATED PARAMETERS REAL*8 D DINV(130,130), D DINVE(130,240), D DINVH(130,1), D DELTAE(130,1), X X(240,1) COMMON /COM9/DINV,DINVE,DINVH CALL DMTMLT(DELTAE,DINVE,X,130,240,1,NDE,NRC,1,0) CALL DMTSUB(DELTAE,DINVH,DELTAE,130,1,NDE,1) RETURN END SUBROUTINE ADJCOR(INET,DELTA2,DELTAE,X,A,B,NO2HDI,NO2H,NRCDIM, 1 NRC,NDEDIM,NDE,NDE2DI,NDE2,NO2DIM,NO2,DTIMN,SCALD,MT,NU2DIM,NU2) C ADJUSTED COORDINATES OF I-TH EPOCH INTEGER*2 N NDE,NDEDIM, N NDE2,NDE2DI, N NRC,NRCDIM, N NO2,NO2DIM, N NO2H,NO2HDI REAL*8 A A(60,48), B B(60,40), B BDN(60,1), D DELTAE(130,1), D DELTAN(40,1), D DELTA1(60,1), D DELTA2(90,1), D DTIMN, S SCALD, T T, T THETA, X X(240,1), X XS(48,1) 1 DO 2 I=1,NDE2 DELTAN(I,1) = DELTAE(NO2H+I,1) 2 CONTINUE CALL DMTSCL(BDN,BDN,0.D0,NO2DIM,1,NO2,1) CALL DMTMLT(BDN,B,DELTAN,NO2DIM,NDE2DI,1,NO2,NDE2,1,0) J=0 11 DO 12 IT=1,MT T = THETA(DTIMN,IT) 13 DO 14 I=1,NU2 XS(I,1) = X(J+I,1) * T 14 CONTINUE CALL DMTMLT(DELTA1,A,XS,NO2DIM,NU2DIM,1,NO2,NU2,1,0) CALL DMTSCL(DELTA1,DELTA1,SCALD,NO2DIM,1,NO2,1) CALL DMTADD(BDN,BDN,DELTA1,NO2DIM,1,NO2,1) J = J + NU2 12 CONTINUE 3 DO 4 I=1,NO2H DELTA2(I,1) = DELTAE(I,1) 5 IF(I.GT.NO2) GOTO 6 DELTA2(I,1) = DELTA2(I,1) + BDN(I,1) 6 CONTINUE 4 CONTINUE RETURN END SUBROUTINE RESID(NOBS,X,V,NV1,NPG,S0) 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(130,4),A(130,6),X(90,1),W(130),WX(60), @ ICA(130,6),V(160,1),ICP(121),SPX(60,60),DOBR(130,4) COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR LT LT NOBS = NO LT NV1 = NV LT NPG = NP 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),1) RESID032 2 CONTINUE RESID033 V(I,1)=W(I)+W1 RESID0 S0=S0+V(I,1)**2/DOBR(I,1)**2 RESID0 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),1) RESID051 6 CONTINUE RESID052 V(J,1)=W(J)+W1 RESID0 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),1) 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,1)=V(J,1)+SUM2 RESI DO 13 J=I,M RESID068 13 S0=S0+V(J,1)**2/DOBR(J,1)**2 RESID0 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,1)=WX(J)-X(ICP(J),1) RESID0 GOTO11 RESID077 20 V(NO+J,1)=WX(J) RESID0 11 CONTINUE RESID079 DO 12 J=1,NP2 RESID080 DO 12 K=1,NP2 RESID081 12 S0=S0+V(NO+J,1)*V(NO+K,1)*SPX(J,K) RESI 14 RETURN RESID083 END RESID084 SUBROUTINE CPXPAR(CPXX,X,NU,NU2,NELIM,MT) C CONVERTS REAL INTO COMPLEX PARAMETER VECTOR, SETS ELIMINATED C COEFFICIENTS TO ZERO, REARRANGES COV.-MATRIX OF THESE COEFFICIENTS INTEGER*2 I IADR(240), N NELIM(13) REAL*8 C CX(240,240), C CXR, X X(240), X XR COMPLEX*8 C CPXX(120) COMMON /COM2/ CX NRC = NU2*MT NCC = NU*MT NU22 = NU*2 NRC2 = NU22*MT J=1 K=1 1 DO 2 IT=1,MT 3 DO 4 I=1,NU22 IADR(J) = K 5 DO 6 IEL=1,13 IF(NELIM(IEL).EQ.I) IADR(J) = 0 6 CONTINUE IF(IADR(J).NE.0) K=K+1 J=J+1 4 CONTINUE 2 CONTINUE WRITE(1,1877) IADR 1877 FORMAT(20I4) 11 DO 12 I1=1,NRC2 I=NRC2+1-I1 XR = 0.D0 L = IADR(I) IF(L.NE.0) XR = X(L) X(I) = XR 13 DO 14 I2=1,NRC2 J=NRC2+1-I2 CXR = 0.D0 K = IADR(J) IF(K.NE.0.AND.L.NE.0) CXR = CX(L,K) CX(I,J) = CXR 14 CONTINUE 12 CONTINUE 9 DO 10 I=1,NCC I2=2*I I1=I2-1 CPXX(I) = CMPLX(SNGL(X(I1)),SNGL(X(I2))) 10 CONTINUE RETURN END SUBROUTINE SIGMAS(SIGDA,SIGCHI,SIGPSI,CDA,CCHIPS) C VARIANCE OF DISPLACEMENT COMPONENTS AND STRAIN QUANTITIES REAL*8 C CCHIPS(4,4), C CDA(2,2) REAL *4 S SIG, S SIGCHI(2),SIGDA(2),SIGPSI(2) 1 DO 2 I=1,2 SIG = CDA(I,I) IF(SIG.LT.0.) SIG = 1.E30 SIGDA(I) = SQRT(SIG) SIG = CCHIPS(I,I) IF(SIG.LT.0.) SIG = 1.E30 SIGCHI(I) = SQRT(SIG) SIG = CCHIPS(I+2,I+2) IF(SIG.LT.0.) SIG = 1.E30 SIGPSI(I) = SQRT(SIG) 2 CONTINUE RETURN END SUBROUTINE CPLXPO(Z,P,P0,SCALP,NP,NFIX) C COMPUTES COMPLEX POSITIONS AND DISPERSION PARAMETERS INTEGER*2 N NP /* NUMBER OF POINTS REAL*8 P P(30,2),P0(2), S SCALP, S SXY(2), X XY(2),XYMIN(2),XYMAX(2) COMPLEX*8 Z Z(30) DATA S SXY/2*0.D0/, X XYMIN,XYMAX/2*1.D20,2*-1.D20/ C DISPERSION PARAMETERS 1 DO 2 I=1,NP 3 DO 4 J=1,2 XY(J) = P(I,J) SXY(J) = SXY(J) + XY(J) XYMIN(J) = DMIN1(XYMIN(J),XY(J)) XYMAX(J) = DMAX1(XYMAX(J),XY(J)) 4 CONTINUE 2 CONTINUE 11 IF(NFIX.NE.0) GOTO 12 5 DO 6 J=1,2 P0(J) = SXY(J)/NP 6 CONTINUE 12 CONTINUE SCALP = DMAX1(XYMAX(1)-P0(1),P0(1)-XYMIN(1),XYMAX(2)-P0(2),P0(2)- 1 XYMIN(2)) C COMPLEX POSITIONS 7 DO 8 I=1,NP Z(I) = CMPLX(SNGL((P(I,1)-P0(1))/SCALP),SNGL((P(I,2)-P0(2))/ 1 SCALP)) 8 CONTINUE RETURN END SUBROUTINE DELROW(AEL,A,K,NDIM,MDIM,N,M) C ELIMINATE ROW K OF MATRIX A (REAL*8) INTEGER*2 I,J,JJ,K,N,NDIM,M,MDIM,M1 REAL*8 A A(NDIM,MDIM), A AEL(NDIM,MDIM) 8 IF(K.EQ.0.OR.K.GT.M) GOTO 9 M = M-1 1 DO 2 J=1,M JJ=J IF(J.GE.K)JJ=J+1 3 DO 4 I=1,N AEL(I,J) = A(I,JJ) 4 CONTINUE 2 CONTINUE 9 CONTINUE RETURN END SUBROUTINE TIMREG(IDAT,ITIME,IUSER) C% ZEIT IN [HR.MIN] , DATUM IN [DY.MT.YR] , INITIALEN DES BENUETZERS C% REGISTRIEREN INTEGER*2 ITIMDA(15),IDAT(3),ITIME(2),IUSER(3) CALL TIMDAT(ITIMDA,15) IDAT(1) = ITIMDA(2) IDAT(2) = ITIMDA(1) IDAT(3) = ITIMDA(3) ITIME(1) = ITIMDA(4)/60 ITIME(2) = ITIMDA(4)-ITIME(1)*60 IUSER(1) = ITIMDA(13) IUSER(2) = ITIMDA(14) IUSER(3) = ITIMDA(15) RETURN END $$$ SUBROUTINE RDNET(INET,NP,NP1,P0,NAME,P,NFIX,LPRINT,NONET,NUNET, 1 NH,NUH,NNOR,NTIT) C READ STORED ADJUSTMENT DATA OF NETWORKS FROM INPUTFILE INTEGER*2 I INET, I ITIM(15), N NAME(30,4), N NAMFIX(4), N NONET(50), N NUNET(50), N NTIT(40) REAL*8 P P0(2), P P(30,2) LOGICAL LPRINT NP = 0 READ(5,5000)(NTIT(J),J=1,40) 5000 FORMAT(40A2) IF(INET.EQ.1)WRITE(6,6901) WRITE(6,6014)INET,(NTIT(J),J=1,40) 6014 FORMAT(1H /' NETWORK # ',I2,2X,': ',40A2//) READ(5,5051) NFIX 5051 FORMAT(I3) IF(NFIX.GT.1)GOTO 902 IF(NFIX.EQ.1)READ(5,5001,END=901)NAMFIX,P0 IF(INET.EQ.1)WRITE(6,6005) 6005 FORMAT(1H //' NAME',11X,'POSITION'/16X,'X',12X,'Y'//) 1 DO 2 I=1,30 READ(5,5001,END=901)(NAME(I,J),J=1,4),(P(I,J),J=1,2) 5001 FORMAT(4A2,2F15.4) 3 IF(NAME(I,1).EQ.'$$') GOTO 4 IF(INET.EQ.1)WRITE(6,6001)(NAME(I,J),J=1,4),(P(I,J),J=1,2) 6001 FORMAT(1H ,4A2,2F13.4) 2 CONTINUE NP = 1 4 CONTINUE C READ NUMBER OF OBSERVATIONS, UNKNOWNS AND DEGREES OF FREEDOM READ(5,5002) NNO,NNP,NN,NND,NIDF,NZERO,NH,NUH 5002 FORMAT(8I4) NONET(INET) = NNO + 2*NNP NUNET(INET) = NND + NZERO NP = NP + I -1 NP1 = NP 51 IF(NFIX.NE.1) GOTO 52 NP1 = NP + 1 61 DO 62 I=1,4 NAME(NP1,I) = NAMFIX(I) 62 CONTINUE P(NP1,1) = P0(1) P(NP1,2) = P0(2) 52 CONTINUE C READ NORMAL EQUATIONS NNOR = 2 * NP + NUH CALL TIMDAT(ITIM,15) WRITE(1,1691)(ITIM(JT),JT=4,10) 1691 FORMAT('#3',7I6) CALL NREAD(INET,NP,NNOR,5,LPRINT) C READ DESIGN MATRICES AND STORE THEM CALL TIMDAT(ITIM,15) WRITE(1,1692)(ITIM(JT),JT=4,10) 1692 FORMAT('#4',7I6) CALL AREAD(INET,5) C IF(LPRINT) CALL AWRIT(INET,6) CALL TIMDAT(ITIM,15) WRITE(1,1693)(ITIM(JT),JT=4,10) 1693 FORMAT('#5',7I6) C CALL ASTOR1(INET) CALL AWRITB(INET,8) RETURN C NEW PAGE COMMAND 6901 FORMAT(' '/) C ERROR MESSAGES 901 CONTINUE WRITE(1,1901) 1901 FORMAT('***ERROR IN RDNET***'/) RETURN 902 CONTINUE WRITE(1,1902) 1902 FORMAT('***MORE THAN 1 FIXED STATION***'/) RETURN END SUBROUTINE NREAD(INET,NP,N12,IFIL,LPRINT) C READ NORMAL EQUATIONS OF NETWORKS FROM INPUT FILE REAL*8 N NI(90,90), U UI(90,1) LOGICAL LPRINT COMMON /COM3/NI,UI DATA N N12DIM/90/ 73 DO 74 I=1,N12 JSTART = I READ(IFIL,5052)(NI(I,J),J=JSTART,N12) 5052 FORMAT(4D20.13) 74 CONTINUE 75 DO 76 I=1,N12 READ(IFIL,5053)UI(I,1) 5053 FORMAT(D20.13) 76 CONTINUE C DUPLICATE ELEMENTS IN UPPER HALF FILLED SYMMETRIC MATRIX CALL DMTSYM(NI,N12DIM,N12) 81 IF(.NOT.LPRINT) GOTO 82 WRITE(6,6111) 6111 FORMAT(' NI'/) CALL DMTOUT(NI,N12DIM,N12DIM,N12,N12,6,'D','5') WRITE(6,6121) 6121 FORMAT(' UI'/) CALL DMTOUT(UI,N12DIM,1,N12,1,6,'D','5') 82 CONTINUE RETURN END SUBROUTINE NWRIT(INET,NP,N12,IFIL) C WRITE NORMAL EQUATIONS OF NETWORKS REAL*8 N NI(90,90), U UI(90,1) COMMON /COM3/NI,UI 73 DO 74 I=1,N12 JSTART = I WRITE(IFIL,5052)(NI(I,J),J=JSTART,N12) 5052 FORMAT(4D20.13) 74 CONTINUE 75 DO 76 I=1,N12 WRITE(IFIL,5053)UI(I,1) 5053 FORMAT(D20.13) 76 CONTINUE RETURN END SUBROUTINE AWRIT(INET,IFI) LT LT C WRITE DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS ON PUNCH- LT C FILE LT IMPLICIT REAL*8 (A-H,O-Z) DIMENSION IOB(130,4),A(130,6),W(130),WX(60),ICA(130,6),ICP(121), 1 SPX(60,60),DOBR(130,4) LT LT COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR WRITE(IFI,5201)NO,NP,NV,NR 5201 FORMAT(4I4) LT LT 1 DO 2 I=1,NO LT WRITE(IFI,5202)(IOB(I,J),J=1,4) WRITE(IFI,5203)(A(I,J),J=1,6) WRITE(IFI,5203)W(I) WRITE(IFI,5202)(ICA(I,J),J=1,6) WRITE(IFI,5203)(DOBR(I,J),J=1,4) 5202 FORMAT(I5) 5203 FORMAT(D20.13) 2 CONTINUE LT IF(NR.LE.0) GOTO 8 11 DO 12 I=1,NR WRITE(IFI,5202) ICP(I) 12 CONTINUE 3 DO 4 I=1,NNOR LT WRITE(IFI,5203)WX(I),(SPX(I,J),J=1,NNOR) LT 4 CONTINUE LT 8 CONTINUE RETURN LT END LT SUBROUTINE AWRITB(INET,IFI) LT LT C WRITE DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS ON PUNCH- LT C FILE LT IMPLICIT REAL*8 (A-H,O-Z) DIMENSION IOB(130,4),A(130,6),W(130),WX(60),ICA(130,6),ICP(121), 1 SPX(60,60),DOBR(130,4) LT LT COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR WRITE(IFI)NO,NP,NV,NR 5201 FORMAT(4I4) LT 1 DO 2 I=1,NO LT WRITE(IFI)(IOB(I,J),J=1,4) WRITE(IFI)(A(I,J),J=1,6) WRITE(IFI)W(I) WRITE(IFI)(ICA(I,J),J=1,6) WRITE(IFI)(DOBR(I,J),J=1,4) 2 CONTINUE LT IF(NR.LE.0) GOTO 8 11 DO 12 I=1,NR WRITE(IFI) ICP(I) 12 CONTINUE 3 DO 4 I=1,NNOR LT WRITE(IFI)WX(I),(SPX(I,J),J=1,NNOR) LT 4 CONTINUE LT 8 CONTINUE RETURN LT END SUBROUTINE AREAD(INET,IFI) LT LT C READ DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS FROM PUNCH- LT C FILE LT IMPLICIT REAL*8 (A-H,O-Z) DIMENSION IOB(130,4),A(130,6),W(130),WX(60),ICA(130,6),ICP(121), 1 SPX(60,60),DOBR(130,4) LT LT COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR READ(IFI,5201)NO,NP,NV,NR C WRITE(1,5201)NO,NP,NV,NR 5201 FORMAT(4I4) LT LT 1 DO 2 I=1,NO LT READ(IFI,5202)(IOB(I,J),J=1,4) READ(IFI,5203)(A(I,J),J=1,6) READ(IFI,5203)W(I) READ(IFI,5202)(ICA(I,J),J=1,6) READ(IFI,5203)(DOBR(I,J),J=1,4) 5202 FORMAT(I5) 5203 FORMAT(D20.13) 2 CONTINUE LT IF(NR.LE.0)GOTO 8 11 DO 12 I=1,NR READ(IFI,5202) ICP(I) 12 CONTINUE 3 DO 4 I=1,NNOR LT READ(IFI,5203)WX(I),(SPX(I,J),J=1,NNOR) LT 4 CONTINUE LT 8 CONTINUE RETURN LT END LT SUBROUTINE AREADB(INET,IFI) LT LT C READ DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS FROM PUNCH- LT C FILE LT IMPLICIT REAL*8 (A-H,O-Z) DIMENSION IOB(130,4),A(130,6),W(130),WX(60),ICA(130,6),ICP(121), 1 SPX(60,60),DOBR(130,4) LT LT COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR READ(IFI)NO,NP,NV,NR C WRITE(1,5201)NO,NP,NV,NR 5201 FORMAT(4I4) LT LT 1 DO 2 I=1,NO LT READ(IFI)(IOB(I,J),J=1,4) READ(IFI)(A(I,J),J=1,6) READ(IFI)W(I) READ(IFI)(ICA(I,J),J=1,6) READ(IFI)(DOBR(I,J),J=1,4) 2 CONTINUE LT IF(NR.LE.0)GOTO 8 11 DO 12 I=1,NR READ(IFI) ICP(I) 12 CONTINUE 3 DO 4 I=1,NNOR LT READ(IFI)WX(I),(SPX(I,J),J=1,NNOR) 4 CONTINUE LT 8 CONTINUE RETURN LT END $$$ REAL*8 FUNCTION THETA(T,M) C ALGEBRAIC TIME POLYNOMIAL WITH LINEAR EPISODES REAL*8 T,BE(10,2) COMMON /EPISOD/ BE,N THETA = 1.D0 IF(M.EQ.0) RETURN 3 IF(M.GT.N) GOTO 4 1 DO 2 I=1,M THETA = THETA * T 2 CONTINUE RETURN 4 CONTINUE ME = M - N THETA = 0.D0 IF(T.GE.BE(ME,1).AND.T.LE.BE(ME,2)) 1 THETA=(T-BE(ME,1))/(BE(ME,2)-BE(ME,1)) IF(T.GT.BE(ME,2)) THETA = 1.D0 RETURN END REAL*8 FUNCTION DTHETA(T,M) C DERIVATIVE OF THE ALGEBRAIC TIME POLYNOMIAL WITH LINEAR EPISODES REAL*8 T,T1,BE(10,2) COMMON /EPISOD/ BE,N DTHETA = 0.D0 IF(M.EQ.0) RETURN T1 = 1.D0 DTHETA = T1 IF(M.EQ.1) RETURN 3 IF(M.GT.N) GOTO 4 1 DO 2 I=2,M T1 = T1 * T 2 CONTINUE DTHETA = M * T1 RETURN 4 CONTINUE ME = M - N DTHETA = 0.D0 IF(T.GE.BE(ME,1).AND.T.LE.BE(ME,2))DTHETA=1.D0/(BE(ME,2)-BE(ME,1)) RETURN END SUBROUTINE CALPOL(PHI,Z,MDIM,N,M) C BASEFUNCTION OF THE GENERALIZED COMPLEX ALGEBRAIC POLYNOMIAL INTEGER N N, /* POWER OF COMPLEX ALGEBRAIC POLYNOMIAL N NPER(5,2), /* VECTOR OF BEGINNING/ENDING # OF POLYGON VERTICES M M /* NUMBER OF TERMS (INCLUDING BLOCK MOTIOM TERMS) REAL*4 A AZ, B BLOCA(5), P PINPOL COMPLEX*8 P P,PHI(1,MDIM), Z Z, Z ZP(50) COMMON /BLOCK/ ZP,NPER,BLOCA N1 = N+1 PHI(1,1) = (0.,0.) IF(N.LE.0) GOTO 7 P = (1.,0.) 1 DO 2 I=1,N P = P * Z PHI(1,I) = P 2 CONTINUE 7 IF(M.LE.N) GOTO 8 3 DO 4 I=N1,M IBLOC = I-N PHI(1,I) = (0.,0.) AZ = BLOCA(IBLOC) IF(AZ.GT.6.28318) AZ = 0. PHI(1,I) = CMPLX(COS(AZ),SIN(AZ)) 1 * PINPOL(Z,ZP,NPER(IBLOC,1),NPER(IBLOC,2),3) 4 CONTINUE 8 CONTINUE RETURN END SUBROUTINE DCALPO(PHI,Z,MDIM,N,M) C DERIVATIVE OF THE BASEFUNCTION OF THE COMPLEX ALGEBRAIC POLYNOMIAL INTEGER*2 N N, /* DEG. OF ALGEBRAIC POLYNOMIAL M M, /* TOTAL DEG. OF GENERALIZED POLYNOMIAL M MDIM /* MAX. DIMENSION OF BASE FUNCTION COMPLEX*8 P P,PHI(1,MDIM), Z Z N1 = N+1 PHI(1,1) = (0.,0.) IF(N.EQ.0) GOTO 7 P = (1.,0.) PHI(1,1) = P IF(N.EQ.1) GOTO 7 1 DO 2 I=2,N P = P * Z PHI(1,I) = I*P 2 CONTINUE 7 IF(M.LE.N) GOTO 8 3 DO 4 I=N1,M PHI(1,I) = (0.,0.) 4 CONTINUE 8 CONTINUE RETURN END $$$ SUBROUTINE PREDIC(DA,CHI,PSI,CDA,CCHIPS,Z,CPXX,MDIM,MCONF, 1 MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1,LCOVAR) C PREDICTION OF COMPLEX DISPLACEMENTS AND STRAIN COMPONENTS REAL*8 A AK(2,240), C CX(240,240), C CXAKT(240,2), C CDA(2,2), D D0(2), D DFACT2, D DTHETA, D DTIMN, A AL(4,240), C CXALT(240,4), C CCHIPS(4,4), R RPHI(2,24), S SCALD, S SCALR, S SFACT2, T T(10), T THETA REAL*4 T TIMSPA COMPLEX*8 D DA(1,1), C CHI, P PHI(1,12), P PSI, C CPXX(120,1), Z Z, Z ZC, C CPXK(1,120), C CPXL(2,120), C CHIPSI(2,1) LOGICAL LCOVAR COMMON /COM2/ CX COMMON /COMP/ AK,CXAKT,CPXK COMMON /COMZ/ AL,CXALT,CPXL NU2 = 2*NU NCC = NU*MT NRC = NCC*2 MCONF2 = 2*MCONF C TIME FUNCTIONS 19 DO 20 I=1,MT IF(IABS(IPREDO).EQ.1) T(I) = THETA(DTIMN,I) IF(IABS(IPREDO).EQ.2) T(I) = DTHETA(DTIMN,I) / (TIMSPA/2.) 20 CONTINUE C CONFORMAL TERMS CALL CALPOL(PHI,Z,MDIM,MCONF1,MCONF) CALL DMREAL(PHI,RPHI,1,12,2,24,1,MCONF) JT=0 JJT=0 11 DO 12 IT=1,MT 1 DO 2 J=1,MCONF CPXK(1,JT+J) = PHI(1,J) * SNGL(T(IT)) IF(.NOT.LCOVAR) GOTO 2 JJ=2*J-1 31 DO 32 II=1,2 AK(II,JJT+JJ) = RPHI(II,JJ) * T(IT) AK(II,JJT+JJ+1) = RPHI(II,JJ+1) * T(IT) 32 CONTINUE 2 CONTINUE JT=JT+NU JJT=JJT+NU2 12 CONTINUE CALL DCALPO(PHI,Z,MDIM,MCONF1,MCONF) CALL DMREAL(PHI,RPHI,1,12,2,24,1,MCONF) JT=0 JJT=0 13 DO 14 IT=1,MT 3 DO 4 J=1,MCONF CPXL(1,JT+J) = PHI(1,J) * SNGL(T(IT)) CPXL(2,JT+J) = (0.,0.) IF(.NOT.LCOVAR) GOTO 4 JJ=2*J-1 33 DO 34 II=1,2 AL(II,JJT+JJ) = RPHI(II,JJ) * T(IT) AL(II,JJT+JJ+1) = RPHI(II,JJ+1) * T(IT) AL(II+2,JJT+JJ) = 0.D0 AL(II+2,JJT+JJ+1) = 0.D0 34 CONTINUE 4 CONTINUE JT=JT+NU JJT=JJT+NU2 14 CONTINUE C ANTICONFORMAL TERMS ZC = CONJG(Z) CALL CALPOL(PHI,ZC,MDIM,MANTIC,MANTIC) CALL DMREAL(PHI,RPHI,1,12,2,24,1,MANTIC) JT=0 JJT=0 15 DO 16 IT=1,MT 5 DO 6 J=1,MANTIC CPXK(1,MCONF+JT+J) = PHI(1,J) * SNGL(T(IT)) IF(.NOT.LCOVAR) GOTO 6 JJ=J*2-1 35 DO 36 II=1,2 AK(II,MCONF2+JJT+JJ) = RPHI(II,JJ) * T(IT) AK(II,MCONF2+JJT+JJ+1) = RPHI(II,JJ+1) * T(IT) 36 CONTINUE 6 CONTINUE JT=JT+NU JJT=JJT+NU2 16 CONTINUE CALL DCALPO(PHI,ZC,MDIM,MANTIC,MANTIC) CALL DMREAL(PHI,RPHI,1,12,2,24,1,MANTIC) JT=0 JJT=0 17 DO 18 IT=1,MT 7 DO 8 J=1,MANTIC CPXL(1,MCONF+JT+J) = (0.,0.) CPXL(2,MCONF+JT+J) = PHI(1,J) * SNGL(T(IT)) IF(.NOT.LCOVAR) GOTO 8 JJ=J*2-1 37 DO 38 II=1,2 AL(II,MCONF2+JJT+JJ) = 0.D0 AL(II,MCONF2+JJT+JJ+1) = 0.D0 AL(II+2,MCONF2+JJT+JJ) = RPHI(II,JJ) * T(IT) AL(II+2,MCONF2+JJT+JJ+1) = RPHI(II,JJ+1) * T(IT) 38 CONTINUE 8 CONTINUE JT=JT+NU JJT=JJT+NU2 18 CONTINUE C COMPLEX DISPLACEMENTS CALL CMTMLT(DA,CPXK,CPXX,1,120,1,1,NCC,1) DA(1,1) = DA(1,1)*SNGL(SCALD) + CMPLX(SNGL(D0(1)),SNGL(D0(2))) IF(CABS(DA(1,1)).GE.100.) DA(1,1) = (0.,0.) C COMPLEX STRAIN COMPONENTS CALL CMTMLT(CHIPSI,CPXL,CPXX,2,120,1,2,NCC,1) SFACT = 1.E6/SCALR CHI = CHIPSI(1,1) * SFACT PSI = CHIPSI(2,1) * SFACT IF(CABS(CHI).GE.1000.) CHI = (0.,0.) IF(CABS(PSI).GE.1000.) PSI = (0.,0.) C COVARIANCE MATRICES IF(.NOT.LCOVAR) RETURN CALL DMTMLT(CXAKT,CX,AK,240,240,2,NRC,NRC,2,2) CALL DMTMLT(CDA,AK,CXAKT,2,240,2,2,NRC,2,0) DFACT2 = SCALD*SCALD CALL DMTSCL(CDA,CDA,DFACT2,2,2,2,2) CALL DMTMLT(CXALT,CX,AL,240,240,4,NRC,NRC,4,2) CALL DMTMLT(CCHIPS,AL,CXALT,4,240,4,4,NRC,4,0) SFACT2 = SFACT*SFACT CALL DMTSCL(CCHIPS,CCHIPS,SFACT2,4,4,4,4) RETURN END SUBROUTINE EVALU(RMAJ,RMIN,THETA,CHI,PSI) C LENGTH AND ORIENTATION OF SEMI-MAJOR AND MINOR AXES OF THE STRAIN C ELLIPSE FROM COMPLEX STRAIN COMPONENTS COMPLEX*8 C CHI, P PSI THETA = 0. SQR = SQRT(REAL(PSI)**2 + AIMAG(PSI)**2) RMAJ = REAL(CHI) + SQR RMIN = REAL(CHI) - SQR 1 IF(CABS(PSI).LT.1.E-20) GOTO 2 THETA = ATAN2(AIMAG(PSI),REAL(PSI))/2. 2 CONTINUE RETURN END SUBROUTINE TSHEAR(TSHR,SHRAZ,STSHR,SSHRAZ,PSI,CCHIPS) C TOTAL SHEAR, AZIMUTH OF TOTAL SHEAR REAL*4 S SHRAZ, T TSHR REAL*8 A A(1,4), A AC(1,4), C CCHIPS(4,4), S STSHR, S SSHRAZ COMPLEX*8 P PSI RHOGON = 50./ATAN(1.) SHRAZ = 0. STSHR = 0.D0 SSHRAZ = 0.D0 C TOTAL SHEAR TSHR = CABS(PSI) C AZIMUTH OF MAX. SHEAR 1 IF(TSHR.LT.1.E-12) GOTO 2 SHRAZ = ATAN2(AIMAG(PSI),REAL(PSI))/2. SHRAZ = 100. - (SHRAZ * RHOGON + 50.) C VARIANCE OF TOTAL SHEAR A(1,1) = 0.D0 A(1,2) = 0.D0 A(1,3) = REAL(PSI)/TSHR A(1,4) = AIMAG(PSI)/TSHR CALL DMTMLT(AC,A,CCHIPS,1,4,4,1,4,4,0) CALL DMTMLT(STSHR,AC,A,1,4,1,1,4,1,2) IF(STSHR.LE.0.D0) STSHR = 0.D0 STSHR = DSQRT(STSHR) C VARIANCE OF AZIMUTH TSHR22 = 2. * TSHR * TSHR A(1,3) = - AIMAG(PSI) / TSHR22 A(1,4) = REAL(PSI) / TSHR22 CALL DMTMLT(AC,A,CCHIPS,1,4,4,1,4,4,0) CALL DMTMLT(SSHRAZ,AC,A,1,4,1,1,4,1,2) IF(SSHRAZ.LE.0.D0) SSHRAZ = 0.D0 SSHRAZ = DSQRT(SSHRAZ) * RHOGON 2 CONTINUE RETURN END REAL*4 FUNCTION PINPOL(ZQ,ZP,NB,NE,ICODE) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * UNIVERSITY OF NEW BRUNSWICK * C * FREDERICTON, 1980 * C * * C **************************************************************** C C DETERMINES WHETHER A POINT IS OUTSIDE,INSIDE,ON A VERTICE OR ON A C SIDE OF A POLYGON C C ICODE IN ON SIDE ON VERTICE OUT C 1 1. 0. 0. 0. C 2 1. 1. 1. 0. C 1 1. 0.5 0.5 0. C C VARIABLES: P(X,Y): POLYGON VERTICES C Q(X,Y): TESTPOINTS, CR: RESULT CODE C A(I),B: AREA*2 OF TRIANGLE C XMIN,XMAX,YMIN,YMAX: COORD. OF CIRCUMRECTANGLE C CIN: NUMBER OF SAMEORIENTED TRIANGLES WHERE Q IS IN C NB: # OF 1-ST VERTICE OF POLYGON C NE: # OF LAST (=1-ST) VERTICE IMPLICIT REAL*8(A-H,O-Z) REAL*8 A A(50), A ARE2, C C,CIN,CR, P P(50,2), Q Q(2),Q1,Q2, X XMAX,XMIN, Y YMAX,YMIN COMPLEX*8 Z ZQ, Z ZP(50) C STATEMENT FUNCTION DEFINITION ARE2(X1,Y1,X2,Y2,X3,Y3)=- X1*Y2-X2*Y3-X3*Y1+Y1*X2+Y2*X3+Y3*X1 N1 = NE-1 C 51 DO 52 I=NB,NE P(I,1) = INT(REAL(ZP(I))*1.E3) P(I,2) = INT(AIMAG(ZP(I))*1.E3) 52 CONTINUE C DETERMINE AREA (ORIENT.) OF TRIANGEL(NB,I,I+1) AND CIRCUMRECTANGLE XMIN=P(NB,1) XMAX=P(NB,1) YMIN=P(NB,2) YMAX=P(NB,2) AREA=0.D0 3 DO 4 I=NB,N1 XMIN=DMIN1(XMIN,P(I,1)) XMAX=DMAX1(XMAX,P(I,1)) YMIN=DMIN1(YMIN,P(I,2)) YMAX=DMAX1(YMAX,P(I,2)) A(I)=ARE2(P(NB,1),P(NB,2),P(I,1),P(I,2),P(I+1,1),P(I+1,2)) AREA=AREA+A(I) 4 CONTINUE C Q1 = INT(REAL(ZQ)*1.E3) Q2 = INT(AIMAG(ZQ)*1.E3) CIN=0.D0 CR=0.D0 C C IS POINT Q IN CIRCUMRECTANGLE IF(Q1.LT.XMIN.OR.Q1.GT.XMAX.OR.Q2.LT.YMIN.OR.Q2.GT.YMAX)GOTO 6 C C IS Q IN TRIANGLE NB,I,I+1 7 DO 8 I=NB,N1 B=ARE2(P(NB,1),P(NB,2),P(I,1),P(I,2),Q1,Q2) IF(DABS(A(I))-DABS(B).LT.0.D0)GOTO 8 C=1.D0 S = A(I)*B IF(DABS(S).LT.1.D-4)GOTO 20 19 IF(S)8,20,21 20 C=0.5D0 21 I1=I+1 B=ARE2(P(I1,1),P(I1,2),P(NB,1),P(NB,2),Q1,Q2) IF(DABS(A(I))-DABS(B).LT.0.D0)GOTO 8 S = A(I)*B IF(DABS(S).LT.1.D-4) GOTO 23 22 IF(S)8,23,24 23 C=0.5D0 24 B=ARE2(P(I,1),P(I,2),P(I1,1),P(I1,2),Q1,Q2) S = A(I)*B IF(DABS(S).LT.1.D-4) GOTO 26 25 IF(S)8,26,27 C C SPECIAL CASE: AREA(TRIANGLE)=0 26 IF(DABS(A(I)).GT.1.D-3)GOTO 29 S=(Q1-P(I,1))*(Q1-P(I1,1))+(Q2-P(I,2))*(Q2-P(I1,2)) IF(DABS(S).LT.1.D-4) GOTO 29 IF(S)30,29,8 30 C=1.D0 29 CONTINUE CR = 2.D0*C + 1.D0 5 GOTO 6 27 CIN=CIN+DSIGN(C,A(I)*AREA) 8 CONTINUE CR=CIN 6 CONTINUE C C SET VALUE OF FUNCTION PINPOL = 0.D0 IF(ICODE.EQ.1.AND.CR.EQ.1.D0) PINPOL = 1.0 IF(ICODE.EQ.2.AND.CR.GT.0.D0) PINPOL = 1.0 IF(ICODE.EQ.3.AND.CR.EQ.1.D0) PINPOL = 1.0 IF(ICODE.EQ.3.AND.CR.GE.2.D0) PINPOL = 0.5 RETURN END SUBROUTINE BLOC(ZBLC,NPER,MBLOC,XYBLOC,SXYBLC,BLOCAZ,CPXX, 1MDIM,MCONF,MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1) C PREDICTION OF COMPLEX BLOC MOTION INTEGER*2 N NPER(5,2) REAL*8 A A(2,4), A ACC(2,4), A AL(4,240), B BLOCAZ(15), C CX(240,240), C CXALT(240,4), C CCBLOC(4,4), C CDBLOC(2,2), D D0(2), D DFACT2, D DTHETA, D DTIMN, R RHOGON, S S, S SCALD, S SCALR, S SFACT2, S SXYBLC(15,2), T THETA, X X, X XYBLOC(15,2), Y Y REAL*4 T T(10), T TIMSPA COMPLEX*8 C CBLOC(2,1), P PHII(1,12), P PHIJ(1,12), C CPXX(120,1), C CPXL(2,120), Z ZBLC(50), Z ZI,ZJ COMMON /COM2/ CX COMMON /COMZ/ AL,CXALT,CPXL RHOGON = 50.D0/DATAN(1.D0) NCC = NU*MT NRC = NCC*2 CALL DMTSCL(A,A,0.D0,2,4,2,4) A(1,1) = 1.D0 A(2,2) = 1.D0 A(1,3) = -1.D0 A(2,4) = -1.D0 C TIME FUNCTIONS 19 DO 20 I=1,MT IF(IABS(IPREDO).EQ.1) T(I) = THETA(DTIMN,I) IF(IABS(IPREDO).EQ.2) T(I) = DTHETA(DTIMN,I) / (TIMSPA/2.) 20 CONTINUE IJ=1 ZI = (0.,0.) MBLOC1 = MBLOC-1 3 DO 4 IBLOC = 0,MBLOC1 IBLOC1 = IBLOC + 1 5 DO 6 JBLOC = IBLOC1,MBLOC IF(IBLOC.NE.0) ZI = ZBLC(NPER(IBLOC,2)+1) ZJ = ZBLC(NPER(JBLOC,2)+1) 31 DO 32 I=1,NCC CPXL(1,I) = (0.,0.) CPXL(2,I) = (0.,0.) 32 CONTINUE C CONFORMAL TERMS CALL CALPOL(PHII,ZI,MDIM,MCONF1,MCONF) CALL CALPOL(PHIJ,ZJ,MDIM,MCONF1,MCONF) JT=0 11 DO 12 IT=1,MT 1 DO 2 J=1,MCONF IF(J.GT.MCONF1) CPXL(1,JT+J) = PHII(1,J) * T(IT) IF(J.GT.MCONF1) CPXL(2,JT+J) = PHIJ(1,J) * T(IT) 2 CONTINUE JT=JT+NU 12 CONTINUE C COMPLEX DISPLACEMENTS CALL CMTMLT(CBLOC,CPXL,CPXX,2,120,1,2,NCC,1) CBLOC(1,1) = CBLOC(1,1)*SNGL(SCALD) 1 + CMPLX(SNGL(D0(1)),SNGL(D0(2))) CBLOC(2,1) = CBLOC(2,1)*SNGL(SCALD) 1 + CMPLX(SNGL(D0(1)),SNGL(D0(2))) C COVARIANCE MATRICES CALL DMREAL(CPXL,AL,2,120,4,240,2,NCC) CALL DMTMLT(CXALT,CX,AL,240,240,4,NRC,NRC,4,2) CALL DMTMLT(CCBLOC,AL,CXALT,4,240,4,4,NRC,4,0) DFACT2 = SCALD*SCALD CALL DMTSCL(CCBLOC,CCBLOC,DFACT2,4,4,4,4) CALL DMTMLT(ACC,A,CCBLOC,2,4,4,2,4,4,0) CALL DMTMLT(CDBLOC,ACC,A,2,4,2,2,4,2,2) X = REAL(CBLOC(2,1)-CBLOC(1,1)) Y = AIMAG(CBLOC(2,1)-CBLOC(1,1)) XYBLOC(IJ,1) = X XYBLOC(IJ,2) = Y BLOCAZ(IJ) = 0.D0 IF(X.NE.0.D0.AND.Y.NE.0.D0) BLOCAZ(IJ) = DATAN2(X,Y) * RHOGON S = CDBLOC(1,1) IF(S.LT.0.D0)S=0.D0 SXYBLC(IJ,1) = DSQRT(S) S= CDBLOC(2,2) IF(S.LT.0.D0)S=0.D0 SXYBLC(IJ,2) = DSQRT(S) IJ=IJ+1 6 CONTINUE 4 CONTINUE RETURN END REAL*8 FUNCTION DROSET(PHI,PSI) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * WABERN, 1981 * C * * C **************************************************************** C C RADIAL DISTANCE OF ROSETTE CURVE (FOR PLOTTING ROUTINE POLAR) REAL*4 P PHI COMPLEX*8 C C, P PSI C = CMPLX(COS(PHI),SIN(PHI)) DROSET = AIMAG(PSI*CONJG(C)**2) RETURN END REAL*8 FUNCTION CROSET(PHI,CCHIPS) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * WABERN, 1981 * C * * C **************************************************************** C C RADIAL DISTANCE OF BOUNDARY OF STANDARD COFIDENCE REGION OF C SHEAR IN A GIVEN DIRECTION REAL*8 A AR(2,4), C CART(4,2), C CCHIPS(4,4), C CE(2,2) REAL*4 P PHI COMPLEX*8 A A(1,2), C C C = CMPLX(COS(PHI),SIN(PHI)) A(1,1) = (0.,0.) A(1,2) = CONJG(C)**2 CALL DMREAL(A,AR,1,2,2,4,1,2) CALL DMTMLT(CART,CCHIPS,AR,4,4,2,4,4,2,2) CALL DMTMLT(CE,AR,CART,2,4,2,2,4,2,0) IF(CE(2,2).LT.0.D0) CE(2,2)=0.D0 CROSET = DSQRT(CE(2,2)) RETURN END $$$ SUBROUTINE DMTMLT(C,A,B,DIMN,DIMM,DIML,N,M,L,NT) C% C% C% C% PRODUKT ZWEIER MATRIZEN IN ALLEN ERLAUBTEN TRANSPONIERTEN C% C% KOMBINATIONEN (DOUBLE PRECISION) C% C% NT=0) C(DIMN,DIML) = A(DIMN,DIMM) * B(DIMM,DIML) C% C% NT=1) C(DIMN,DIML) = A(DIMM,DIMN)T * B(DIMM,DIML) C% C% NT=2) C(DIMN,DIML) = A(DIMN,DIMM) * B(DIML,DIMM)T C% C% NT=3) C(DIMN,DIML) = A(DIMM,DIMN)T * B(DIML,DIMM)T C% C% N,M,L: AKTUELLE PARAMETER C% C% DIMN,DIMM,DIML: DIMENSIONEN IM HAUPTPROGRAMM C% C% C BUNDESAMT FUER LANDESTOPOGRAPHIE C% C D.SCHNEIDER C% C WABERN, 1981 C% C% C% C% INTEGER*2 N,M,L,DIMN,DIMM,DIML,NT C% INTEGER*2 I,J,K,NT1 INTEGER*4 IM,JM,KL,KN REAL*8 C,A,B,AEL,BEL,CIJ C% DIMENSION C(DIMN,DIML),A(1),B(1) C TEST DER ARRAYDIMENSIONEN: 41 IF(N.LE.DIMN.AND.M.LE.DIMM.AND.L.LE.DIML)GOTO 42 WRITE(1,9901)N,DIMN,M,DIMM,L,DIML 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTMLT***'/ 1 'N = ',I4,' DIMN = ',I4/ 2 'M = ',I4,' DIMM = ',I4/ 3 'L = ',I4,' DIML = ',I4/) 42 CONTINUE IF(N.EQ.0.OR.M.EQ.0.OR.L.EQ.0) RETURN NT1 = NT+1 GOTO (100,101,102,103),NT1 C A*B 100 CONTINUE 1 DO 2 I=1,N JM=0 3 DO 4 J=1,L CIJ = 0.D0 KN=I 5 DO 6 K=1,M AEL = A(KN) BEL = B(K+JM) KN = KN+DIMN 7 IF(AEL.EQ.0.D0.OR.BEL.EQ.0.D0) GOTO 8 CIJ = CIJ + AEL * BEL 8 CONTINUE 6 CONTINUE C(I,J) = CIJ JM=JM+DIMM 4 CONTINUE 2 CONTINUE RETURN C AT*B 101 CONTINUE IM=0 11 DO 12 I=1,N JM=0 13 DO 14 J=1,L CIJ = 0.D0 15 DO 16 K=1,M AEL = A(K+IM) BEL = B(K+JM) 17 IF(AEL.EQ.0.D0.OR.BEL.EQ.0.D0) GOTO 18 CIJ = CIJ + AEL * BEL 18 CONTINUE 16 CONTINUE C(I,J) = CIJ JM=JM+DIMM 14 CONTINUE IM=IM+DIMM 12 CONTINUE RETURN C A*BT 102 CONTINUE 21 DO 22 I=1,N 23 DO 24 J=1,L CIJ = 0.D0 KN=I KL=J 25 DO 26 K=1,M AEL = A(KN) BEL = B(KL) KN=KN+DIMN KL=KL+DIML 27 IF(AEL.EQ.0.D0.OR.BEL.EQ.0.D0) GOTO 28 CIJ = CIJ + AEL * BEL 28 CONTINUE 26 CONTINUE C(I,J) = CIJ 24 CONTINUE 22 CONTINUE RETURN C AT*BT 103 CONTINUE IM=0 31 DO 32 I=1,N 33 DO 34 J=1,L CIJ = 0.D0 KL=J 35 DO 36 K=1,M AEL = A(K+IM) BEL = B(KL) KL=KL+DIML 37 IF(AEL.EQ.0.D0.OR.BEL.EQ.0.D0) GOTO 38 CIJ = CIJ + AEL * BEL 38 CONTINUE 36 CONTINUE C(I,J) = CIJ 34 CONTINUE IM=IM+DIMM 32 CONTINUE RETURN END SUBROUTINE DMTSYM(A,NDIM,N) C DUPLICATE ELEMENTS IN UPPER HALF FILLED SYMMETRIC MATRICE INTEGER*2 N N, /* ACTUAL SIZE OF MATRIX N NDIM /* DIMENSION OF A REAL*8 A A(NDIM,NDIM) /* UPPER HALF FILLED MATRIX / SYMM. MATRIX C CHECK ARRAY DIMENSIONS 900 IF(N.GT.NDIM) GOTO 901 IF(N.LE.1) RETURN 1 DO 2 I=2,N IEND=I-1 3 DO 4 K=1,IEND A(I,K) = A(K,I) 4 CONTINUE 2 CONTINUE RETURN C ERROR MESSAGES 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' ***ARRAY SIZE EXCEEDS DIMENSIONS IN "MTSYM"***'/) RETURN END SUBROUTINE DMTSAD(A,ASUB,S,IROW,ICOL,M,N,MSUB,NSUB,MDIM,NDIM, 1 MSDIM,NSDIM) C ADDS SUBMATRIX S*ASUB TO A (REAL*8) C% INTEGER*2 C% I IROW,ICOL, /* INDIZES VON ASUB(1,1) IN A C% M M,MSUB, /* AKTUELLE DIMENSIONEN VON A,ASUB C% M MDIM,MSDIM, /* MAX.DIMENSION VON A , ASUB C% N N,NSUB, /* AKTUELLE DIMENSIONEN VON A,ASUB C% N NDIM,NSDIM /* MAX.DIMENSION VON A , ASUB C% C% REAL *8 C% A A(MDIM,NDIM), /* GANZE MATRIX C% A ASUB(MSDIM,NSDIM),/*SUB-MATRIX C% S S, /* SCALAR FACTOR S SASUB C% LOGICAL LS1 C PRUEFEN DER ARRAYGRENZEN 905 IF(IROW.LT.1.OR.IROW+MSUB.GT.M+1.OR.ICOL.LT.1.OR.ICOL+NSUB.GT.N+1) 1 GOTO 906 IF(M.EQ.0.OR.N.EQ.0.OR.MSUB.EQ.0.OR.NSUB.EQ.0) RETURN IF(S.EQ.0.D0) RETURN LS1 = .FALSE. IF(S.EQ.1.D0) LS1 = .TRUE. 1 DO 2 I=1,MSUB IA=IROW+I-1 3 DO 4 K=1,NSUB KA=ICOL+K-1 SASUB = ASUB(I,K) IF(.NOT.LS1) SASUB = S * SASUB A(IA,KA) = A(IA,KA) + SASUB 4 CONTINUE 2 CONTINUE RETURN C FEHLERMELDUNG 906 CONTINUE WRITE(1,9906)IROW,MSUB,M,ICOL,NSUB,N 9906 FORMAT(' ***ARRAY-UEBERSCHREITUNG (DMTSAD)***'/3I3/3I3/) RETURN END SUBROUTINE DCHOL1(C,A,NDIM,N,INDEF) C AUFLOESUNG DES SYMMETRISCH DEFINITEN GLEICHUNGSSYSTEMS A*X+B = 0 C NACH CHOLESKY C 1. SCHRITT: REDUKTION VON A AUF EINE OBERE DREIECKSMATRIX INTEGER*2 I INDEF, /* INDEF=0 FUER A: POS.-DEFINIT, ANDERNFALLS INDEF=1 N N, /* AKTUELLE DIMENSION DER KOEFFIZIENTEN-MATRIX N NDIM /* MAX. DIMENSION DER KOEFFIZIENTEN-MATRIX REAL*8 A A(NDIM,NDIM), /* KOEFFIZIENTEN-MATRIX C C(NDIM,NDIM) /* OBERE DREIECKSMATRIX INDEF=0 1 DO 2 I=1,N 11 IF(A(I,I).LE.1.D-12) GOTO 12 14 CONTINUE C LINKE SEITE VON C NULL SETZEN I1=I-1 9 DO 10 JL=1,I1 C(I,JL) = 0.D0 10 CONTINUE C REDUKTION DER ZEILEN C(I,I) = DSQRT(A(I,I)) M = I+1 3 DO 4 J=M,N C(I,J) = A(I,J)/C(I,I) 4 CONTINUE C REDUZIERTE OBERE DREIECKSMATRIX 5 DO 6 J=M,N 7 DO 8 K=J,N A(J,K) = A(J,K) - C(I,J)*C(I,K) 8 CONTINUE 6 CONTINUE 2 CONTINUE INDEF=0 RETURN 12 CONTINUE INDEF=1 WRITE(1,1901)I,A(I,I) WRITE(6,1901)I,A(I,I) 1901 FORMAT(1H ,'*** A INDEF. IN DCHOL1: I = ',I3,' ,A(I,I) = ',E13.6, 1 ' ***'/) A(I,I) = A(I,I) + 1.D9 13 GOTO 14 END SUBROUTINE DMTOUT(A,NDIM,MDIM,N,M,IOUT,IF1,IF2) C% C% C% C% OUTPUT VON GROSSEN MATRIZEN (DOUBLE PRECISION) C% DIMENSION A(NDIM,MDIM) C% REAL*8 A /* ZU DRUCKENDE MATRIX C% INTEGER*2 C% I IOUT, /* OUTPUT FTN-UNIT NUMMER C% I IF1, /* 'F' OR 'D' FORMAT C% I IF2, /* ANZ. DEZ.STELLEN DER ELEMENTE VON A (D12.'IF') C% N N,NDIM, /* AKTUELLE UND MAX.DIMENSION VON A C% M M,MDIM /* AKTUELLE UND MAX.DIMENSION VON A C% INTEGER*2 I,IFORM(20),J,K,MA,ME C% DATA IFORM/'(','1','H',' ','/',' ','1','X',',','I','3',',','1', 1 '0','D','1','2','.','0',')'/ C% BUNDESAMT FUER LANDESTOPOGRAPHIE C% C% D.SCHNEIDER C% C% WABERN 1981 C% C% C% C FORMAT FESTLEGEN IFORM(15) = IF1 IFORM(19) = IF2 C MATRIX DRUCKEN IF(M.EQ.0.OR.N.EQ.0) RETURN MA=1 ME=10 1 DO 2 K=1,10 IF(ME.GT.M) ME=M WRITE(IOUT,2001)(J,J=MA,ME) 3 DO 4 I=1,N WRITE(IOUT,IFORM)I,(A(I,J),J=MA,ME) 4 CONTINUE IF(ME.GE.M) RETURN MA=MA+10 2 ME=ME+10 RETURN 2001 FORMAT(1H / 6X,10(I3,9X)) END SUBROUTINE DMTADD(C,A,B,DIMN,DIMM,N,M) C% C% C% C% MATRIZENADDITION (DOUBLE PRECISION): C(N,M) = A(N,M)*B(N,M) C% C% N,M : AKTUELLE DIMENSIONEN C% C% DIMN,DIMM : DIMENSIONEN IM HAUPTPROGRAMM C% C% C% INTEGER*2 N,M,DIMN,DIMM C% REAL*8 A,B,C C% DIMENSION A(DIMN,DIMM),B(DIMN,DIMM),C(DIMN,DIMM) C% C% C TEST DER ARRAYDIMENSIONEN: 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 WRITE(1,9901)N,DIMN,M,DIMM 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTADD***'/ 1 'N = ',I4,' DIMN = ',I4/ 2 'M = ',I4,' DIMM = ',I4/) 22 CONTINUE IF(N.EQ.0.OR.M.EQ.0) RETURN 1 DO 2 I=1,N 3 DO 4 J=1,M C(I,J) = A(I,J)+B(I,J) 4 CONTINUE 2 CONTINUE RETURN END SUBROUTINE DMTINV(AIN,A,DIMN,N,ISING) C% C% C% C% INVERTIEREN DER MATRIX A(N,N) (DOUBLE PECISION) C% C% NACH DER DIAGONAL STRATEGIE C% C% MAX.DIMENSION : N=200 C% C% C% C% N,M: AKTUELLE DIMENSIONEN VON A UND AIN C% C% DIMN,DIMM: DIMENSIONEN VON A UND AIN IM HAUPTPROGRAMM C% INTEGER*2 N,DIMN,ISING C% INTEGER*2 I,J,P REAL*8 A,AIN C% REAL*8 KZ DIMENSION A(DIMN,DIMN),AIN(DIMN,DIMN) C% DIMENSION KZ(200) C TEST DER ARRAYDIMENSIONEN: 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 WRITE(1,9901)N,DIMN,M,DIMM 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTINV***'/ 1 'N = ',I4,' DIMN = ',I4/ 2 'M = ',I4,' DIMM = ',I4/) 22 CONTINUE ISING = 0 1 DO 2 I=1,N 3 DO4 J=1,N AIN(I,J)=A(I,J) 4 CONTINUE 2 CONTINUE C AUSTAUSCHVERFAHREN C 7 DO 8 P=1,N C TEST DER PIVOTS 31 IF((DABS(AIN(P,P)).GT.1.D-16.OR.DABS(AIN(P,P)).LT.1.D16).AND. 1 (DABS(AIN(P,P)).GT.DABS(A(P,P))*1.D-16)) GOTO 32 WRITE(1,2001)P,P,AIN(P,P) ISING=P 5 DO 6 I=1,N AIN(P,I)=0.D0 AIN(I,P)=0.D0 6 CONTINUE AIN(P,P)=1.D30 GOTO 8 32 CONTINUE C PIVOTELEMENT AIN(P,P)=1.D0/AIN(P,P) C KELLERZEILE SETZEN 11 DO 12 I=1,N KZ(I)=-AIN(P,I)*AIN(P,P) 12 CONTINUE C UEBRIGE ELEMENTE BERECHNEN 13 DO 14 I=1,N 23 IF(I.EQ.P) GOTO 24 15 DO 16 J=1,N 25 IF(J.EQ.P)GOTO 26 AIN(I,J)=KZ(J)*AIN(I,P)+AIN(I,J) 26 CONTINUE 16 CONTINUE 24 CONTINUE 14 CONTINUE C ELEMENTE IN DER PIVOTZEILE 17 DO 18 J=1,N 27 IF(J.EQ.P)GOTO 28 AIN(P,J)=-AIN(P,J)*AIN(P,P) 28 CONTINUE 18 CONTINUE C ELEMENTE IN DER PIVOTKOLONNE 19 DO 20 I=1,N 29 IF(I.EQ.P)GOTO 30 AIN(I,P)=AIN(I,P)*AIN(P,P) 30 CONTINUE 20 CONTINUE 8 CONTINUE RETURN 2001 FORMAT(1H ,'***PIVOT(',I3,',',I3,') = ',D12.4,' UND WIRD = 1D30 ', 1'GESETZT***'/) END SUBROUTINE DMTSUB(C,A,B,DIMN,DIMM,N,M) C% C% C% C% MATRIZENSUBTRAKTION (DOUBLE PRECISION): C(N,M) = A(N,M)*B(N,M) C% C% N,M : AKTUELLE DIMENSIONEN C% C% DIMN,DIMM : DIMENSIONEN IM HAUPTPROGRAMM C% C% C% INTEGER*2 N,M,DIMN,DIMM C% REAL*8 A,B,C C% DIMENSION A(DIMN,DIMM),B(DIMN,DIMM),C(DIMN,DIMM) C% C% C TEST DER ARRAYDIMENSIONEN: 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 WRITE(1,9901)N,DIMN,M,DIMM 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTSUB***'/ 1 'N = ',I4,' DIMN = ',I4/ 2 'M = ',I4,' DIMM = ',I4/) 22 CONTINUE IF(N.EQ.0.OR.M.EQ.0) RETURN 1 DO 2 I=1,N 3 DO 4 J=1,M C(I,J) = A(I,J)-B(I,J) 4 CONTINUE 2 CONTINUE RETURN END C% C% SUBROUTINE DMTSCL(C,A,S,DIMN,DIMM,N,M) C% C% C% MULTIPLIKATION MATRIX*SKALAR (DOUBLE PRECISION): C(N,M)=A(N,M)*S C% C% N,M : AKTUELLE DIMENSIONEN C% C% DIMN,DIMM : DIMENSIONEN IM HAUPTPROGRAMM C% C% C% INTEGER*2 N,M,DIMN,DIMM C% REAL*8 A,C,S C% DIMENSION A(DIMN,DIMM),C(DIMN,DIMM) C% C% C% C TEST DER ARRAYDIMENSIONEN: 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 WRITE(1,9901)N,DIMN,M,DIMM 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTSCL***'/ 1 'N = ',I4,' DIMN = ',I4/ 2 'M = ',I4,' DIMM = ',I4/) 22 CONTINUE IF(N.EQ.0.OR.M.EQ.0) RETURN 31 IF(S.EQ.0.D0) GOTO 32 1 DO 2 I=1,N 3 DO 4 J=1,M C(I,J)=A(I,J)*S 4 CONTINUE 2 CONTINUE RETURN 32 CONTINUE 5 DO 6 I=1,N 7 DO 8 J=1,M C(I,J) = 0.D0 8 CONTINUE 6 CONTINUE RETURN END SUBROUTINE DMTTRS(C,A,M,N,DIMM,DIMN) C% C% MATRIX TRANSPONIEREN (DOUBLE PRECISION): C(DIMM,DIMN)= C% C% A(DIMN,DIMM)T C% C% C% C% N,M: AKTUELLE DIMENSIONEN C% C% DIMN,DIMM: DIMENSIONEN IM HAUPTPROGRAMM C% C% C% INTEGER*2 N,M,DIMN,DIMM C% REAL*8 A,C C% DIMENSION A(DIMN,DIMM),C(DIMM,DIMN) C% C% C% C TEST DER ARRAYDIMENSIONEN: 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 WRITE(1,9901)N,DIMN,M,DIMM 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTTRS***'/ 1 'N = ',I4,' DIMN = ',I4/ 2 'M = ',I4,' DIMM = ',I4/) 22 CONTINUE IF(N.EQ.0.OR.M.EQ.0) RETURN 1 DO 2 I=1,N 3 DO 4 J=1,M C(J,I) = A(I,J) 4 CONTINUE 2 CONTINUE RETURN END SUBROUTINE DMREAL(CPXA,A,MDIM,NDIM,M2DIM,N2DIM,M,N) COMPLEX*8 CPXA(MDIM,NDIM),CPXAIJ REAL*8 A(M2DIM,N2DIM) 1 DO 2 I=1,M I2=2*I I1=I2-1 3 DO 4 J=1,N J2=2*J J1=J2-1 CPXAIJ = CPXA(I,J) A(I1,J1)=REAL(CPXAIJ) A(I1,J2)=-AIMAG(CPXAIJ) A(I2,J1)=AIMAG(CPXAIJ) A(I2,J2)=REAL(CPXAIJ) 4 CONTINUE 2 CONTINUE RETURN END SUBROUTINE CMTMLT(C,A,B,NDIM,MDIM,LDIM,N,M,L) C PRODUCT OF TWO COMPLEX MATRICES COMPLEX*8 A A(NDIM,MDIM), B B(MDIM,LDIM), C C(NDIM,LDIM) 1 DO 2 I=1,N 3 DO 4 J=1,L C(I,J) = (0.,0.) 5 DO 6 K=1,M C(I,J) = A(I,K) * B(K,J) + C(I,J) 6 CONTINUE 4 CONTINUE 2 CONTINUE RETURN END SUBROUTINE DRMINV(B,A,NDIM,N,IERR) C INVERSE 'B' OF RIGHT RECTANGULAR MATRIX 'A' (REAL*8) C (NOTE: 'A' AND 'B' MAY BE EQUAL IN CALLING STATEMENT) INTEGER*2 N N, /* ACTUAL DIMENSION OF A,B N NDIM /* MAX. DIMENSION OF A,B REAL*8 A A(NDIM,NDIM), /* ORIG. RIGHT RECTANGULAR MATRIX A AII, B B(NDIM,NDIM), /* INVERSE OF A S S C TEST ELEMENTS ON LEFT SIDE OF 'A' 1 DO 2 I=2,N I1=I-1 3 DO 4 J=1,I1 900 IF(ABS(A(I,J)).GT.1.D-12) GOTO 901 B(I,J) = 0.D0 4 CONTINUE 2 CONTINUE C COMPUTE INVERSE 'B' ROW BY ROW 5 DO 6 II=1,N I=N-II+1 I1 = I+1 AII = A(I,I) 902 IF(DABS(AII).LT.1.D-12) GOTO 903 7 DO 8 KK=I1,N K=N-KK+I1 S = 0.D0 9 DO 10 JJ=I1,K J=K-JJ+I1 S = S + A(I,J) * B(J,K) 10 CONTINUE B(I,K) = -S/AII 8 CONTINUE B(I,I) = 1.D0/AII 6 CONTINUE RETURN C ERROR MESSAGES 901 CONTINUE WRITE(1,9901)I,J,A(I,J) 9901 FORMAT(' ***ELEMENT A(',I2,',',I2,')=',E12.4,'>1.D-12 IN RMINV***' 1/) A(I,J) = 0.D0 GOTO 900 903 CONTINUE WRITE(1,9903) I,I,AII 9903 FORMAT(' ***DIAGONAL ELEMENT A(',I2,',',I2,')=',E12.4,'<1.D-12 IN' 1 ,' RMINV***'/) AII = 1.D-12 IERR = I GOTO 902 END SUBROUTINE DSISRT(V,A,NDIM,MDIM,N,M) C SIMULTANEOUS SORTING OF VECTOR 'V' AND REARANGING OF COLUMN C VECTORS OF MATRIC 'A' (REAL*8) ( N < NDIM < 200 ) REAL*8 A A(NDIM,MDIM), U U, V V(MDIM) M1=M-1 1 DO 2 I=1,M1 J=I I1=I+1 3 DO 4 K=I1,M IF(DABS(V(K)).GT.DABS(V(J))) J = K 4 CONTINUE U = V(I) V(I) = V(J) V(J) = U 5 DO 6 IN=1,N U = A(IN,I) A(IN,I) = A(IN,J) A(IN,J) = U 6 CONTINUE 2 CONTINUE RETURN END SUBROUTINE DMTSYM(A,NDIM,N) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C DUPLICATE ELEMENTS IN UPPER HALF FILLED SYMMETRIC MATRICE INTEGER*2 N N, /* ACTUAL SIZE OF MATRIX N NDIM /* DIMENSION OF A REAL*8 A A(NDIM,NDIM) /* UPPER HALF FILLED MATRIX / SYMM. MATRIX C CHECK ARRAY DIMENSIONS 900 IF(N.GT.NDIM) GOTO 901 1 DO 2 I=2,N IEND=I-1 3 DO 4 K=1,IEND A(I,K) = A(K,I) 4 CONTINUE 2 CONTINUE RETURN C ERROR MESSAGES 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' ***ARRAY SIZE EXCEEDS DIMENSIONS IN "DMTSYM"***'/) RETURN END $$$ REAL*8 FUNCTION DCHISQ(X) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C DENSITY FUNCTION OF THE CHI-SQUARE PROBABILITY DISTRIBUTION REAL*8 C C, D DGAMMA, X X /* ARGUMENT OF FUNCTION INTEGER*2 N NDF1, /* DEGREES OF FREEDOM N NDF2 /* DEGREES OF FREEDOM COMMON /STAT/ NDF1,NDF2 1 IF(X.LE.0.D0) GOTO 2 C = 2.D0**(NDF1/2.D0)* DGAMMA(NDF1) DCHISQ = X**(NDF1/2.D0 - 1.D0) * DEXP(-X/2.D0) / C RETURN 2 CONTINUE DCHISQ = 0.D0 RETURN END REAL*8 FUNCTION DCCHIS(X) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C CUMULATIVE CHI-SQUARED PROBABILITY DISTRIBUTION FUNCTION INTEGER*2 N NDF1, /* DEGREES OF FREEDOM N NDF2 /* DEGREES OF FREEDOM REAL*8 D DCHISQ, F F01, F F9(15), G GRZW, /* CRIT. VALUE FOR ITERATION TERMINATION R RNDF, R RNDF2, R ROMINT, X X,X1 LOGICAL KONVER,GTNDF,GTNDF2 COMMON /STAT/ NDF1,NDF2 EXTERNAL DCHISQ DATA F F01/0.982069D-3/, F F9/2.70554D0,4.60517D0,6.25139D0,7.77944D0,9.23635D0,10.6446D0, F 12.0170D0,13.3616D0,14.6837D0,15.9871D0,17.2750D0,18.5494D0, F 19.8119D0,21.0642D0,22.3072D0/ GRZW = 1.D-5 IF(NDF1.LE.15) GRZW = 1.D-4 RNDF = NDF1 RNDF2 = 2*NDF1 GTNDF = .FALSE. GTNDF2 = .FALSE. DCCHIS = 0.D0 X1 = X IF(X.LT.0.D0) GOTO 902 8 IF(X.EQ.0.D0) GOTO 9 IF(X.GT.RNDF) GTNDF = .TRUE. IF(X.GT.RNDF2) GTNDF2 = .TRUE. IF(NDF1.EQ.1) GOTO 1 IF(NDF1.GE.2) GOTO 2 GOTO 901 C 1 DEGREE OF FREEDOM 1 CONTINUE 101 IF(.NOT.GTNDF) GOTO 102 DCCHIS = -ROMINT(DCHISQ,X,F9(1),GRZW,K,KONVER) + 0.9D0 RETURN 102 CONTINUE DCCHIS = DCCHIS - ROMINT(DCHISQ,X1,F01,GRZW,K,KONVER) + 0.025D0 RETURN C NDF>=2 2 CONTINUE 103 IF(NDF1.GT.15.OR..NOT.GTNDF) GOTO 104 DCCHIS = - ROMINT(DCHISQ,X,F9(NDF1),GRZW,K,KONVER) + 0.9D0 RETURN 104 CONTINUE IF(GTNDF2) DCCHIS = - ROMINT(DCHISQ,X,RNDF2,GRZW,K,KONVER) IF(GTNDF2) X1=RNDF2 DCCHIS = DCCHIS - ROMINT(DCHISQ,X1,0.D0,GRZW,K,KONVER) RETURN 9 CONTINUE DCCHIS = 0.D0 RETURN 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' *** NDF<1 IN DCCHIS ***'/) RETURN 902 CONTINUE WRITE(1,1902) 1902 FORMAT(' *** X<0. IN DCCHIS ***'/) RETURN END REAL*8 FUNCTION DICCHI(F) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C INVERSE CHI-SQUARED CUMULATIVE PDF (FOR X < 10000.) INTEGER*2 N NDF1, /* DEGREES OF FREEDOM N NDF2 /* DEGREES OF FREEDOM REAL*8 D DF, D DFALSI, D DCCHIS, D DX, F F, X X(3) COMMON /STAT/ NDF1,NDF2 EXTERNAL DCCHIS X(1) = 0.D0 IF(F.GE.0.75D0) X(1) = NDF1 DX = 1.D-2 IF(NDF1.GT.50) DX = 0.2D0 IF(NDF1.GT.100) DX = 0.5D0 IF(NDF1.GT.500) DX = 0.7D0 C CHECK INTERVAL OF ARGUMENT IF(F.GE.1.D0) GOTO 901 C APPROX. VALUES X(1),X(2) 1 DO 2 I=1,20 X(2) = X(1) + DX DF = DCCHIS(X(2)) - F 11 IF(DF.GT.0.D0) GOTO 12 X(1) = X(2) DX = 2.D0*DX 2 CONTINUE GOTO 902 12 CONTINUE C REGULA FALSI DICCHI = DFALSI(DCCHIS,F,X) RETURN 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' *** F>= 1. ***'/) RETURN 902 CONTINUE WRITE(1,1902) X(2) 1902 FORMAT(' *** X> ',F8.2,'***'/) RETURN END REAL*8 FUNCTION DGAMMA(N) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C GAMMA FUNCTION FOR BETA = 2 C GAMMA = C(ALFA) = C(N/BETA) = C(N/2) INTEGER*2 N,N2 REAL*8 PI 900 IF(N.LE.0) GOTO 901 PI = 4.D0*DATAN(1.D0) DGAMMA = 1.D0 IF(MOD(N,2).EQ.1) DGAMMA = DSQRT(PI) 11 IF(N.LE.2) GOTO 12 N2 = (N+1)/2 - 1 1 DO 2 I=1,N2 DGAMMA = DGAMMA * (N/2.D0 - I) 2 CONTINUE 12 CONTINUE RETURN C ERROR MESSAGE 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' ***ILLEGAL ARGUMENT N<=0 IN FUNCTION DGAMMA***'/) DGAMMA = 0.D0 RETURN END REAL*8 FUNCTION ROMINT(FCT,A,B,GRZW,K,KONVER) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C ROMBERG INTEGRATION INTEGER*2 J,L,K REAL*8 H H, T T, T TOLD, A A, B B, S SF, M M, K K1, G GRZW DIMENSION T(20,2) LOGICAL KONVER EXTERNAL FCT KONVER = .FALSE. H = B-A T(1,1) = (FCT(A) + FCT(B)) * H / 2.D0 M = H * FCT(A+H/2.D0) J=2 101 DO 102 K=2,20 J=2*J H = H/2.D0 T(1,2) = (T(1,1)+M)/2.D0 SF = 0.D0 103 DO 104 L=1,J,2 104 SF = SF + FCT(A + L*H/2.D0) M = H*SF K1=4.D0 1 IF(K.LT.3)GOTO 2 L = K-1 105 DO 106 I=2,L T(I,2) = (K1*T(I-1,2)-T(I-1,1))/(K1-1.D0) T(I-1,1) = T(I-1,2) 106 K1 = K1 * K1 2 I=K T(I,1) = (K1*T(I-1,2)-T(I-1,1))/(K1-1.D0) C WRITE(1,1097) K,T(K,1) 1097 FORMAT(I4,D16.8) 203 IF(DABS(T(I,1)-TOLD).LT.GRZW) GOTO 204 TOLD=T(K,1) T(I-1,1) = T(I-1,2) 102 CONTINUE 205 GOTO 206 204 KONVER = .TRUE. ROMINT = T(K,1) C WRITE(1,1098) K 1098 FORMAT('K=',I4) RETURN 206 CONTINUE ROMINT = 0.D0 WRITE(1,1099) 1099 FORMAT('*** NO CONVERGENCE IN ROMINT ***'/) RETURN END REAL*8 FUNCTION DFALSI(FCT,F0,X) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C SOLVE THE EQUATION FCT(X) = F0 , FOR FCT MONOTON INSCREASING C USING THE REGULA FALSI REAL*8 D DCRIT, D DF, F F(3), F F0, F FCT, X X(3) EXTERNAL FCT DATA DCRIT/5.D-4/ 1 DO 2 I=1,2 F(I) = FCT(X(I)) 2 CONTINUE C CHECK MONOTONITY IF ((F(2)-F(1)).EQ.0.D0) GOTO 901 C ITERATION 3 DO 4 I=1,100 X(3) = X(1) + (X(2)-X(1)) / (F(2)-F(1)) * (F0-F(1)) F(3) = FCT(X(3)) DF = F(3) - F0 C TEST FOR ITERATION TERMINATION IF(DABS(DF).LT.DCRIT) GOTO 12 C NEW APPROX. VALUES X(1), X(2) 13 IF(DF.LT.0.D0) GOTO 14 X(1) = X(3) F(1) = F(3) 15 GOTO 16 14 CONTINUE X(2) = X(3) F(2) = F(3) 16 CONTINUE C WRITE(1,1999) X,F 1999 FORMAT(6D12.3) 4 CONTINUE 12 CONTINUE DFALSI = X(3) RETURN 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' *** FCT NOT MONOTONE INCREASING IN DFALSI **'/) RETURN END REAL*8 FUNCTION DNORM(X) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C REAL*8 X C C WAHRSCHEINLICHKEITSDICHTE DER NORMALVERTEILUNG C REAL *8 ZPI DATA ZPI /2.506628275D0/ DNORM = DEXP(-X*X/2.D0)/ZPI RETURN END REAL*8 FUNCTION DCNORM(X) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C NORMAL CUMULATIVE PROBABILITY DISTRIBUTION FUNCTION REAL*8 D DNORM, D DSIMPS, X X LOGICAL KONVER EXTERNAL DNORM DCNORM = -ROMINT(DNORM,X,0.D0,1.D-5,K,KONVER) RETURN END REAL*8 FUNCTION DNEWTO(F,F1,F0,X) C C **************************************************************** C * * C * WRITTEN BY D.SCHNEIDER * C * BUNDESAMT FUER LANDESTOPOGRAPHIE * C * CH-3084 WABERN, 1981 * C * * C **************************************************************** C C NEWTONS ITERATIVE METHOD TO SOLVE THE EQUATION: F(X) = F0 REAL*8 D DF, F F, F F0, F F1, F F1X, X X EXTERNAL F,F1 1 DO 2 I=1,20 F1X = F1(X) IF(DABS(F1X).LT.1.D-24) F1X=1.D-24 DF = F(X) - F0 3 IF(DABS(DF).LT.1.D-4) GOTO 4 X = X - DF/F1X 2 CONTINUE 4 CONTINUE DNEWTO = X RETURN END $$$ C PROGRAM CRUSTRAIN (VERS.3.82) (0001) C PROGRAM CRUSTRAIN (VERS.3.82) (0002) C ***************** (0003) (0004) C GENERAL METHOD FOR THE CRUSTAL STRAIN ANALYSIS FROM REPEATED (0005) C OBSERVATIONS OF HORIZONTAL GEODETIC NETWORKS (VERSION FOR (0006) C STRAIN APPROXIMATION IN SPACE AND TIME) (0007) (0008) C **************************************************************** (0009) C * * (0010) C * PROGRAM CRUSTRAIN (VERSION 3.82) * (0011) C * DEVELOPED BY D.SCHNEIDER * (0012) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0013) C * CH-3084 WABERN, 1981-82 * (0014) C * (C) D.SCHNEIDER, 1982 * (0015) C * * (0016) C **************************************************************** (0017) C (0018) C FILES: (0019) C FILE NAME FTN# PRIMOS# CONTENT (0020) C (0021) C IFILI 5 1 INPUT FILE (RESULTS FROM PROG. GEOPA (0022) C 'O_STRAIN' 6 2 OUTPUT-LIST (0023) C 'P_STRAIN' 7 3 PLOT-INFO (FOR PROG. STRAINPLOT) (0024) C 'T$STRAIN' 8 4 SCRATCH-FILE (0025) C 'P_PREDICT' 9 5 COEFF. AND COV. FOR PREDICTION (0026) C 'P_ISOLIN1' 10 6 PLOT-INFO (FOR PROG. ISOLIN) (0027) C 'P_ISOLIN2' 11 7 PLOT-INFO (FOR PROG. ISOLIN) (0028) (0029) INTEGER*2 (0030) I IDAT(3), /* DATE OF COMPUTATION (0031) I IDIM, (0032) I IFILI(16), /* NAME OF INPUT FILE (0033) I ISING, /* SINGULARITY CODE (0034) I ISPACE(4), /* OPTION CODE OF SPACE MODEL (0035) I ISTAT(2), /* OPTION CODE OF STATISTICAL MODEL (0036) I ITIM(15), (0037) I ITIME1(2), /* TIME OF COMPUTATION (0038) I ITOPT, /* # OF STATISTICAL TEST OPTION (0039) I IUSER(3), /* USER NAME (0040) M MANTIC, /* POWER OF ANTICONFORMAL POLYNOMIAL (0041) M MCONF, /* NUMBER OF TERMS IN CONFORMAL BASE (0042) M MCONF1, /* POWER OF CONFORMAL POLYNOMIAL (0043) N NAME(30,4), /* IDENTIFICATION OF POINTS (0044) N NAMFIX(4), /* IDENTIFICATION OF FIXED POINT (0045) N NELIM(13), /* VECTOR CONTAINING NO. OF CONSTRAINED PAR. (0046) N NPROJ1(20), /* TITLE OF PROJECT (0047) N NPROJ2(20), /* SUB-TITLE OF PROJECT (0048) N NONET(50), /* NUMBER OF OBSERVATIONS OF EACH NETWORK (0049) N NPER(5,2), /* BEGIN AND END ADDRESS OF BLOCK PERIMETER VERT (0050) N NUNET(50), /* NUMBER OF UNKNOWNS OF EACH NETWORK (0051) N NTIT(40), /* TITLE OF EACH NETWORK (0052) N NUIPAR(50,2) /* VECTOR OF NUISANCE PARAMETER CODES OF EACH NE (0053) (0054) REAL*4 (0055) A ALPHP, (0056) A APVARF, /* A POST. VARIANCE FACTOR (0057) A AZSHR, /* AZIMUTH OF PREDICTED SHEAR (0058) B BLOCA(5), /* AZIMUTH OF "ABSOLUTE" BLOCK MOTION (0059) F FACTK, /* CRIT. FACTOR FOR VAR. OF FOURIERCOEFF. (0060) G GRIDW, /* TEST GRID INTERVAL (0061) G GRIDL, /* TEST GRID INTERVAL [M] (0062) R RHOGON, (0063) P PBLOC(5), (0064) S SIG(20), /* STD.DEV. OF COEFF. (0065) S SIGCHI(2), /* STD.DEV. OF STRAIN (0066) S SIGPSI(2), /* STD.DEV. OF STRAIN (0067) S SIGDA(2), /* STD.DEV. OF DISPLACEMENT OR VELOCITY (0068) T TIME(50), /* OBSERVATION TIMES [YR] OF EACH EPOCH (0069) T TIME0, /* REFERENCE TIME (0070) T TIMINT, /* TIME INTERVAL OF PREDICTION (0071) T TIMSPA /* TOTAL TIME SPAN OF OBSERVATIONS (0072) (0073) REAL*8 (0074) A A(60,48), /* REAL DESIGN MATRIX OF APPROXIMATION (0075) A A2R(60,2), /* FIRST TWO COLUMNS OF "A" (0076) A ALIN, /* AZIMUTH OF FAULT LINE (0077) A ALFT, /* LEVEL OF SIGNIFICANCE (0078) A ALPH, /* LEVEL OF CONFIDENCE (0079) B BLCREF(2), /* BLOCK REFERENCE POINT (0080) B BLOCAZ(15), /* AZIMUTH OF REL. BLOCK MOTIONS OR VELOCITIES (0081) B B(60,40), /* DESIGN MATRIX OF NUISANCE PARAMETERS (0082) B BE(10,2), /* BEGIN AND END OF EPISODES (0083) C CCBLOC(2,2), /* COV. OF BLOC MOTION (0084) C CCHIPS(4,4), /* COV. OF STRAINS OR STRAIN RATES (0085) C CDA(2,2), /* COV. OF DISPLACEMENTS OR VELOCITIES (0086) C CRXON, (0087) C CX(240,240), /* COV. OF REAL COEFFICIENTS (0088) D D0(2), /* MEAN DISPLACEMENTS (0089) D DNEWTO, (0090) D DTIME, /* TIME DIFFERENCE BETWEEN OBS. EPOCHS (0091) D DTIMN, /* SCALED TIME DIFFERENCE (0092) F FAULT(15,4), /* (0093) N NEPOC(50,2), /* TITLES OF NETWORKS (0094) P P(30,2),P0(2), /* POSITIONS OF ALL STATIONS / MEAN POSITION (0095) P PER(50,2), /* BLOCK PERIMETER VETICES (0096) P PR(2), /* COORD. OF GRID POINTS (0097) S SCALP,SCALD, /* SCALE FACTOR OF POSITIONS/DISPLAC. (0098) S SCALR, /* RATIO OF DISPLACEMENT AND POSITION SCALES (0099) S SCALDI, (0100) S SCALD2, (0101) S SSHRAZ, /* STD.DEV. OF SHEAR AZ (0102) S STSHR, /* STD.DEV. OF TOTAL SHEAR (0103) S SXPER,SYPER, (0104) S SXYBLC(15,2), /* STD. DEV. OF RELATIVE BLOC DISPLACEMENT (0105) T TPRE, /* TIME OF PREDICTION (0106) T TPRED(30), /* TIMES OF PREDICTION (0107) V VARF(50), /* VAR.FACTOR OF NETWORKS (0108) X X1,X2, (0109) X XICHI, (0110) X XPER, /* COORD. OF BLOCK PERIMETER VERTICES (0111) X XR(240,1), /* REAL VECTOR OF ORIG. COEFFICIENTS (0112) X XYBLOC(15,2), (0113) Y Y1,Y2, (0114) Y YPER /* COORD. OF BLOCK PERIMETER VERTICES (0115) (0116) COMPLEX*8 (0117) C CBLOC, /* COMPLEX BLOC MOTION (0118) C CHI, /* CONFORMAL COMPLEX STRAIN COMPONENT (0119) C CPXA(30,24), /* COMPLEX DESIGN MATRIX OF APPROX. (0120) C CPXX(120,1), /* ORIGINAL COMPLEX COEFFICIENTS (0121) D DA(1,1), /* COMPLEX REL. DISPLACEMENT OR VELOCITY (0122) P PHI(1,12), /* COMPLEX SPACE BASE FUNCTION (0123) P PSI, /* COMPLEX STRAIN COMPONENT (0124) Z Z(30), /* COMPLEX POSITIONS OF STATIONS (0125) Z ZBLC(50), /* COMPLEX COORD. OF BLOCK PERIMETER VERTICES (0126) Z ZC, /* COMPLEX CONJUGATE POSITION (0127) Z ZG /* COMPLEX COORD. OF GRID POINT (0128) (0129) LOGICAL (0130) L LBLOCA, /* CONSTRAIN AZ. OF REL. BLOCK MOTION (0131) L LCOVAR, /* COMPUTE COVARIANCE OF PREDICTED QUANTITIES (0132) L LOPEN, /* FILE SUCCESSFULLY OPENED (0133) L LPRINT, /* PRINT INTERMEDIATE RESULTS (0134) L JANEIN, (0135) L LPREAN, /* PREANALYSIS ONLY (0136) L LPREDI, /* PREDICTION ONLY (0137) L LPLTG /* DO PLOT STRAIN AT GRID POINTS (0138) (0139) COMMON /COM0/ CPXA (0140) COMMON /COM2/ CX (0141) COMMON /COM10/ A,B,A2R (0142) COMMON /COM14/ NAME,VARF (0143) COMMON /EPISOD/ BE,NTPOLY (0144) COMMON /BLOCK/ ZBLC,NPER,BLOCA (0145) (0146) EXTERNAL DCNORM,DNORM (0147) (0148) C A$KEYS, APPLIB, ELS, 08/21/80 (0148) C Insert file for mnemonic APPLIB keys (FTN) (0148) C Copyright 1977, PR1ME COMPUTER, INC., Framingham, MA. (0148) NOLIST (0149) (0150) DATA (0151) A AMASQ/-999./, /* VALUE FOR MASKING OUT IN ISOLINE PLOTTING (0152) B BLOCA/5*0./, (0153) F FAULT/60*0.D0/, (0154) I ISPACE/4*0/, (0155) L LPRINT/.FALSE./, (0156) M MDIM/12/, /* DIMENSION OF SPACE BASE (0157) N NDEDIM/130/, /* DIMENSION OF VECTOR OF ELIMINATED PARAMETERS (0158) N NELIM/13*0/, /* VECTOR CONTAINING ELIMINATION CODES FOR PARAM (0159) N NPDIM/30/, /* MAX. NUMBER OF STATIONS (0160) N NP2DIM/60/, /* MAX. NUMBER OF STAT.COORD. (0161) N NP2HDI/90/, /* MAX. NUMBER OF STAT.COORD. + HEIGHTS (0162) N NUDIM/24/, /* DIMENSION OF COMPLEX VECTOR OF ORIG. COEFF. (0163) N NU2DIM/48/, /* DIMENSION OF REAL VECTOR OF ORIG. COEFF. (0164) N NCCDIM/120/, /* MAX. NUMBER OF TOTAL COMPLEX COEFF. (0165) N NRCDIM/240/, /* MAX. NUMBER OF TOTAL REAL COEFF. (0166) N N12DIM/90/, (0167) S SCALD/3.D-1/ (0168) (0169) RHOGON = 50.D0/DATAN(1.D0) (0170) (0171) C OPEN OUTPUT FILE (0172) LOPEN = OPEN$A(A$WRIT+A$SAMF,'O_STRAIN',8,2) (0173) IF(.NOT.LOPEN)GOTO 901 (0174) (0175) C WRITE TITLE (0176) WRITE(6,6900) (0177) WRITE(6,6901) (0178) WRITE(6,6000) (0179) WRITE(1,6000) (0180) 6000 FORMAT(1H ,'PROGRAM CRUSTRAIN (VERS.3.82)'/1H ,17(1H*)/ (0181) 1' (MULTI-EPOCH VERSION FOR STRAIN APPROX. IN SPACE AND TIME)'// (0182) 2' (C) D.SCHNEIDER, 1982'//) (0183) (0184) C WRITE USER, DATE AND TIME (0185) CALL TIMREG(IDAT,ITIME1,IUSER) (0186) WRITE(6,6991) IUSER,IDAT,ITIME1 (0187) 6991 FORMAT(1H ,T100,'USER: ',3A2/T100,'DATE: ',A2,'.',A2,'.',A2/T100, (0188) 1 'TIME: ',I2,'.',I2/) (0189) (0190) C SELECTION OF APPROXIMATION OPTION (0191) WRITE(6,6061) (0192) WRITE(1,6061) (0193) 6061 FORMAT(1H ,'SELECTION OF APPROX. OPTION:'// (0194) 1 ' OPT.# OPTION:'/ (0195) 2 ' 0 PREANALYSIS ONLY'/ (0196) 3 ' 1 LEAST SQ. APPROX.'/ (0197) 4 ' 2 PREDICTION ONLY'//) (0198) CALL TNOUA('OPT.# : ',8) (0199) READ(1,*) IOPTAP (0200) WRITE(6,6062) IOPTAP (0201) 6062 FORMAT(' OPT.# : ',I2) (0202) LPREAN = (IOPTAP.EQ.0) (0203) LPREDI = (IOPTAP.EQ.2) (0204) (0205) C OPEN INPUT FILE (0206) 708 IF(LPREDI) GOTO 709 (0207) 801 LOPEN = OPNP$A('INPUTFILE',9,A$READ+A$SAMF,IFILI,32,1) (0208) IF(.NOT.LOPEN)GOTO 801 (0209) WRITE(6,6023) IFILI (0210) 6023 FORMAT(1H /' INPUT-FILE: ',16A2) (0211) 709 CONTINUE (0212) (0213) C OPEN FILE FOR DATA TRANSFER TO PROGRAMM STRAINPLOT (0214) LOPEN = OPEN$A(A$WRIT+A$SAMF,'P_STRAIN',8,3) (0215) IF(.NOT.LOPEN) GOTO 901 (0216) (0217) C OPEN FILE FOR DATA TRANSFER TO PROGRAM ISOLINE (0218) LOPEN = OPEN$A(A$WRIT+A$SAMF,'P_ISOLIN1',9,6) (0219) IF(.NOT.LOPEN) GOTO 901 (0220) LOPEN = OPEN$A(A$WRIT+A$SAMF,'P_ISOLIN2',9,7) (0221) IF(.NOT.LOPEN) GOTO 901 (0222) (0223) C FILE FOR DATA STORAGE FOR PREDICTION AFTER THE APPROXIMATION (0224) IF(.NOT.LPREDI)LOPEN = OPEN$A(A$WRIT+A$SAMF,'P_PREDICT',9,5) (0225) IF(LPREDI) LOPEN = OPEN$A(A$READ+A$SAMF,'P_PREDICT',9,5) (0226) IF(.NOT.LOPEN) GOTO 901 (0227) (0228) C READ STORED COEFFICIENTS FOR PREDICTION (0229) 703 IF(.NOT.LPREDI) GOTO 704 (0230) READ(9,9091)(NPROJ1(I),I=1,20),(NPROJ2(I),I=1,20) (0231) READ(9,9087) ALPHP,XICHI,IDIM (0232) 9087 FORMAT(2F8.4,I4) (0233) READ(9,9092) NU,NU2,MCONF,MANTIC,NCC,NRC,MT,MBLOC,MCONF1,MDIM,NP1, (0234) 1 NNET,JJBLOC,NEPIS,NRC2,NTPOLY (0235) IF(MBLOC.NE.0) READ(9,9096) ((NPER(I,J),J=1,2),I=1,MBLOC) (0236) IF(MBLOC.NE.0) READ(9,9097) ((PER(I,J),J=1,2),I=1,JJBLOC) (0237) IF(MBLOC.NE.0) READ(9,9095) (BLOCA(I),I=1,MBLOC) (0238) READ(9,9093) ((NAME(I,J),J=1,4),I=1,NP1) (0239) READ(9,9095) (Z(I),I=1,NP1),(ZBLC(J),J=1,JJBLOC) (0240) READ(9,9095) (TIME(I),I=1,NNET),TIMSPA,TIME0,BE (0241) READ(9,9095) D0,P,P0,SCALP,SCALD,SCALR (0242) READ(9,9095) (CPXX(I,1),I=1,NCC) (0243) 181 DO 182 I=1,NRC2 (0244) READ(9,9095) (CX(I,J),J=I,NRC2) (0245) 182 CONTINUE (0246) CALL DMTSYM(CX,NRCDIM,NRC2) (0247) 704 CONTINUE (0248) (0249) C READ TITLE AND SUBTITLE OF PROJECT (0250) IF(.NOT.LPREDI) READ(5,1001) NPROJ1 (0251) CALL TNOUA('SUBTITLE OF PROJECT:',20) (0252) READ(1,1001)NPROJ2 (0253) 1001 FORMAT(20A2) (0254) WRITE(6,6031)NPROJ1,NPROJ2 (0255) 6031 FORMAT(T69,42(1H-)/T68,1H[,1X,'PROJECT:',T111,1H]/ (0256) 1 2(T68,1H[,1X,20A2,1X,1H]/),T69,42(1H-)//) (0257) WRITE(7,7003)NPROJ1,NPROJ2 (0258) WRITE(10,7003)NPROJ1,NPROJ2 (0259) 7003 FORMAT(20A2,20A2) (0260) (0261) C OPEN SCRATCH FILE (0262) 701 IF(LPREDI) GOTO 702 (0263) LOPEN = OPEN$A(A$RDWR+A$SAMF,'T$STRAIN',8,4) (0264) IF(.NOT.LOPEN) GOTO 901 (0265) (0266) C DEFINE APPROXIMATION FUNCTION IN SPACE (0267) WRITE(6,6025) (0268) 6025 FORMAT(1H //' APPROXIMATION FUNCTION IN SPACE:'/1H ,32(1H-)/ (0269) 1' (MAX.NUM.: N.BLOCKS<=5, N.BLOCKS+N.CONF<=12, N.A.-CONF.<=12)'//) (0270) CALL TNOUA('POWER OF APPROX. POLYN.(BLOCKS/CONF./ANTICONF.): ',49) (0271) READ(1,*) MBLOC,MCONF,MANTIC (0272) WRITE(6,6013) MBLOC,MCONF,MANTIC (0273) 6013 FORMAT(1H /' POWER OF THE APPROXIMATION POLYNOMIALS : '/ (0274) 1 ' NUMB. OF BLOCKS: CONFORMAL TERMS: ANTICONF.TERMS:'/ (0275) 2 7X,I2,14X,I2,20X,I2//) (0276) (0277) WRITE(6,6057) (0278) 46 CONTINUE (0279) WRITE(1,6057) (0280) 6057 FORMAT(1H ,'CONSTRAIN PARAMETER # ? [#1: SCALE, #2: ORIENT.]:'/) (0281) READ(1,*) IPAR (0282) 43 IF(IPAR.EQ.0) GOTO 44 (0283) NELIM(IPAR) = IPAR (0284) WRITE(6,6050) IPAR (0285) 6050 FORMAT(1H /' CONSTRAINED PARAMETER # ',I2) (0286) 45 GOTO 46 (0287) 44 CONTINUE (0288) (0289) C ENTER COORDINATES OF RIGID BLOCK PERIMETER POYGON VERTICES (0290) (0291) 95 IF(MBLOC.EQ.0) GOTO 96 (0292) WRITE(1,6071) (0293) WRITE(6,6071) (0294) 6071 FORMAT(1H //' MASKING FUNCTIONS: DEFINITION OF BLOCK PERIMETERS:' (0295) 1 /' INPUT OF POLYGON VERTICES: '//' BLOCK:',8X,'X[M]',5X,'Y[M]', (0296) 2 5X,'REF.POINT: X[M]',2X,'Y[M]',4X,'AZ.[GON]'//) (0297) JJ=1 (0298) 37 DO 38 I=1,MBLOC (0299) NPER(I,1) = JJ (0300) WRITE(1,6072) I (0301) 6072 FORMAT(1H ,'BLOCK #',I1,': ') (0302) CALL TNOUA('COORD. OF BLOCK REFERENCE POINT : ',34) (0303) READ(1,*) BLCREF (0304) WRITE(1,1005) (0305) 1005 FORMAT('AZIMUTH OF REL. BLOCK MOTION TO BE CONSTRAINED TO:'/) (0306) CALL TNOUA('AZIMUTH [GON]: (NO CONSTR.:AZ=999):',35) (0307) READ(1,*) BLOCA(I) (0308) WRITE(6,6074) I,BLCREF,BLOCA(I) (0309) 6074 FORMAT(3X,I2,32X,2F9.0,F9.2/) (0310) BLOCA(I) = (100.-BLOCA(I))/RHOGON (0311) SXPER = 0.D0 (0312) SYPER = 0.D0 (0313) IF(BLOCA(I).GT.-6.283) NELIM(2*I+2) = 2*(MCONF+I) (0314) 39 DO 40 J=1,10 (0315) READ(1,*) XPER,YPER (0316) WRITE(6,6073) XPER,YPER (0317) 6073 FORMAT(12X,2F9.0/) (0318) PER(JJ,1) = XPER (0319) PER(JJ,2) = YPER (0320) 83 IF(XPER.EQ.PER(NPER(I,1),1).AND.YPER.EQ.PER(NPER(I,1),2) (0321) 1 .AND.J.NE.1) GOTO 84 (0322) SXPER = SXPER + XPER (0323) SYPER = SYPER + YPER (0324) JJ=JJ+1 (0325) 40 CONTINUE (0326) 84 CONTINUE (0327) NPER(I,2)=JJ (0328) C BLOCK REFERENCE POINTS (0329) JJ=JJ+1 (0330) PER(JJ,1) = SXPER/(J-1) (0331) PER(JJ,2) = SYPER/(J-1) (0332) IF(BLCREF(1).NE.0.D0) PER(JJ,1) = BLCREF(1) (0333) IF(BLCREF(2).NE.0.D0) PER(JJ,2) = BLCREF(2) (0334) JJ=JJ+1 (0335) IF(JJ.GT.50)GOTO 902 (0336) 38 CONTINUE (0337) JJBLOC = JJ (0338) 96 CONTINUE (0339) (0340) C NUMBER OF UNKNOWN COEFFICIENTS (0341) MCONF1 = MCONF (0342) MCONF = MBLOC + MCONF (0343) NU = MCONF + MANTIC (0344) (0345) C DEFINE APPROXIMATION FUNCTION IN TIME (0346) WRITE(6,6028) (0347) 6028 FORMAT(1H //' APPROXIMATION FUNCTION IN TIME:'/1H ,31(1H-)//) (0348) WRITE(1,6015) (0349) 6015 FORMAT(' SELECTION OF TIME FUNCTION: '/) (0350) CALL TNOUA('POWER OF TIME POLYN.: ,NUMBER OF EPISODES: ',43) (0351) CALL TNOUA(' NP+NE < 10',13) (0352) READ(1,*) NTPOLY,NEPIS (0353) MT = NTPOLY + NEPIS (0354) WRITE(6,6016) NTPOLY,NEPIS,MT (0355) 6016 FORMAT(1H ,'POWER OF THE TIME APPROX. POLYNOMIAL : ',T48,I2/ (0356) 1 ' NUMBER OF LINEAR EPISODES : ',T48,I2/ (0357) 2 ' TOTAL POWER OF GENERALIZED TIME POLYNOMIAL : ',T48,I2//) (0358) (0359) 91 IF(NEPIS.EQ.0) GOTO 92 (0360) WRITE(1,6026) (0361) WRITE(6,6026) (0362) 6026 FORMAT(1H /' DEFINITION OF LINEAR EPISODES :'/) (0363) 93 DO 94 I=1,NEPIS (0364) CALL TNOUA(' BEGIN, END OF EPISODE [YR] : ',30) (0365) READ(1,*) (BE(I,J),J=1,2) (0366) WRITE(6,6027) I,(BE(I,J),J=1,2) (0367) 6027 FORMAT(1H /' EPISODE # ',I2,' BEGIN : ',F8.3,' END : ',F8.3/) (0368) 94 CONTINUE (0369) 92 CONTINUE (0370) (0371) C SELECT REJECTION CRITERIA FOR FOURIER COEFFICIENTS (0372) 201 IF(LPREAN) GOTO 202 (0373) WRITE(6,6018) (0374) 6018 FORMAT(1H /' TEST OPTIONS:'/1H ,13(1H-)//) (0375) CALL TNOUA('LEVEL OF SIGNIFIC. FOR TEST OF FOURIER COEFF.[%]:',49) (0376) READ(1,*)ALFAT (0377) ALFT = ALFAT/200.D0 (0378) FACTK = 2.D0 * ALFT (0379) FACTK = DNEWTO(DCNORM,DNORM,ALFT,FACTK) (0380) WRITE(6,6019)ALFAT,FACTK (0381) WRITE(1,6019)ALFAT,FACTK (0382) 6019 FORMAT(1H ,'LEVEL OF SIGNIFIC. FOR TEST OF FOURIER COEFF.[%]:', (0383) 1 T55,F8.4/' VAR. FACTOR FOR TESTING FOURIER COEFF.: ',T55, (0384) 2 F8.4/) (0385) CALL TNOUA('LEVEL OF CONFIDENCE (CONF. REGIONS) [%]:',40) (0386) READ(1,*)ALPH (0387) WRITE(6,6081) ALPH (0388) 6081 FORMAT(1H ,'LEVEL OF CONFIDENCE [%] :',T55,F8.4//) (0389) ALPH = ALPH/100.D0 (0390) (0391) C TEST OPTIONS (0392) WRITE(6,6082) (0393) WRITE(1,6082) (0394) 6082 FORMAT(' TEST ON THE ORTHO-NORMAL COEFFICIENTS:'// (0395) 1 'OPT.# STATISTICS: TEST CRIT.: ADDITIONAL COMPUT.:'/ (0396) 2/' 0 NO REJECTION NONE'/ (0397) 3 ' 1 X(ON)**2 > VAR. A PRIORI VAR.FACT.'/ (0398) 4 ' -1 X(ON)**2 > VAR. A PRIORI NONE'/ (0399) 5 ' 2 X(ON)**2 > VAR. A POST. VAR.FACT. CHI-SQ.T.' (0400) 6/' -2 X(ON)**2 > VAR. A POST. VAR.FACT.'/ (0401) 7 ' 3 X(ON)**2 > VAR. A PRI/POST. VAR.FACT. CHI-SQ.T.' (0402) 8/' -3 X(ON)**2 > VAR. A POST.'//) (0403) CALL TNOUA('OPT.# : ',8) (0404) READ(1,*) ITOPT (0405) WRITE(6,6083) ITOPT (0406) 6083 FORMAT(1H ,' OPTION # : ',I4///) (0407) (0408) 645 IF(ITOPT.NE.-3) GOTO 646 (0409) CALL TNOUA('CRIT. VALUE FOR X(ON) TESTING',29) (0410) READ(1,*) CRXON (0411) 646 CONTINUE (0412) (0413) C OPTIONS OF STATISTICAL MODEL (0414) WRITE(6,6088) (0415) WRITE(6,6089) (0416) 6088 FORMAT(1H /' OPTIONS OF STATISTICAL MODEL:'/1X,29(1H-)//) (0417) CALL TNOUA('STATISTICAL OPTION:',19) (0418) WRITE(1,6089) (0419) 6089 FORMAT(1H /' OPT.# OPTION:'/ (0420) 1 ' VAR.FACT.: COV. MATRIX OF COEFF.:'/ (0421) 2 ' UNKNOWN KNOWN A PRIORI A POST.'/ (0422) 3/' A=0 B=0'/ (0423) 4 ' A=1 B=1'/) (0424) CALL TNOUA('OPT.#: A,B: ',12) (0425) READ(1,*)ISTAT (0426) WRITE(6,6087) ISTAT (0427) 6087 FORMAT(1H ,'A=',I2,4X,'B=',I2) (0428) (0429) C SELECT PLOTTING OPTIONS (0430) 202 CONTINUE (0431) 702 CONTINUE (0432) WRITE(6,6029) (0433) 6029 FORMAT(1H //' PLOTTING OPTIONS:'/1H ,17(1H-)//) (0434) WRITE(6,6204) (0435) WRITE(1,6204) (0436) 6204 FORMAT(1H ,'OPTIONAL PLOTTING OF ISOLINES:'// (0437) + ' (WITHOUT PLOTTING OF STRAIN FIGURES AT GRID POINTS!)'// (0438) 1 ' OPTION: OPTION #:'// (0439) 2 ' LINE OF EQUAL: STRAIN VALUE: ITS VARIANCE:'// (0440) 3 ' NO PLOTTING 0 0'/ (0441) 4 ' DILATION 1 -1'/ (0442) 5 ' AV. ROTATION 2 -2'/ (0443) 6 ' TOTAL SHEAR 3 -3'/ (0444) 7 ' SHEAR IN AZ. 4 -4'//) (0445) CALL TNOUA('OPT. # : ',9) (0446) READ(1,*) IISO (0447) WRITE(6,6206) IISO (0448) 6206 FORMAT(1H ,'OPTION # :',I3//) (0449) LPLTG = (IISO.EQ.0) (0450) (0451) 105 IF(IISO.EQ.0) GOTO 106 (0452) 109 IF(IABS(IISO).NE.4) GOTO 110 (0453) CALL TNOUA('AZIMUTH IN WHICH SHEAR IS TO BE PREDICTED [GON]:',48) (0454) READ(1,*) AZSHR (0455) WRITE(6,6090) AZSHR (0456) 6090 FORMAT(1H ,'AZIMUTH OF PREDICTED SHEAR [GON]: ',F10.4//) (0457) AZSHR = (100.-AZSHR)/RHOGON (0458) 110 CONTINUE (0459) (0460) CALL TNOUA('LOWER/UPPER LIMIT OF SCALAR PLOT FUNCTION: ',43) (0461) READ(1,*) SLOW,SUP (0462) WRITE(6,6091) SLOW,SUP (0463) 6091 FORMAT(1H ,'LOWER/UPPER LIMIT OF SCALAR PLOT FUNCTION: ',2F10.4/ (0464) 1 //) (0465) 106 CONTINUE (0466) (0467) C DEFINE GRID OF PREDICTION IN SPACE AND TIME (0468) WRITE(6,6030) (0469) 6030 FORMAT(1H //' PREDICTION OPTIONS:'/1H ,19(1H-)//) (0470) WRITE(1,1004) (0471) 1004 FORMAT(1H // (0472) 1 ' PREDICTION IN TIME: AT REGUL.INTERV. AT FIXED TIMES'/ (0473) 2/' NO PREDICTION #0 # 0'/ (0474) 3 ' ACCUMULATED STRAIN #1 #-1'/ (0475) 4 ' STRAIN RATES #2 #-2'//) (0476) CALL TNOUA('OPT.# : ',8) (0477) READ (1,*) IPREDO (0478) (0479) CALL TNOUA('REFERENCE TIME [YR] : ',22) (0480) READ(1,*) TIME0 (0481) WRITE(6,6109) TIME0 (0482) 6109 FORMAT(1H /' REFERENCE TIME [YR] : ',F9.3//) (0483) (0484) C PREDICTION IN SPACE (0485) WRITE(1,6086) (0486) WRITE(6,6086) (0487) 6086 FORMAT(1H / (0488) 1 ' PREDICTION IN SPACE: WITH PRINT: STORE ONLY:'// (0489) 2 ' AT ALL STATIONS # 1 # -1'/ (0490) 3 ' AT GRID POINTS # 2 # -2'/ (0491) 4 ' AT GIVEN LOCATIONS # 3'/ (0492) 5 ' AT BLOC BOUNDARIES # 4'/ (0493) 6 ' TERMINATE SELECTION : # 0'//) (0494) 107 DO 108 I=1,4 (0495) CALL TNOUA('OPTION #: ',10) (0496) READ(1,*) J (0497) 113 IF(J.EQ.0) GOTO 114 (0498) WRITE(6,6085) J (0499) 6085 FORMAT(' OPTION #: ',I3/) (0500) IF(IABS(J).EQ.1) ISPACE(1)=J (0501) IF(IABS(J).EQ.2) ISPACE(2)=J (0502) IF(IABS(J).EQ.3) ISPACE(3)=J (0503) IF(IABS(J).EQ.4) ISPACE(4)=J (0504) 108 CONTINUE (0505) 114 CONTINUE (0506) 115 IF(ISPACE(2).EQ.0) GOTO 116 (0507) CALL TNOUA('NUMBER OF GRID INTERVALS ',26) (0508) READ(1,*) NGRID (0509) 116 CONTINUE (0510) (0511) 117 IF(ISPACE(4).EQ.0) GOTO 118 (0512) WRITE(6,6092) (0513) WRITE(1,6092) (0514) 6092 FORMAT(1H ,'ACTIVE FAULT LINE:'/ (0515) 1' BLOCK LEFT # BLOCK RIGHT # FROM: X Y TO: X Y'/) (0516) IJ=1 (0517) MBLOC1= MBLOC-1 (0518) 121 DO 122 IBLOC=0,MBLOC1 (0519) IBLOC1=IBLOC+1 (0520) 123 DO 124 JBLOC=IBLOC1,MBLOC (0521) WRITE(1,6093) IBLOC,JBLOC (0522) 6093 FORMAT(4X,2(I2,4X)) (0523) READ(1,*) X1,Y1,X2,Y2 (0524) 187 IF(X1.EQ.0.D0.AND.Y1.EQ.0.D0) GOTO 188 (0525) SXPER = (X1+X2)/2.D0 (0526) SYPER = (Y1+Y2)/2.D0 (0527) ALIN = DATAN2(Y2-Y1,X2-X1) (0528) FAULT(IJ,1) = SXPER + DSIN(ALIN)*1.D2 (0529) FAULT(IJ,2) = SYPER - DCOS(ALIN)*1.D2 (0530) FAULT(IJ,3) = SXPER - DSIN(ALIN)*1.D2 (0531) FAULT(IJ,4) = SYPER + DCOS(ALIN)*1.D2 (0532) WRITE(6,6094) IBLOC,JBLOC,X1,Y1,X2,Y2 (0533) 6094 FORMAT(11X,I2,14X,I2,2X,2(2F9.0,2X)) (0534) 188 CONTINUE (0535) IJ = IJ+1 (0536) 124 CONTINUE (0537) 122 CONTINUE (0538) 118 CONTINUE (0539) (0540) 47 IF(IPREDO.LE.0) GOTO 48 (0541) CALL TNOUA('NUMBER OF TIME INTERVALS FOR PREDICTION : ',42) (0542) READ(1,*) NTIMIN (0543) 49 GOTO 50 (0544) 48 CONTINUE (0545) 51 DO 52 I=1,30 (0546) CALL TNOUA('PREDICTION TIMES [YR] (END=-9): ',32) (0547) READ(1,*) TPRED(I) (0548) 53 IF(TPRED(I).EQ.-9.D0) GOTO 54 (0549) 52 CONTINUE (0550) 54 CONTINUE (0551) NTIMIN = I-1 (0552) 50 CONTINUE (0553) WRITE(6,1004) (0554) WRITE(6,6017) IPREDO,NTIMIN,NGRID (0555) 6017 FORMAT(1H ,'OPTION # ',I2// (0556) 1 ' NUMBER OF TIME INTERVALS: ',I2/ (0557) 2 ' NUMBER OF GRID INTERVALS: ',I2//) (0558) 706 IF(LPREDI) GOTO 707 (0559) (0560) (0561) C READ NUMBER OF OBSERVATION EPOCHS, OBSERVATION TIME [YR], (0562) C NUMBER OF NUISANCE PARAMETERS, VARIANCE FACTOR (0563) WRITE(6,6032) (0564) 6032 FORMAT(1H //' OBSERVATION DATA:'/1H ,17(1H-)//) (0565) READ(5,5101) NNET (0566) 5101 FORMAT(I2) (0567) WRITE(6,6201) NNET (0568) 6201 FORMAT(1H /' NUMBER OF OBSERVATION EPOCHS: ',I4//) (0569) WRITE(6,6203) (0570) 6203 FORMAT(' OBSERVATION EPOCHS:'//' #',3X,'EPOCH',15X,'TIME[YR]'1X, (0571) 1 'NUIS.PAR.',2X,'VAR.FACT.'/) (0572) (0573) NN = 0 (0574) 101 DO 102 I=1,NNET (0575) READ(5,5102) (NEPOC(I,J),J=1,2),TIME(I),(NUIPAR(I,J),J=1,2), (0576) 1 VARF(I) (0577) 5102 FORMAT(2A8,F10.3,2I2,F10.6) (0578) IF(ISTAT(1).EQ.0) VARF(I) = 1.D0 (0579) WRITE(6,6202)I,(NEPOC(I,J),J=1,2),TIME(I),(NUIPAR(I,J),J=1,2), (0580) 1 VARF(I) (0581) 6202 FORMAT(I4,2X,2A8,2X,F10.3,2X,I1,2X,I1,4X,F10.6) (0582) NN = NN + NUIPAR(I,1) + NUIPAR(I,2) (0583) 102 CONTINUE (0584) (0585) C NUMBER OF NUISANCE PARAMETERS (0586) WRITE(6,6005) NN (0587) 6005 FORMAT(1H /' NUMBER OF NUISANCE PARAMETERS: ',I2//) (0588) (0589) C TOTAL TIME SPAN OF OBSEVATIONS AND TIME INTERVAL OF PREDICTION (0590) TIMSPA = TIME(I) - TIME(1) (0591) TIMINT = 0.D0 (0592) 58 IF(NTIMIN.EQ.0.OR.IPREDO.LE.0) GOTO 59 (0593) TIMINT = TIMSPA / NTIMIN (0594) 59 CONTINUE (0595) IF(NGRID.NE.0) GRIDWM = 2./NGRID * SCALP (0596) WRITE(6,6007) TIMSPA,TIMINT,GRIDWM (0597) 6007 FORMAT(1H /' TOTAL TIME SPAN OF OBSERVATION [YR] : ',T44,F8.3/ (0598) 1 ' TIME INTERVAL OF PREDICTION [YR] : ',T44,F8.3/ (0599) 2 ' GRID INTERVAL OF PREDICTION [M] : ',T44,F8.3//) (0600) (0601) C SCALE TIME OF EPISODES (0602) 97 DO 98 I = 1,NEPIS (0603) BE(I,1) = (BE(I,1)-TIME0)/(TIMSPA/2.) (0604) BE(I,2) = (BE(I,2)-TIME0)/(TIMSPA/2.) (0605) 98 CONTINUE (0606) (0607) C READ TITLE OF NETWORKS, NUMBER, IDENT. AND COORD. OF FIXED POINTS (0608) INPAR = 1 (0609) ISOBS = 0 (0610) ISNU = 0 (0611) 71 DO 72 INET=1,NNET (0612) C CALL TIMDAT(ITIM,15) (0613) C WRITE(1,1691)(ITIM(JT),JT=4,10) (0614) 1691 FORMAT('#1',7I6) (0615) CALL RDNET(INET,NP,NP1,P0,NAME,P,NFIX,LPRINT,NONET,NUNET, (0616) 1 NH,NUH,NNOR,NTIT) (0617) ISOBS = ISOBS + NONET(INET) (0618) ISNU = ISNU + NUNET(INET) (0619) (0620) WRITE(1,6042) INET,NTIT (0621) 6042 FORMAT(/' NETWORK # ',I3,' : ',40A2) (0622) WRITE(6,6041)NP,NONET(INET),NUNET(INET),NH,NUH (0623) WRITE(1,6041)NP,NONET(INET),NUNET(INET),NH,NUH (0624) 6041 FORMAT(1H ,'NUMBER OF POINTS: ',T38,I3,2X, (0625) 1 'TOTAL NUMBER OF OBSERVATIONS:',T76,I3/ (0626) 2 ' NUMBER OF NETWORK NUISANCE PARAM.:',T38,I3,2X,'NUMBER OF OBSERV (0627) 3ED HEIGHTS:',T76,I3/' NUMBER OF HEIGHT UNKNOWNS:',T38,I3//) (0628) (0629) 31 IF(INET.GE.2) GOTO 32 (0630) (0631) C CONVERT POSITON INTO COMPLEX VARIABLES (0632) CALL CPLXPO(Z,P,P0,SCALP,NP1,NFIX) (0633) SCALR = SCALP/SCALD (0634) D0(1) = 0.D0 (0635) D0(2) = 0.D0 (0636) (0637) C CONVERT PERIMETER POLYGON VERTICES INTO COMPLEX VARIABLES (0638) 87 DO 88 I=1,JJBLOC (0639) ZBLC(I) = CMPLX(SNGL((PER(I,1)-P0(1))/SCALP),SNGL((PER(I,2)- (0640) 1 P0(2))/SCALP)) (0641) 88 CONTINUE (0642) (0643) C CHECK IF STATION IS IN BLOCK (0644) WRITE(6,6002) (0645) 6002 FORMAT(1H //' NAME',9X,'COMPLEX POSITIONS:',T40,'IN BLOCK:(0=OUTSI (0646) 1DE,1=INSIDE,0.5=ON SIDE OR VERTICE)'//T40,'#1',4X,'#2',4X,'#3',4X, (0647) 2 '#4',4X,'#5'//) (0648) 11 DO 12 I=1,NP (0649) 75 IF(MBLOC.EQ.0) GOTO 76 (0650) 73 DO 74 IBLOC=1,MBLOC (0651) PBLOC(IBLOC)=PINPOL(Z(I),ZBLC,NPER(IBLOC,1),NPER(IBLOC,2),3) (0652) 74 CONTINUE (0653) 76 CONTINUE (0654) WRITE(6,6003) (NAME(I,J),J=1,4),Z(I),(PBLOC(J),J=1,MBLOC) (0655) 6003 FORMAT(1H ,4A2,4X,2F8.4,10X,5(F3.1,3X)) (0656) 12 CONTINUE (0657) (0658) WRITE(6,6004)P0,D0,SCALP,SCALD,SCALR (0659) 6004 FORMAT(1H //' LOCAL ORIGINES: ',T55,'SCALE FACTORS:',13X, (0660) 1 'RATIO:' //6X,'X0',11X,'Y0',11X,'U0',9X,'V0',T55,'POSITIONS',7X, (0661) 2 'DISPLACEM.'//7F13.4//) (0662) (0663) C COMPLEX OBSERVATION EQUATIONS (0664) 5 DO 6 I=1,NP (0665) CPXA(I,1) = (1.,0.) (0666) CALL CALPOL(PHI,Z(I),MDIM,MCONF1,MCONF) (0667) 7 DO 8 J=1,MCONF (0668) CPXA(I,J) = PHI(1,J) (0669) 8 CONTINUE (0670) ZC = CONJG(Z(I)) (0671) CALL CALPOL(PHI,ZC,MDIM,MANTIC,MANTIC) (0672) 9 DO 10 J=1,MANTIC (0673) CPXA(I,MCONF+J) = PHI(1,J) (0674) 10 CONTINUE (0675) 6 CONTINUE (0676) (0677) IF(LPRINT)WRITE(6,2002) (0678) 2002 FORMAT(1H ,'COMPLEX A-MATRIX'/) (0679) 1 DO 2 I=1,NP (0680) 1003 FORMAT(8F10.3) (0681) IF(LPRINT)WRITE(6,2003)(CPXA(I,J),J=1,NU) (0682) 2003 FORMAT(1H /4(F11.3,2X,F11.3,4X)) (0683) 2 CONTINUE (0684) (0685) NP2 = NP*2 (0686) NP2H = NP2 + NUH (0687) NU2 = NU*2 (0688) NDE = NP2 + NN + NUH (0689) (0690) C COMPUTE REAL A-MATRIX (0691) CALL DMREAL(CPXA,A,NPDIM,NUDIM,NP2DIM,NU2DIM,NP,NU) (0692) IF(LPRINT)WRITE(6,2015) (0693) 2015 FORMAT(1H /' REAL A-MATRIX'/) (0694) IF(LPRINT)CALL DMTOUT(A,NP2DIM,NU2DIM,NP2,NU2,6,'D','5') (0695) (0696) C STORE FIRST TWO COLUMNS OF A (0697) 25 DO 26 I=1,NP2 (0698) 27 DO 28 J=1,2 (0699) A2R(I,J) = A(I,J) (0700) 28 CONTINUE (0701) 26 CONTINUE (0702) (0703) WRITE(1,1877) NELIM (0704) 1877 FORMAT(I4) (0705) 77 DO 78 I=1,13 (0706) J=14-I (0707) CALL DELROW(A,A,NELIM(J),NP2DIM,NU2DIM,NP2,NU2) (0708) 78 CONTINUE (0709) (0710) IF(LPRINT) CALL DMTOUT(A,NP2DIM,NU2DIM,NP2,NU2,6,'D','5') (0711) (0712) 32 CONTINUE (0713) (0714) C TIME DIFFERENCE (0715) DTIME = TIME(INET) - TIME0 (0716) WRITE(6,6001)TIME(INET),DTIME (0717) 6001 FORMAT(1H ,'OBSERVATION TIME',4X,'TIME DIFFERENCE'/4X,F10.3,10X, (0718) 1 F10.3///) (0719) (0720) C NORMAL EQUATIONS OF I TH EPOCH (0721) C CALL TIMDAT(ITIM,15) (0722) C WRITE(1,1692)(ITIM(JT),JT=4,10) (0723) 1692 FORMAT('#2',7I6) (0724) NDE2 = NDE-NP2H (0725) NDE2DI = NDEDIM-NP2HDI (0726) CALL BMAT(B,A2R,NUIPAR,INET,INPAR,NP2DIM,NP2HDI,NDE,NDEDIM,NP2, (0727) 1 NP2H,NN,NDE2DI,NDE2) (0728) IF(LPRINT) CALL DMTOUT(B,NP2DIM,NDE2DI,NP2,NDE2,6,'D','5') (0729) C CALL TIMDAT(ITIM,15) (0730) C WRITE(1,1693)(ITIM(JT),JT=4,10) (0731) 1693 FORMAT('#2A',7I6) (0732) (0733) NRC = NU2 * MT (0734) NCC = NU * MT (0735) (0736) DTIMN = DTIME/(TIMSPA/2.) (0737) CALL NORMAL(INET,NP2,NP2H,NU2,NDE,LPRINT,SCALD,DTIMN,VARF(INET), (0738) 1 MT,NRC) (0739) (0740) 72 CONTINUE (0741) (0742) WRITE(6,6901) (0743) WRITE(6,6020) (0744) 6020 FORMAT(1H ,'LEAST SQUARES APPROXIMATION'/1H ,27(1H*)//) (0745) C ELIMINATE NUISANCE PARAMETERS (0746) CALL DELCYC(NDE,NRC,IERR,LPRINT) (0747) (0748) C PERFORM LEAST SQUARES ADJUSTMENT (0749) CALL LSQUA(XR,APVARF,ISING,NP,NU,NU2,NN,NNET,NUIPAR,FACTK,SCALD, (0750) 1 TIME,ITOPT,LPRINT,NONET,NUNET,LPREAN,NUH,ALPH,NRC,ISTAT, (0751) 2 TIMSPA,MT,ISOBS,ISNU,TIME0,ALPHP,XICHI,IDIM,CRXON) (0752) (0753) C COMPLEX PARAMETERS (0754) NU22 = 2*NU (0755) NRC2 = NU22*MT (0756) CALL CPXPAR(CPXX,XR,NU,NU2,NELIM,MT) (0757) IF(LPRINT) WRITE(6,6058) (0758) 6058 FORMAT(1H ,'X'/) (0759) IF(LPRINT) CALL DMTOUT(XR,NRCDIM,1,NRC2,1,6,'D','5') (0760) (0761) C STORE COEFFICIENTS AND THEIR COV.-MATRIX ON FILE "P_PREDICT" (0762) WRITE(9,9091)(NPROJ1(I),I=1,20),(NPROJ2(I),I=1,20) (0763) 9091 FORMAT(20A2,20A2) (0764) WRITE(9,9087) ALPHP,XICHI,IDIM (0765) WRITE(9,9092)NU,NU2,MCONF,MANTIC,NCC,NRC,MT,MBLOC,MCONF1,MDIM,NP1, (0766) 1 NNET,JJBLOC,NEPIS,NRC2,NTPOLY (0767) 9092 FORMAT(I4) (0768) IF(MBLOC.NE.0) WRITE(9,9096) ((NPER(I,J),J=1,2),I=1,MBLOC) (0769) 9096 FORMAT(2I2) (0770) IF(MBLOC.NE.0) WRITE(9,9097) ((PER(I,J),J=1,2),I=1,JJBLOC) (0771) 9097 FORMAT(2F12.0) (0772) IF(MBLOC.NE.0) WRITE(9,9095) (BLOCA(I),I=1,MBLOC) (0773) WRITE(9,9093) ((NAME(I,J),J=1,4),I=1,NP1) (0774) 9093 FORMAT(A2) (0775) WRITE(9,9095) (Z(I),I=1,NP1),(ZBLC(J),J=1,JJBLOC) (0776) WRITE(9,9095) (TIME(I),I=1,NNET),TIMSPA,TIME0,BE (0777) 9095 FORMAT(E20.13) (0778) WRITE(9,9095) D0,P,P0,SCALP,SCALD,SCALR (0779) WRITE(9,9095) (CPXX(I,1),I=1,NCC) (0780) 81 DO 82 I=1,NRC2 (0781) WRITE(9,9095) (CX(I,J),J=I,NRC2) (0782) 82 CONTINUE (0783) (0784) 707 CONTINUE (0785) C WRITE CONF.LEVEL, XICHI AND DIM. OF SAMPLE INTO FILE 'P_STRAIN' (0786) WRITE(7,7011) ALPHP,XICHI,IDIM (0787) 7011 FORMAT(2F8.4,I4) (0788) (0789) 758 IF(NTIMIN.EQ.0.OR.IPREDO.LE.0) GOTO 759 (0790) TIMINT = TIMSPA/NTIMIN (0791) 759 CONTINUE (0792) (0793) C COMPLEX COEFFICIENTS AND STANDARD DEVIATIONS (0794) WRITE(6,6901) (0795) WRITE(6,6006) (0796) 6006 FORMAT(1H //' COMPLEX COEFFICIENTS OF THE APPROX. POLYNOMIAL:'/ (0797) 1 1H ,47(1H-)//) (0798) WRITE(6,6008) (0799) 6008 FORMAT(1H //' CONFORMAL TERM:'//) (0800) WRITE(6,6024) (0801) 6024 FORMAT(2X,'I',7X,'T1',12X,'T2',12X,'T3',12X,'T4',12X,'T5',12X, (0802) 1 'T6',12X,'T7',12X,'T8',12X,'T9'/5X,9('REAL',3X,'IMAG',3X)) (0803) 15 DO 16 I=1,MCONF (0804) IF(I.EQ.MCONF1+1) WRITE(6,6043) (0805) 6043 FORMAT(6X,'BLOCK MOTION COEFFICIENTS:'/) (0806) WRITE(6,6011) I,(CPXX(J,1),J=I,NCC,NU) (0807) 6011 FORMAT(1H ,I2,1X,18F7.4/4X,18F7.4) (0808) 16 CONTINUE (0809) (0810) 288 IF(MANTIC.EQ.0) GOTO 289 (0811) WRITE(6,6009) (0812) 6009 FORMAT(1H ,//' ANTICONFORMAL TERM:'//) (0813) WRITE(6,6024) (0814) 17 DO 18 I=1,MANTIC (0815) MCONFI = MCONF+I (0816) WRITE(6,6011) I,(CPXX(J,1),J=MCONFI,NCC,NU) (0817) 18 CONTINUE (0818) 289 CONTINUE (0819) WRITE(6,6159) (0820) 6159 FORMAT(1H //' STANDARD DEVIATIONS OF THESE COEFFICIENTS:'//) (0821) WRITE(6,6008) (0822) WRITE(6,6024) (0823) 33 DO 34 I=1,MCONF (0824) JJ=1 (0825) 61 DO 62 J=I,NCC,NU (0826) JR = 2*J-1 (0827) 65 DO 66 II=1,2 (0828) SIG(JJ) = CX(JR,JR) (0829) IF(SIG(JJ).LT.0.) SIG(JJ)=0. (0830) SIG(JJ) = SQRT(SIG(JJ)) (0831) JJ=JJ+1 (0832) JR=JR+1 (0833) 66 CONTINUE (0834) 62 CONTINUE (0835) WRITE(6,6011) I,(SIG(2*J-1),SIG(2*J),J=1,MT) (0836) 34 CONTINUE (0837) (0838) 286 IF(MANTIC.EQ.0) GOTO 287 (0839) WRITE(6,6009) (0840) WRITE(6,6024) (0841) 35 DO 36 I=1,MANTIC (0842) JJ=1 (0843) MCONFI = MCONF+I (0844) 63 DO 64 J=MCONFI,NCC,NU (0845) JR = 2*J-1 (0846) 69 DO 70 II=1,2 (0847) SIG(JJ) = CX(JR,JR) (0848) IF(SIG(JJ).LT.0.) SIG(JJ)=0. (0849) SIG(JJ) = SQRT(SIG(JJ)) (0850) JJ=JJ+1 (0851) JR=JR+1 (0852) 70 CONTINUE (0853) 64 CONTINUE (0854) WRITE(6,6011) I,(SIG(2*J-1),SIG(2*J),J=1,MT) (0855) 36 CONTINUE (0856) 287 CONTINUE (0857) (0858) C APPROX. DISPLACEMENT, RESIDUALS AND COMPLEX STRAIN COMPONENTS (0859) IF(IPREDO.EQ.0) GOTO 9999 (0860) DTIME = -1.D0*TIMSPA/2.D0 (0861) 41 DO 42 ITIME = 1,NTIMIN (0862) WRITE(6,6901) (0863) IF(IPREDO.LE.0) DTIME = TPRED(ITIME)-TIME0 (0864) TPRE = TIME0 + DTIME (0865) WRITE(6,6014) ITIME,TPRE,DTIME (0866) WRITE(1,1014) ITIME,TPRE (0867) 1014 FORMAT(I2,'-TH PREDICTION: T= ',F8.3/) (0868) DTIMN = DTIME/(TIMSPA/2.) (0869) 6014 FORMAT(1H ,I2,'-TH PREDICTION OF STRAIN TENSOR FIELD AT TIME : ', (0870) 1 F8.3,10X,' DT [YR] = ',F8.3//) (0871) (0872) C PREDICTION OF RIGID BLOC MOTIONS (0873) 55 IF(MBLOC.EQ.0) GOTO 56 (0874) WRITE(6,6096) (0875) 6096 FORMAT(1H //' PREDICTION OF RIGID BLOC MOTIONS:'//) (0876) IF(IABS(IPREDO).EQ.2) WRITE(6,6076) (0877) 6076 FORMAT(1H /' RELATIVE BLOCK MOTION VELOCITIES: '//' FOR',T10, (0878) 1'REL.TO',T20,'VELOCITIES',T64,'STD.DEV.',T80,'AZIMUTH OF VELOC.'// (0879) 2' BLOCK #',T10,'BLOCK #',T20,'VX[MM/YR]',4X,'VY[MM/YR]',6X, (0880) @ 'VS[MM/YR]',T64,'SVX', (0881) 3 6X,'SVY',T80,'AZ[GON]'//) (0882) IF(IABS(IPREDO).EQ.1) WRITE(6,6077) (0883) 6077 FORMAT(1H /' ACCUMULATED RELATIVE BLOCK DISPLACEMENTS: '//' FOR', (0884) 1 T10,'REL.TO',T20,'DISPLACEMENTS',T64,'STD.DEV.',T80, (0885) 2 'AZIMUTH OF DISPLACEMENT'//' BLOCK #',T10,'BLOCK #', (0886) 3 T20,'DX[MM]',6X,'DY[MM]',6X,'DS[MM]',T64,'SDX',6X,'SDY',6X, (0887) @'AZ[GON]'/) (0888) (0889) CALL BLOC(ZBLC,NPER,MBLOC,XYBLOC,SXYBLC,BLOCAZ,CPXX, (0890) 1MDIM,MCONF,MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1) (0891) (0892) IJ=1 (0893) MBLOC1 = MBLOC-1 (0894) 85 DO 86 IBLOC=0,MBLOC1 (0895) IBLOC1 = IBLOC+1 (0896) J1 = NPER(IBLOC1,1) (0897) J2 = NPER(IBLOC1,2) (0898) IF(ISPACE(4).NE.0) WRITE(7,7006) IBLOC1,(PER(J2+1,J),J=1,2) (0899) 7006 FORMAT(' %',I2,4X,2F10.2,52X/80X/80X) (0900) IF(ISPACE(4).NE.0) WRITE(7,7005)((PER(I,J),J=1,2),I=J1,J2) (0901) 7005 FORMAT(' $',6X,2F10.2,52X/80X/80X) (0902) 185 DO 186 JBLOC=IBLOC1,MBLOC (0903) X1 = XYBLOC(IJ,1)/2.D0 (0904) Y1 = XYBLOC(IJ,2)/2.D0 (0905) 281 DO 282 J=1,2 (0906) XYBLOC(IJ,J) = XYBLOC(IJ,J)*1.E3 (0907) SXYBLC(IJ,J) = SXYBLC(IJ,J)*1.E3 (0908) 282 CONTINUE (0909) X2 = DSQRT(XYBLOC(IJ,1)**2 + XYBLOC(IJ,2)**2) (0910) WRITE(6,6097) JBLOC,IBLOC,(XYBLOC(IJ,J),J=1,2),X2, (0911) 1 (SXYBLC(IJ,J),J=1,2),BLOCAZ(IJ) (0912) 6097 FORMAT(2X,I2,T10,2X,I2,T20,3F10.4,T60,2F10.4,T80,F8.2) (0913) 125 IF(FAULT(IJ,1).EQ.0.D0) GOTO 126 (0914) IF(DABS(X1).GT.1.D2.OR.DABS(Y1).GT.1.D2) GOTO 126 (0915) X2 = -X1 (0916) Y2 = -Y1 (0917) IF(ISPACE(4).NE.0)WRITE(7,7007) JBLOC,IBLOC, (0918) 1 (FAULT(IJ,J),J=1,2),X1,Y1 (0919) IF(ISPACE(4).NE.0)WRITE(7,7008) (FAULT(IJ,J),J=3,4),X2,Y2 (0920) 7007 FORMAT(' #',I2,'-',I2,1X,2F10.2,2F8.4,36X,/80X/80X) (0921) 7008 FORMAT(' #',6X,2F10.2,2F8.4,36X/80X/80X) (0922) 126 CONTINUE (0923) IJ=IJ+1 (0924) 186 CONTINUE (0925) 86 CONTINUE (0926) 56 CONTINUE (0927) (0928) (0929) 103 IF(ISPACE(1).EQ.0) GOTO 104 (0930) IF(IABS(IPREDO).EQ.2)WRITE(6,6010) (0931) 6010 FORMAT(1H //' STRAIN RATE TENSOR FIELD AND DISPLACEMENT RATES:' (0932) 1 //' NAME',5X,'POSITION',16X,'APPROX.DISPL.RATES [MM/YR]' (0933) 2 ,3X,'COMPLEX STRAIN RATE COMPONENTS [MICROSTRAIN/YR]'// (0934) 3 34X,'VARIANCE',T64,'VARIANCE'// (0935) 4 16X,'X',11X,'Y',11X,'U',11X,'V',10X,'SIGMA',7X,'OMEGA',8X,'TAU', (0936) 5 7X,'YPSILON',5X,'T.SHEAR',4X,'SHEAR-AZ.'/1X,T123,'[GON]'//) (0937) IF(IABS(IPREDO).EQ.1)WRITE(6,6051) (0938) 6051 FORMAT(1H //' ACCUMULATED STRAIN TENSOR FIELD AND DISPLACEMENTS:' (0939) 1 //' NAME',5X,'POSITION',16X,'APPROX.DISPL. [MM] ' (0940) 2 ,3X,'COMPLEX STRAIN COMPONENTS [MICROSTRAIN] '// (0941) 3 34X,'VARIANCE',T64,'VARIANCE'// (0942) 4 16X,'X',11X,'Y',11X,'U',11X,'V',10X,'SIGMA',7X,'OMEGA',8X,'TAU', (0943) 5 7X,'YPSILON',5X,'T.SHEAR',4X,'SHEAR-AZ.'/1X,T123,'[GON]'//) (0944) LCOVAR = .TRUE. (0945) IF(IISO.NE.0) LCOVAR = (IISO.LT.0) (0946) 19 DO 20 I=1,NP1 (0947) (0948) C PREDICTED VALUES AND THEIR COVARIANCE MATRICES (0949) (0950) CALL PREDIC(DA,CHI,PSI,CDA,CCHIPS,Z(I),CPXX,MDIM,MCONF, (0951) 1 MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1, (0952) 2 LCOVAR) (0953) (0954) IF(.NOT.LPREAN)CALL TSHEAR(TSHR,SHRAZ,STSHR,SSHRAZ,PSI,CCHIPS) (0955) (0956) IF(ABS(REAL(DA(1,1))).GE.100..OR.ABS(AIMAG(DA(1,1))).GE.100.) (0957) 1 DA(1,1)=(0.,0.) (0958) WRITE(7,7001)(NAME(I,J),J=1,4),(P(I,J),J=1,2),DA,CHI,PSI, (0959) 1 CCHIPS (0960) 7001 FORMAT(4A2,2F10.2,2F8.4,4F9.4/8E10.3/8E10.3) (0961) (0962) DA(1,1) = DA(1,1)*1.E3 (0963) CALL DMTSCL(CDA,CDA,1.D6,2,2,2,2) (0964) CALL SIGMAS(SIGDA,SIGCHI,SIGPSI,CDA,CCHIPS) (0965) WRITE(6,6012)(NAME(I,J),J=1,4),(P(I,J),J=1,2),DA,CHI,PSI,TSHR, (0966) 1 SHRAZ (0967) 6012 FORMAT(1H ,4A2,10F12.4) (0968) IF(ISPACE(1).GT.0)WRITE(6,6103)SIGDA,SIGCHI,SIGPSI,STSHR,SSHRAZ (0969) 6103 FORMAT(1H ,32X,8F12.4//) (0970) (0971) C WRITE SCALAR VALUES ON FILE "P_ISOLIN2" FOR PLOTTING ISO-LINES (0972) GOTO(911,912,913,914),IABS(IISO) (0973) GOTO 921 (0974) 911 IF(IISO.GT.0)SCALAR = REAL(CHI) (0975) IF(IISO.LT.0)SCALAR = SIGCHI(1) (0976) GOTO 920 (0977) 912 IF(IISO.GT.0)SCALAR = AIMAG(CHI) (0978) IF(IISO.LT.0)SCALAR = SIGCHI(2) (0979) GOTO 920 (0980) 913 IF(IISO.GT.0)SCALAR = TSHR (0981) IF(IISO.LT.0)SCALAR = STSHR (0982) GOTO 920 (0983) 914 IF(IISO.GT.0)SCALAR = DROSET(AZSHR,PSI) (0984) IF(IISO.LT.0)SCALAR = CROSET(AZSHR,CCHIPS) (0985) GOTO 920 (0986) 920 CONTINUE (0987) IF(SCALAR.LT.SLOW.OR.SCALAR.GT.SUP) SCALAR = AMASQ (0988) WRITE(11,8002) P(I,1),P(I,2),SCALAR (0989) 8002 FORMAT(3E20.13) (0990) 921 CONTINUE (0991) (0992) 20 CONTINUE (0993) SEND = 999. (0994) IF(IISO.NE.0)WRITE(11,8002)P(1,1),P(1,2),SEND (0995) 104 CONTINUE (0996) (0997) C INTERPOLATION OF GRID POINTS (0998) 67 IF(IPREDO.EQ.0.OR.NGRID.EQ.0.OR.ISPACE(2).EQ.0) GOTO 68 (0999) GRIDW = 2./NGRID (1000) GRIDL = GRIDW * SCALP (1001) PR(1) = -SCALP + P0(1) (1002) PR(2) = SCALP + P0(2) (1003) WRITE(6,6021) PR,GRIDL (1004) 6021 FORMAT(1H //' INTERPOLATED GRID POINTS:'// (1005) 1 ' COORD. OF UPPER LEFT CORNER OF GRID: X = ',F10.2,' Y = ',F10.2/ (1006) 2 ' GRID INTERVAL [M] = ',F10.2//) (1007) WRITE(6,6010) (1008) (1009) Y = 1. (1010) LCOVAR = (IISO.LT.0) (1011) 21 DO 22 I=1,NGRID (1012) X = -1. (1013) PR(2) = Y * SCALP + P0(2) (1014) 23 DO 24 J=1,NGRID (1015) PR(1) = X * SCALP + P0(1) (1016) ZG = CMPLX(X,Y) (1017) (1018) C PREDICTE VALUES AND THEIR COVARIANCE MATRICES (1019) (1020) CALL PREDIC(DA,CHI,PSI,CDA,CCHIPS,ZG,CPXX,MDIM,MCONF, (1021) 1 MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1, (1022) 2 LCOVAR) (1023) (1024) IF(.NOT.LPREAN)CALL TSHEAR(TSHR,SHRAZ,STSHR,SSHRAZ,PSI, (1025) 1 CCHIPS) (1026) (1027) IF(ABS(REAL(DA(1,1))).GE.100..OR.ABS(AIMAG(DA(1,1))) (1028) 1 .GE.100.) DA(1,1)=(0.,0.) (1029) IF(IISO.EQ.0) WRITE(7,7002)I,J,PR,DA,CHI,PSI,CCHIPS (1030) 7002 FORMAT(2X,I2,1X,I2,1X,2F10.2,2F8.4,4F9.4/8E10.3/8E10.3) (1031) (1032) DA(1,1) = DA(1,1)*1.E3 (1033) CALL DMTSCL(CDA,CDA,1.D6,2,2,2,2) (1034) CALL SIGMAS(SIGDA,SIGCHI,SIGPSI,CDA,CCHIPS) (1035) IF(ISPACE(2).GT.0.AND.IISO.EQ.0) (1036) 1 WRITE(6,6022) I,J,PR,DA,CHI,PSI,TSHR,SHRAZ (1037) 6022 FORMAT(1H ,I2,1X,I2,3X,10F12.4) (1038) IF(ISPACE(2).GT.0.AND.IISO.EQ.0) (1039) 1 WRITE(6,6103) SIGDA,SIGCHI,SIGPSI,STSHR, (1040) 2 SSHRAZ (1041) (1042) C WRITE SCALAR VALUES ON FILE "P_ISOLIN1" FOR PLOTTING ISO-LINES (1043) GOTO(811,812,813,814),IABS(IISO) (1044) GOTO 821 (1045) 811 IF(IISO.GT.0)SCALAR = REAL(CHI) (1046) IF(IISO.LT.0)SCALAR = SIGCHI(1) (1047) GOTO 820 (1048) 812 IF(IISO.GT.0)SCALAR = AIMAG(CHI) (1049) IF(IISO.LT.0)SCALAR = SIGCHI(2) (1050) GOTO 820 (1051) 813 IF(IISO.GT.0)SCALAR = TSHR (1052) IF(IISO.LT.0)SCALAR = STSHR (1053) GOTO 820 (1054) 814 IF(IISO.GT.0)SCALAR = DROSET(AZSHR,PSI) (1055) IF(IISO.LT.0)SCALAR = CROSET(AZSHR,CCHIPS) (1056) 820 CONTINUE (1057) IF(SCALAR.LT.SLOW.OR.SCALAR.GT.SUP) SCALAR = AMASQ (1058) WRITE(10,8001) SCALAR (1059) 8001 FORMAT(8E10.3) (1060) 821 CONTINUE (1061) (1062) X = X + GRIDW (1063) 24 CONTINUE (1064) Y = Y - GRIDW (1065) 22 CONTINUE (1066) 68 CONTINUE (1067) 111 IF(ISPACE(3).EQ.3) GOTO 112 (1068) WRITE(7,7004) (1069) IF(IISO.NE.0) WRITE(10,7004) (1070) IF(IISO.NE.0) WRITE(11,7004) (1071) 7004 FORMAT('$$') (1072) DTIME = DTIME + TIMINT (1073) 42 CONTINUE (1074) GOTO 9999 (1075) (1076) C PREDICTION OF INDIVIDUAL POINTS (1077) 112 CONTINUE (1078) WRITE(1,6098) (1079) WRITE(6,6098) (1080) 6098 FORMAT(1H /' PREDICTION OF STRAIN FIELD AT INDIVIDUAL POINTS:'//) (1081) WRITE(1,1021) (1082) 1021 FORMAT(4X,'U',7X,'V',4X,'SIGMA',4X,'OMEGA',4X,'TAU',3X,'YPSILON', (1083) 1 3X,'T.SHEAR',3X,'SHEAR-AZ.'//) (1084) IF(IABS(IPREDO).EQ.1) WRITE(6,6051) (1085) IF(IABS(IPREDO).EQ.2) WRITE(6,6010) (1086) LCOVAR = .FALSE. (1087) 89 DO 90 I=1,20 (1088) CALL TNOUA(' POINT: ID# [END: ID#=0] :',26) (1089) READ(1,1088) (NAME(1,J),J=1,4) (1090) IF(NAME(1,1).EQ.'0 ') GOTO 9999 (1091) CALL TNOUA(' X[M] Y[M] :',12) (1092) 1088 FORMAT(4A2) (1093) READ(1,*) X,Y (1094) ZG = CMPLX(SNGL((X-P0(1))/SCALP),SNGL((Y- (1095) 1 P0(2))/SCALP)) (1096) CALL PREDIC(DA,CHI,PSI,CDA,CCHIPS,ZG,CPXX,MDIM,MCONF, (1097) 1 MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1, (1098) 2 LCOVAR) (1099) (1100) IF(.NOT.LPREAN)CALL TSHEAR(TSHR,SHRAZ,STSHR,SSHRAZ,PSI, (1101) 1 CCHIPS) (1102) (1103) DA(1,1) = DA(1,1)*1.E3 (1104) CALL DMTSCL(CDA,CDA,1.D6,2,2,2,2) (1105) (1106) CALL SIGMAS(SIGDA,SIGCHI,SIGPSI,CDA,CCHIPS) (1107) (1108) WRITE(6,6022) (NAME(1,J),J=1,4),X,Y,DA,CHI,PSI,TSHR,SHRAZ (1109) WRITE(1,1022) DA,CHI,PSI,TSHR,SHRAZ (1110) 1022 FORMAT(8F10.4) (1111) 90 CONTINUE (1112) GOTO 9999 (1113) (1114) C ERROR MESSAGES (1115) 901 CONTINUE (1116) WRITE(1,1901) (1117) 1901 FORMAT(' ***FILE NOT OPEN***'/) (1118) GOTO 9999 (1119) 902 CONTINUE (1120) WRITE(1,1902) (1121) 1902 FORMAT(' ***NUMBER OF BLOCK PERIMETER VERTICES EXCEEDED***'/) (1122) (1123) C WRITE TIME OF TERMINATION (1124) 9999 CONTINUE (1125) CALL TIMREG(IDAT,ITIME1,IUSER) (1126) WRITE(6,6981) ITIME1 (1127) 6981 FORMAT(1H ,'END OF COMPUTATION: ',I2,'.',I2) (1128) (1129) C CLOSE FILES (1130) CALL CLOS$A(1) (1131) CALL TRNC$A(2) (1132) CALL CLOS$A(2) (1133) CALL TRNC$A(3) (1134) CALL CLOS$A(3) (1135) IF(.NOT.LPREDI)CALL TRNC$A(4) (1136) IF(.NOT.LPREDI)CALL CLOS$A(4) (1137) IF(.NOT.LPREDI)CALL TRNC$A(5) (1138) CALL CLOS$A(5) (1139) CALL TRNC$A(6) (1140) CALL CLOS$A(6) (1141) CALL TRNC$A(7) (1142) CALL CLOS$A(7) (1143) IF(.NOT.LPREDI) CALL DELE$A('T$STRAIN',8) (1144) CALL EXIT (1145) (1146) C NEW PAGE COMMAND (1147) 6900 FORMAT(' PROGRAM CRUSTRAIN (VERS.3.82)') (1148) 6901 FORMAT(' '/) (1149) END PROGRAM SIZE: PROCEDURE - 026532 LINKAGE - 010436 STACK - 000070 A D /COM10/ 000000 0073S 0141S 0691A 0694A 0699 0707A 0710A A$ABS I PARAMETER 0148S A$BACK I PARAMETER 0148S A$BIN I PARAMETER 0148S A$BINZ I PARAMETER 0148S A$CNTR I PARAMETER 0148S A$CUFD I PARAMETER 0148S A$DAMF I PARAMETER 0148S A$DEC I PARAMETER 0148S A$DECU I PARAMETER 0148S A$DECZ I PARAMETER 0148S A$DLAY I PARAMETER 0148S A$DNO I PARAMETER 0148S A$DYES I PARAMETER 0148S A$FLOW I PARAMETER 0148S A$FUPP I PARAMETER 0148S A$GETU I PARAMETER 0148S A$HEX I PARAMETER 0148S A$HEXZ I PARAMETER 0148S A$LEFT I PARAMETER 0148S A$NAME I PARAMETER 0148S A$NBIN I PARAMETER 0148S A$NDEC I PARAMETER 0148S A$NDEF I PARAMETER 0148S A$NEXT I PARAMETER 0148S A$NHEX I PARAMETER 0148S A$NKWL I PARAMETER 0148S A$NOCT I PARAMETER 0148S A$NONE I PARAMETER 0148S A$NOVF I PARAMETER 0148S A$NSEG I PARAMETER 0148S A$NUFD I PARAMETER 0148S A$NUMB I PARAMETER 0148S A$NVER I PARAMETER 0148S A$OCT I PARAMETER 0148S A$OCTZ I PARAMETER 0148S A$OPTL I PARAMETER 0148S A$OVAP I PARAMETER 0148S A$RAWI I PARAMETER 0148S A$RCMD I PARAMETER 0148S A$RDWR I PARAMETER 0148S 0263 A$READ I PARAMETER 0148S 0207 0225 A$REL I PARAMETER 0148S A$REQD I PARAMETER 0148S A$RGHT I PARAMETER 0148S A$RSET I PARAMETER 0148S A$SAMF I PARAMETER 0148S 0172 0207 0214 0218 0220 0224 0225 0263 A$TREE I PARAMETER 0148S A$UPLW I PARAMETER 0148S A$VNEW I PARAMETER 0148S A$VOLD I PARAMETER 0148S A$WRIT I PARAMETER 0148S 0172 0214 0218 0220 0224 A2R D /COM10/ 051200 0073S 0141S 0699M 0726A ABS R EXTERNAL 000000 0956 1027 AIMAG R EXTERNAL 000000 0956 0977 1027 1048 ALFAT R LINKAGE 010506 0376M 0377 0380 0381 ALFT D LINKAGE 010510 0073S 0377M 0378 0379A ALIN D LINKAGE 010564 0073S 0527M 0528A 0529A 0530A 0531A ALPH D LINKAGE 010524 0073S 0386M 0387 0389M 0749A ALPHP R LINKAGE 010406 0054S 0231M 0749A 0764 0786 AMASQ R LINKAGE 000576 0150I 0987 1057 APVARF R LINKAGE 010710 0054S 0749A AZSHR R LINKAGE 010534 0054S 0454M 0455 0457M 0983A 0984A 1054A 1055A B D /COM10/ 026400 0073S 0141S 0726A 0728A BE D /EPISOD/ 000000 0073S 0143S 0240M 0365M 0366 0603M 0604M 0776 BLCREF D LINKAGE 001206 0073S 0303M 0308 0332 0333 BLOC R EXTERNAL 000000 0889 BLOCA R /BLOCK/ 000322 0054S 0144S 0150I 0237M 0307M 0308 0310M 0313 0772 BLOCAZ D LINKAGE 001216 0073S 0889A 0910 BMAT R EXTERNAL 000000 0726 CALPOL R EXTERNAL 000000 0666 0671 CASE$A L 000000 0148S CBLOC C 000000 0116S CCBLOC D LINKAGE 001312 0073S CCHIPS D LINKAGE 001332 0073S 0950A 0954A 0958 0964A 0984A 1020A 1024A 1029 1034A 1055A 1096A 1100A 1106A CDA D LINKAGE 001432 0073S 0950A 0963A 0964A 1020A 1033A 1034A 1096A 1104A 1106A CHI C LINKAGE 010734 0116S 0950A 0958 0965 0974A 0977A 1020A 1029 1035 1045A 1048A 1096A 1108 1109 CLOS$A L EXTERNAL 000000 0148S 1130 1132 1134 1136 1138 1140 1142 CMDL$A L 000000 0148S CMPLX C EXTERNAL 000000 0639 1016 1094 CNVA$A L 000000 0148S CNVB$A I 000000 0148S CONJG C EXTERNAL 000000 0670 CPLXPO R EXTERNAL 000000 0632 CPXA C /COM0/ 000000 0116S 0139S 0665M 0668M 0673M 0681 0691A CPXPAR R EXTERNAL 000000 0756 CPXX C LINKAGE 001452 0116S 0242M 0756A 0779 0806 0816 0889A 0950A 1020A 1096A CROSET R EXTERNAL 000000 0984 1055 CRXON D LINKAGE 010530 0073S 0410M 0749A CSP$$A L 000000 0148S CSTR$A L 000000 0148S CSUB$A L 000000 0148S CTIM$A D 000000 0148S CX D /COM2/ 000000 000000 0073S 0140S 0244M 0246A 0781 0828 0847 D0 D LINKAGE 002412 0073S 0241M 0634M 0635M 0658 0778 0889A 0950A 1020A 1096A DA C LINKAGE 002422 0116S 0950A 0956M 0958 0962M 0965 1020A 1027M 1029 1032M 1035 1096A 1103M 1108 1109 DABS D EXTERNAL 000000 0914 DATAN D EXTERNAL 000000 0169 DATAN2 D EXTERNAL 000000 0527 DATE$A D 000000 0148S DATN$X I EXTERNAL 000000 0176 DCNORM R EXTERNAL 000000 0146S 0379A DCOS D EXTERNAL 000000 0529 0531 DCOS$X D EXTERNAL 000000 0532 DELCYC R EXTERNAL 000000 0746 DELE$A L EXTERNAL 000000 0148S 1143 DELROW R EXTERNAL 000000 0707 DMREAL R EXTERNAL 000000 0691 DMTOUT R EXTERNAL 000000 0694 0710 0728 0759 DMTSCL R EXTERNAL 000000 0963 1033 1104 DMTSYM R EXTERNAL 000000 0246 DNEWTO D EXTERNAL 000000 0073S 0379 DNORM R EXTERNAL 000000 0146S 0379A DOFY$A D 000000 0148S DROSET R EXTERNAL 000000 0983 1054 DSIN D EXTERNAL 000000 0528 0530 DSIN$X D EXTERNAL 000000 0532 DSQR$X D EXTERNAL 000000 0910 DSQRT D EXTERNAL 000000 0909 DTIM$A D 000000 0148S DTIME D LINKAGE 010664 0073S 0715M 0716 0736 0860M 0863M 0864 0865 0868 1072M DTIMN D LINKAGE 010676 0073S 0736M 0737A 0868M 0889A 0950A 1020A 1096A EDAT$A D 000000 0148S ENCD$A L 000000 0148S EXIT R EXTERNAL 000000 1144 EXST$A L 000000 0148S FACTK R LINKAGE 010514 0054S 0378M 0379M 0380 0381 0749A FAULT D LINKAGE 000600 0073S 0150I 0528M 0529M 0530M 0531M 0913 0917 0919 FDAT$A D 000000 0148S FEDT$A D 000000 0148S FILL$A I 000000 0148S FSUB$A L 000000 0148S FTIM$A D 000000 0148S GCHR$A I 000000 0148S GEND$A L 000000 0148S GRIDL R LINKAGE 011012 0054S 1000M 1003 GRIDW R LINKAGE 011010 0054S 0999M 1000 1062 1064 GRIDWM R LINKAGE 010600 0595M 0596 I I LINKAGE 000432 0230M 0235M 0236M 0237M 0238M 0239M 0240M 0242M 0243M 0244 0298M 0299 0300 0307 0308 0310 0313 0320 0327 0363M 0365 0366 0494M 0545M 0547 0548 0551 0574M 0575 0578 0579 0582 0590 0602M 0603 0604 0638M 0639 0648M 0651 0654 0664M 0665 0666 0668 0670 0673 0679M 0681 0697M 0699 0705M 0706 0762M 0768M 0770M 0772M 0773M 0775M 0776M 0779M 0780M 0781 0803M 0804 0806 0814M 0815 0816 0823M 0825 0835 0841M 0843 0854 0900M 0946M 0950 0958 0965 0988 1011M 1029 1035 1087M IABS I EXTERNAL 000000 0452 0500 0501 0502 0503 0876 0882 0930 0937 0972 1043 1084 1085 IBLOC I LINKAGE 000510 0518M 0519 0521 0532 0650M 0651 0894M 0895 0910 0917 IBLOC1 I LINKAGE 000511 0519M 0520 0895M 0896 0897 0898 0902 IDAT I LINKAGE 002426 0029S 0185A 0186 1125A IDIM I LINKAGE 000435 0029S 0231M 0749A 0764 0786 IERR I LINKAGE 000540 0746A IFILI I LINKAGE 002432 0029S 0207A 0209 II I LINKAGE 000545 0827M 0846M IISO I LINKAGE 000477 0446M 0447 0449 0451 0452 0945 0972 0974 0975 0977 0978 0980 0981 0983 0984 0994 1010 1029 1035 1038 1043 1045 1046 1048 1049 1051 1052 1054 1055 1069 1070 IJ I LINKAGE 000506 0516M 0528 0529 0530 0531 0535M 0892M 0903 0904 0906 0907 0909 0910 0913 0917 0919 0923M INET I LINKAGE 000521 0611M 0615A 0617 0618 0620 0622 0623 0629 0715 0716 0726A 0737A INPAR I LINKAGE 000516 0608M 0726A IOPTAP I LINKAGE 000422 0199M 0200 0202 0203 IPAR I LINKAGE 000463 0281M 0282 0283 0284 IPREDO I LINKAGE 000502 0477M 0540 0554 0592 0789 0859 0863 0876 0882 0889A 0930 0937 0950A 0998 1020A 1084 1085 1096A ISING I LINKAGE 000541 0029S 0749A ISNU I LINKAGE 000520 0610M 0618M 0749A ISOBS I LINKAGE 000517 0609M 0617M 0749A ISPACE I LINKAGE 001160 0029S 0150I 0500M 0501M 0502M 0503M 0506 0511 0898 0900 0917 0919 0929 0968 0998 1035 1038 1067 ISTAT I LINKAGE 002452 0029S 0425M 0426 0578 0749A ITIM I LINKAGE 002454 0029S ITIME I LINKAGE 000546 0861M 0863 0865 0866 ITIME1 I LINKAGE 002474 0029S 0185A 0186 1125A 1126 ITOPT I LINKAGE 000472 0029S 0404M 0405 0408 0749A IUSER I LINKAGE 002476 0029S 0185A 0186 1125A J I LINKAGE 000454 0235M 0236M 0238M 0239M 0244M 0314M 0320 0330 0331 0365M 0366M 0496M 0497 0498 0500 0501 0502 0503 0575M 0579M 0654M 0667M 0668 0672M 0673 0681M 0698M 0699 0706M 0707 0768M 0770M 0773M 0775M 0781M 0806M 0816M 0825M 0826 0835M 0844M 0845 0854M 0898M 0900M 0905M 0906 0907 0910M 0917M 0919M 0958M 0965M 1014M 1029 1035 1089M 1108M J1 I LINKAGE 000547 0896M 0900 J2 I LINKAGE 000550 0897M 0898 0900 JANEIN L 000000 0129S JBLOC I LINKAGE 000512 0520M 0521 0532 0902M 0910 0917 JJ I LINKAGE 000464 0297M 0299 0318 0319 0324M 0327 0329M 0330 0331 0332 0333 0334M 0335 0337 0824M 0828 0829 0830 0831M 0842M 0847 0848 0849 0850M JJBLOC I LINKAGE 000451 0233M 0236 0239 0337M 0638 0765 0770 0775 JR I LINKAGE 000544 0826M 0828 0832M 0845M 0847 0851M JSTR$A L 000000 0148S LBLOCA L 000000 0129S LCOVAR L LINKAGE 000552 0129S 0944M 0945M 0950A 1010M 1020A 1086M 1096A LOPEN L LINKAGE 000415 0129S 0172M 0173 0207M 0208 0214M 0215 0218M 0219 0220M 0221 0224M 0225M 0226 0263M 0264 LPLTG L LINKAGE 000500 0129S 0449M LPREAN L LINKAGE 000423 0129S 0202M 0372 0749A 0954 1024 1100 LPREDI L LINKAGE 000424 0129S 0203M 0206 0224 0225 0229 0250 0262 0558 1135 1136 1137 1143 LPRINT L LINKAGE 000400 0129S 0150I 0615A 0677 0681 0692 0694 0710 0728 0737A 0746A 0749A 0757 0759 LSQUA I EXTERNAL 000000 0749 LSTR$A L 000000 0148S LSUB$A L 000000 0148S MANTIC I LINKAGE 000441 0029S 0233M 0271M 0272 0343 0671A 0672 0765 0810 0814 0838 0841 0889A 0950A 1020A 1096A MBLOC I LINKAGE 000445 0233M 0235 0236 0237 0271M 0272 0291 0298 0342 0517 0520 0649 0650 0654 0765 0768 0770 0772 0873 0889A 0893 0902 MBLOC1 I LINKAGE 000507 0517M 0518 0893M 0894 MCHR$A I 000000 0148S MCONF I LINKAGE 000440 0029S 0233M 0271M 0272 0313 0341 0342M 0343 0666A 0667 0673 0765 0803 0815 0823 0843 0889A 0950A 1020A 1096A MCONF1 I LINKAGE 000446 0029S 0233M 0341M 0666A 0765 0804 0889A 0950A 1020A 1096A MCONFI I LINKAGE 000543 0815M 0816 0843M 0844 MDIM I LINKAGE 000401 0150I 0233M 0666A 0671A 0765 0889A 0950A 1020A 1096A MSTR$A I 000000 0148S MSUB$A I 000000 0148S MT I LINKAGE 000444 0233M 0353M 0354 0733 0734 0737A 0749A 0755 0756A 0765 0835 0854 0889A 0950A 1020A 1096A N12DIM I LINKAGE 000412 0150I NAME I /COM14/ 000000 0029S 0142S 0238M 0615A 0654 0773 0958 0965 1089M 1090 1108 NAMFIX I LINKAGE 002502 0029S NCC I LINKAGE 000442 0233M 0242 0734M 0765 0779 0806 0816 0825 0844 NCCDIM I LINKAGE 000410 0150I NDE I LINKAGE 000531 0688M 0724 0726A 0737A 0746A NDE2 I LINKAGE 000536 0724M 0726A 0728A NDE2DI I LINKAGE 000537 0725M 0726A 0728A NDEDIM I LINKAGE 000402 0150I 0725 0726A NELIM I LINKAGE 001164 0029S 0150I 0283M 0313M 0703 0707A 0756A NEPIS I LINKAGE 000452 0233M 0352M 0353 0354 0359 0363 0602 0765 NEPOC D LINKAGE 002506 0073S 0575M 0579 NFIX I LINKAGE 000523 0615A 0632A NGRID I LINKAGE 000505 0508M 0554 0595 0998 0999 1011 1014 NH I LINKAGE 000524 0615A 0622 0623 NLEN$A I 000000 0148S NN I LINKAGE 000515 0573M 0582M 0586 0688 0726A 0749A NNET I LINKAGE 000450 0233M 0240 0565M 0567 0574 0611 0749A 0765 0776 NNOR I LINKAGE 000526 0615A NONET I LINKAGE 003326 0029S 0615A 0617 0622 0623 0749A NORMAL I EXTERNAL 000000 0737 NP I LINKAGE 000522 0615A 0622 0623 0648 0664 0679 0685 0691A 0749A NP1 I LINKAGE 000447 0233M 0238 0239 0615A 0632A 0765 0773 0775 0946 NP2 I LINKAGE 000527 0685M 0686 0688 0694A 0697 0707A 0710A 0726A 0728A 0737A NP2DIM I LINKAGE 000404 0150I 0691A 0694A 0707A 0710A 0726A 0728A NP2H I LINKAGE 000530 0686M 0724 0726A 0737A NP2HDI I LINKAGE 000405 0150I 0725 0726A NPDIM I LINKAGE 000403 0150I 0691A NPER I /BLOCK/ 000310 0029S 0144S 0235M 0299M 0320 0327M 0651A 0768 0889A 0896 0897 NPROJ1 I LINKAGE 003410 0029S 0230M 0250M 0254 0257 0258 0762 NPROJ2 I LINKAGE 003434 0029S 0230M 0252M 0254 0257 0258 0762 NRC I LINKAGE 000443 0233M 0733M 0737A 0746A 0749A 0765 NRC2 I LINKAGE 000453 0233M 0243 0244 0246A 0755M 0759A 0765 0780 0781 NRCDIM I LINKAGE 000411 0150I 0246A 0759A NTIMIN I LINKAGE 000514 0542M 0551M 0554 0592 0593 0789 0790 0861 NTIT I LINKAGE 003460 0029S 0615A 0620 NTPOLY I /EPISOD/ 000120 0143S 0233M 0352M 0353 0354 0765 NU I LINKAGE 000436 0233M 0343M 0681 0687 0691A 0734 0749A 0754 0756A 0765 0806 0816 0825 0844 0889A 0950A 1020A 1096A NU2 I LINKAGE 000437 0233M 0687M 0694A 0707A 0710A 0733 0737A 0749A 0756A 0765 NU22 I LINKAGE 000542 0754M 0755 NU2DIM I LINKAGE 000407 0150I 0691A 0694A 0707A 0710A NUDIM I LINKAGE 000406 0150I 0691A NUH I LINKAGE 000525 0615A 0622 0623 0686 0688 0749A NUIPAR I LINKAGE 003530 0029S 0575M 0579 0582 0726A 0749A NUNET I LINKAGE 003674 0029S 0615A 0618 0622 0623 0749A OPEN$A L EXTERNAL 000000 0148S 0172 0214 0218 0220 0224 0225 0263 OPNP$A L EXTERNAL 000000 0148S 0207 OPNV$A L 000000 0148S OPVP$A L 000000 0148S P D LINKAGE 003756 0073S 0241M 0615A 0632A 0778 0958 0965 0988 0994 P0 D LINKAGE 004336 0073S 0241M 0615A 0632A 0639 0658 0778 1001 1002 1013 1015 1094 PBLOC R LINKAGE 004346 0054S 0651M 0654 PER D LINKAGE 004360 0073S 0236M 0318M 0319M 0320 0330M 0331M 0332M 0333M 0639 0770 0898 0900 PHI C LINKAGE 005200 0116S 0666A 0668 0671A 0673 PINPOL R EXTERNAL 000000 0651 POSN$A L 000000 0148S PR D LINKAGE 005260 0073S 1001M 1002M 1003 1013M 1015M 1029 1035 PREDIC R EXTERNAL 000000 0950 1020 1096 PSI C LINKAGE 010740 0116S 0950A 0954A 0958 0965 0983A 1020A 1024A 1029 1035 1054A 1096A 1100A 1108 1109 RAND$A D 000000 0148S RDNET R EXTERNAL 000000 0615 REAL R EXTERNAL 000000 0956 0974 1027 1045 RHOGON R LINKAGE 010362 0054S 0169M 0310 0457 RNAM$A L 000000 0148S RNDI$A D 000000 0148S RNUM$A L 000000 0148S RPOS$A L 000000 0148S RSTR$A L 000000 0148S RSUB$A L 000000 0148S RWND$A L 000000 0148S SCALAR R LINKAGE 011000 0974M 0975M 0977M 0978M 0980M 0981M 0983M 0984M 0987M 0988 1045M 1046M 1048M 1049M 1051M 1052M 1054M 1055M 1057M 1058 SCALD D LINKAGE 001202 0073S 0150I 0241M 0633 0658 0737A 0749A 0778 0889A 0950A 1020A 1096A SCALD2 D 000000 0073S SCALDI D 000000 0073S SCALP D LINKAGE 010440 0073S 0241M 0595 0632A 0633 0639 0658 0778 1000 1001 1002 1013 1015 1094 SCALR D LINKAGE 010444 0073S 0241M 0633M 0658 0778 0889A 0950A 1020A 1096A SEND R LINKAGE 011006 0993M 0994 SHRAZ R LINKAGE 010750 0954A 0965 1024A 1035 1100A 1108 1109 SIG R LINKAGE 005270 0054S 0828M 0829M 0830M 0835 0847M 0848M 0849M 0854 SIGCHI R LINKAGE 005340 0054S 0964A 0968 0975 0978 1034A 1038 1046 1049 1106A SIGDA R LINKAGE 005344 0054S 0964A 0968 1034A 1038 1106A SIGMAS R EXTERNAL 000000 0964 1034 1106 SIGPSI R LINKAGE 005350 0054S 0964A 0968 1034A 1038 1106A SLOW R LINKAGE 010536 0461M 0462 0987 1057 SNGL R EXTERNAL 000000 0639 1094 SQRT R EXTERNAL 000000 0830 0849 SQRT$X J EXTERNAL 000000 0833 0852 SSHRAZ D LINKAGE 010756 0073S 0954A 0968 1024A 1038 1100A SSTR$A L 000000 0148S SSUB$A L 000000 0148S STSHR D LINKAGE 010752 0073S 0954A 0968 0981 1024A 1038 1052 1100A SUP R LINKAGE 010540 0461M 0462 0987 1057 SXPER D LINKAGE 010460 0073S 0311M 0322M 0330 0525M 0528 0530 SXYBLC D LINKAGE 005354 0073S 0889A 0907M 0910 SYPER D LINKAGE 010464 0073S 0312M 0323M 0331 0526M 0529 0531 TEMP$A L 000000 0148S TIME R LINKAGE 005544 0054S 0240M 0575M 0579 0590 0715 0716 0749A 0776 TIME$A D 000000 0148S TIME0 R LINKAGE 010434 0054S 0240M 0480M 0481 0603 0604 0715 0749A 0776 0863 0864 TIMINT R LINKAGE 010576 0054S 0591M 0593M 0596 0790M 1072 TIMREG R EXTERNAL 000000 0185 1125 TIMSPA R LINKAGE 010432 0054S 0240M 0590M 0593 0596 0603 0604 0736 0749A 0776 0790 0860 0868 0889A 0950A 1020A 1096A TNOUA R EXTERNAL 000000 0198 0251 0270 0302 0306 0350 0351 0364 0375 0385 0403 0409 0417 0424 0445 0453 0460 0476 0479 0495 0507 0541 0546 1088 1091 TPRE D LINKAGE 010716 0073S 0864M 0865 0866 TPRED D LINKAGE 005710 0073S 0547M 0548 0863 TREE$A L 000000 0148S TRNC$A L EXTERNAL 000000 0148S 1131 1133 1135 1137 1139 1141 TSCN$A L 000000 0148S TSHEAR R EXTERNAL 000000 0954 1024 1100 TSHR R LINKAGE 010746 0954A 0965 0980 1024A 1035 1051 1100A 1108 1109 TYPE$A L 000000 0148S UNIT$A L 000000 0148S VARF D /COM14/ 000170 0073S 0142S 0575M 0578M 0579 0737A X R LINKAGE 011016 1012M 1015 1016A 1062M 1093M 1094 1108 X1 D LINKAGE 010542 0073S 0523M 0524 0525 0527 0532 0903M 0914A 0915 0917 X2 D LINKAGE 010552 0073S 0523M 0525 0527 0532 0909M 0910 0915M 0919 XICHI D LINKAGE 010412 0073S 0231M 0749A 0764 0786 XPER D LINKAGE 010470 0073S 0315M 0316 0318 0320 0322 XR D LINKAGE 006100 0073S 0749A 0756A 0759A XYBLOC D LINKAGE 010000 0073S 0889A 0903 0904 0906M 0909 0910 Y R LINKAGE 011014 1009M 1013 1016A 1064M 1093M 1094 1108 Y1 D LINKAGE 010546 0073S 0523M 0524 0526 0527 0532 0904M 0914A 0916 0917 Y2 D LINKAGE 010556 0073S 0523M 0526 0527 0532 0916M 0919 YPER D LINKAGE 010474 0073S 0315M 0316 0319 0320 0323 YSNO$A L 000000 0148S Z C LINKAGE 010170 0116S 0239M 0632A 0651A 0654 0666A 0670A 0775 0950A ZBLC C /BLOCK/ 000000 0116S 0144S 0239M 0639M 0651A 0775 0889A ZC C LINKAGE 010642 0116S 0670M 0671A ZG C LINKAGE 011020 0116S 1016M 1020A 1094M 1096A $1 014304 0679D $10 014237 0672 0674D $1001 002107 0250 0252 0253D $1003 014306 0680D $1004 007463 0470 0471D 0553 $1005 003303 0304 0305D $101 011666 0574D $1014 020120 0866 0867D $102 012213 0574 0583D $1021 025220 1081 1082D $1022 026061 1109 1110D $103 021742 0929D $104 023612 0929 0995D $105 007101 0451D $106 007414 0451 0465D $107 010265 0494D $108 010414 0494 0504D $1088 025441 1089 1092D $109 007104 0452D $11 013472 0648D $110 007247 0452 0458D $111 025045 1067D $112 025131 1067 1077D $113 010321 0497D $114 010422 0497 0505D $115 010422 0506D $116 010470 0506 0509D $117 010470 0511D $118 011154 0511 0538D $12 013666 0648 0656D $121 010600 0518D $122 011146 0518 0537D $123 010604 0520D $124 011140 0520 0536D $125 021435 0913D $126 021724 0913 0914 0922D $15 017024 0803D $16 017146 0803 0808D $1691 012600 0614D $1692 014761 0723D $1693 015060 0731D $17 017220 0814D $18 017266 0814 0817D $181 001742 0243D $182 002011 0243 0245D $185 021161 0902D $186 021726 0902 0924D $187 010702 0524D $1877 014563 0703 0704D $188 011136 0524 0534D $19 022516 0946D $1901 026104 1116 1117D $1902 026133 1120 1121D $2 014373 0679 0683D $20 023543 0946 0992D $2002 014266 0677 0678D $2003 014355 0681 0682D $201 004611 0372D $2015 014452 0692 0693D $202 006377 0372 0430D $21 024033 1011D $22 025037 1011 1065D $23 024052 1014D $24 025023 1014 1063D $25 014514 0697D $26 014537 0697 0701D $27 014516 0698D $28 014531 0698 0700D $281 021201 0905D $282 021224 0905 0908D $286 017552 0838D $287 017772 0838 0856D $288 017154 0810D $289 017274 0810 0818D $31 013226 0629D $32 014653 0629 0712D $33 017360 0823D $34 017544 0823 0836D $35 017575 0841D $36 017764 0841 0855D $37 003164 0298D $38 003753 0298 0336D $39 003525 0314D $40 003666 0314 0325D $41 020004 0861D $42 025123 0861 1073D $43 002741 0282D $44 003011 0282 0287D $45 003010 0286D $46 002655 0278D 0286 $47 011154 0540D $48 011232 0540 0544D $49 011231 0543D $5 014052 0664D $50 011330 0543 0552D $51 011232 0545D $5101 011527 0565 0566D $5102 012005 0575 0577D $52 011317 0545 0549D $53 011307 0548D $54 011325 0548 0550D $55 020235 0873D $56 021742 0873 0926D $58 012303 0592D $59 012326 0592 0594D $6 014245 0664 0675D $6000 000071 0178 0179 0180D $6001 014716 0716 0717D $6002 013362 0644 0645D $6003 013644 0654 0655D $6004 013742 0658 0659D $6005 012237 0586 0587D $6006 016626 0795 0796D $6007 012377 0596 0597D $6008 016703 0798 0799D 0821 $6009 017167 0811 0812D 0839 $6010 021764 0930 0931D 1007 1085 $6011 017127 0806 0807D 0816 0835 0854 $6012 023224 0965 0967D $6013 002543 0272 0273D $6014 020157 0865 0869D $6015 004046 0348 0349D $6016 004224 0354 0355D $6017 011372 0554 0555D $6018 004624 0373 0374D $6019 005024 0380 0381 0382D $6020 015201 0743 0744D $6021 023710 1003 1004D $6022 024531 1035 1037D 1108 $6023 000601 0209 0210D $6024 016732 0800 0801D 0813 0822 0840 $6025 002322 0267 0268D $6026 004364 0360 0361 0362D $6027 004546 0366 0367D $6028 004001 0346 0347D $6029 006407 0432 0433D $6030 007424 0468 0469D $6031 002137 0254 0255D $6032 011463 0563 0564D $6041 013061 0622 0623 0624D $6042 012701 0620 0621D $6043 017043 0804 0805D $6050 002765 0284 0285D $6051 022244 0937 0938D 1084 $6057 002665 0277 0279 0280D $6058 015402 0757 0758D $6061 000333 0191 0192 0193D $6062 000511 0200 0201D $6071 003034 0292 0293 0294D $6072 003210 0300 0301D $6073 003577 0316 0317D $6074 003455 0308 0309D $6076 020316 0876 0877D $6077 020517 0882 0883D $6081 005211 0387 0388D $6082 005266 0392 0393 0394D $6083 005720 0405 0406D $6085 010342 0498 0499D $6086 010031 0485 0486 0487D $6087 006362 0426 0427D $6088 006026 0414 0416D $6089 006112 0415 0418 0419D $6090 007205 0455 0456D $6091 007354 0462 0463D $6092 010514 0512 0513 0514D $6093 010632 0521 0522D $6094 011116 0532 0533D $6096 020250 0874 0875D $6097 021404 0910 0912D $6098 025151 1078 1079 1080D $61 017364 0825D $6103 023310 0968 0969D 1038 $6109 007765 0481 0482D $6159 017304 0819 0820D $62 017455 0825 0834D $6201 011550 0567 0568D $6202 012156 0579 0581D $6203 011607 0569 0570D $6204 006455 0434 0435 0436D $6206 007061 0447 0448D $63 017604 0844D $64 017675 0844 0853D $645 005736 0408D $646 006006 0408 0411D $65 017371 0827D $66 017447 0827 0833D $67 023612 0998D $68 025045 0998 1066D $69 017611 0846D $6900 026352 0176 1147D $6901 026375 0177 0742 0794 0862 1148D $6981 026216 1126 1127D $6991 000242 0186 0187D $7 014114 0667D $70 017667 0846 0852D $7001 023005 0958 0960D $7002 024326 1029 1030D $7003 002263 0257 0258 0259D $7004 025110 1068 1069 1070 1071D $7005 021142 0900 0901D $7006 021046 0898 0899D $7007 021652 0917 0920D $7008 021702 0919 0921D $701 002272 0262D $7011 016555 0786 0787D $702 006377 0262 0431D $703 000753 0229D $704 002027 0229 0247D $706 011450 0558D $707 016523 0558 0784D $708 000531 0206D $709 000620 0206 0211D $71 012576 0611D $72 015153 0611 0740D $73 013477 0650D $74 013540 0650 0652D $75 013474 0649D $758 016563 0789D $759 016606 0789 0791D $76 013546 0649 0653D $77 014566 0705D $78 014620 0705 0708D $8 014145 0667 0669D $8001 025010 1058 1059D $8002 023535 0988 0989D 0994 $801 000534 0207D 0208 $81 016446 0780D $811 024640 1043 1045D $812 024661 1043 1048D $813 024702 1043 1051D $814 024721 1043 1054D $82 016515 0780 0782D $820 024747 1047 1050 1053 1056D $821 025015 1044 1060D $83 003620 0320D $84 003674 0320 0326D $85 020762 0894D $86 021734 0894 0925D $87 013264 0638D $88 013344 0638 0641D $89 025334 1087D $9 014205 0672D $90 026066 1087 1111D $901 026074 0173 0215 0219 0221 0226 0264 1115D $902 026123 0335 1119D $9087 001066 0231 0232D 0764 $9091 015513 0230 0762 0763D $9092 015724 0233 0765 0767D $9093 016170 0238 0773 0774D $9095 016331 0237 0239 0240 0241 0242 0244 0772 0775 0776 0777D 0778 0779 0781 $9096 016000 0235 0768 0769D $9097 016056 0236 0770 0771D $91 004341 0359D $911 023334 0972 0974D $912 023355 0972 0977D $913 023376 0972 0980D $914 023415 0972 0983D $92 004611 0359 0369D $920 023444 0976 0979 0982 0985 0986D $921 023543 0973 0990D $93 004412 0363D $94 004603 0363 0368D $95 003011 0291D $96 003763 0291 0338D $97 012515 0602D $98 012563 0602 0605D $9999 026170 0859 1074 1090 1112 1118 1124D 0000 ERRORS [<.MAIN.>FTN-REV18.2] $$$ SUBROUTINE BMAT(B,A2R,NUIPAR,INET,INPAR,NP2DIM,NP2HDI,NDE,NDEDIM, (0001) SUBROUTINE BMAT(B,A2R,NUIPAR,INET,INPAR,NP2DIM,NP2HDI,NDE,NDEDIM, (0002) 1 NP2,NP2H,NN,NDE2DI,NDE2) (0003) (0004) C GENERATE DESIGN SUBMATRIX "B" (0005) (0006) INTEGER*2 (0007) I INET,INPAR, (0008) N NUIPAR(50,2) (0009) (0010) REAL*8 (0011) A A2R(NP2DIM,2), (0012) B B(NP2DIM,NDE2DI) (0013) (0014) CALL DMTSCL(B,B,0.D0,NP2DIM,NDE2DI,NP2,NDE2) (0015) 3 DO 4 K=1,2 (0016) 11 IF(NUIPAR(INET,K).NE.1) GOTO 12 (0017) 5 DO 6 I=1,NP2 (0018) B(I,INPAR) = A2R(I,K) (0019) 6 CONTINUE (0020) INPAR = INPAR + 1 (0021) 12 CONTINUE (0022) 4 CONTINUE (0023) RETURN (0024) END PROGRAM SIZE: PROCEDURE - 000174 LINKAGE - 000026 STACK - 000122 A2R D ARGUMENT 000045 0001S 0010S 0018 B D ARGUMENT 000042 0001S 0010S 0014A 0018M DMTSCL R EXTERNAL 000000 0014 I I LINKAGE 000401 0017M 0018 INET I ARGUMENT 000053 0001S 0006S 0016 INPAR I ARGUMENT 000056 0001S 0006S 0018 0020M K I LINKAGE 000400 0015M 0016 0018 NDE2 I ARGUMENT 000111 0001S 0014A NDE2DI I ARGUMENT 000106 0001S 0010S 0014A NP2 I ARGUMENT 000075 0001S 0014A 0017 NP2DIM I ARGUMENT 000061 0001S 0010S 0014A NUIPAR I ARGUMENT 000050 0001S 0006S 0016 $11 000023 0016D $12 000150 0016 0021D $3 000021 0015D $4 000150 0015 0022D $5 000052 0017D $6 000136 0017 0019D 0000 ERRORS [FTN-REV18.2] (0025) (0026) SUBROUTINE NORMAL(INET,NP2,NP2H,NU2,NDE,LPRINT,SCALD,DTIME,VARF, (0027) 1 MT,NRC) (0028) (0029) C GENERATES NORMAL EQUATIONS FOR EACH EPOCH AND ADDS THEM (0030) (0031) INTEGER*2 (0032) N NP2,NP2H,NU2,NDE,NDE1,NDE2,NRC,MT (0033) (0034) REAL*8 (0035) A A(60,48), (0036) A A2R(60,2), (0037) A ATN11(48,60), (0038) B B(60,40), (0039) B BTN11(40,60), (0040) D D(130,130), (0041) D D21I(40,90),D22I(40,40),D12I(90,40), (0042) D DTIME, (0043) E E(130,240), (0044) E E11I(90,48),E21I(40,48), (0045) G G(240,240),GI(48,48), (0046) H H(130,1), (0047) H H2I(40,1), (0048) K K(240,1),KI(48,1), (0049) N NI(90,90),N1(60,90),N11(60,60), (0050) S SCALD,SCALD2,SCAL, (0051) T TI,TJ,T2, (0052) U UI(90,1),U1I(60,1), (0053) V VARF (0054) (0055) LOGICAL LPRINT (0056) (0057) COMMON /COM10/ A,B,A2R (0058) COMMON /COM3/ NI,UI (0059) COMMON /COM6/ D,E,G,H,K (0060) COMMON /COM7/ D21I,D22I,E11I,E21I,GI,N1,N11,ATN11,BTN11 (0061) (0062) NDE1 = NP2H (0063) NDE2 = NDE - NP2H (0064) NP2H1 = NP2H + 1 (0065) (0066) C CLEAR SUBMATRICES (0067) 7 IF(INET.GT.1) GOTO 8 (0068) CALL DMTSCL(G,G,0.D0,240,240,NRC,NRC) (0069) CALL DMTSCL(K,K,0.D0,240,1,NRC,1) (0070) CALL DMTSCL(D,D,0.D0,130,130,NDE,NDE) (0071) CALL DMTSCL(E,E,0.D0,130,240,NDE,NRC) (0072) CALL DMTSCL(H,H,0.D0,90,1,NDE,1) (0073) 8 CONTINUE (0074) (0075) C SCALE NI AND UI (0076) SCAL = -SCALD/VARF (0077) SCALD2 = SCALD*SCALD/VARF (0078) CALL DMTSCL(NI,NI,SCALD2,90,90,NP2H,NP2H) (0079) CALL DMTSCL(UI,UI,SCAL,90,1,NP2H,1) (0080) (0081) 11 DO 12 I=1,NP2 (0082) U1I(I,1) = UI(I,1) (0083) 12 CONTINUE (0084) (0085) 13 DO 14 I=1,NP2 (0086) 15 DO 16 J=1,NP2H (0087) N1(I,J) = NI(I,J) (0088) 17 IF(J.GT.NP2) GOTO 18 (0089) N11(I,J) = NI(I,J) (0090) 18 CONTINUE (0091) 16 CONTINUE (0092) 14 CONTINUE (0093) (0094) C GENERATE NORMAL SUBMATRICES (0095) CALL DMTMLT(D21I,B,N1,40,60,90,NDE2,NP2,NDE1,1) (0096) CALL DMTMLT(BTN11,B,N11,40,60,60,NDE2,NP2,NP2,1) (0097) CALL DMTMLT(D22I,BTN11,B,40,60,40,NDE2,NP2,NDE2,0) (0098) CALL DMTMLT(H2I,B,U1I,40,60,1,NDE2,NP2,1,1) (0099) CALL DMTMLT(E11I,N1,A,90,60,48,NP2H,NP2,NU2,1) (0100) CALL DMTMLT(E21I,BTN11,A,40,60,48,NDE2,NP2,NU2,0) (0101) CALL DMTMLT(ATN11,A,N11,48,60,60,NU2,NP2,NP2,1) (0102) CALL DMTMLT(GI,ATN11,A,48,60,48,NU2,NP2,NU2,0) (0103) CALL DMTMLT(KI,A,U1I,48,60,1,NU2,NP2,1,1) (0104) (0105) C SUMMATION OF NORMAL SUBMATRICES (0106) CALL DMTSAD(D,NI,1.D0,1,1,NDE,NDE,NP2H,NP2H,130,130,90,90) (0107) CALL DMTSAD(D,D21I,1.D0,NP2H1,1,NDE,NDE,NDE2,NP2H,130,130,40,90) (0108) CALL DMTSAD(D,D22I,1.D0,NP2H1,NP2H1,NDE,NDE,NDE2,NDE2,130,130,40, (0109) 1 40) (0110) CALL DMTTRS(D12I,D21I,NP2H,NDE2,90,40) (0111) CALL DMTSAD(D,D12I,1.D0,1,NP2H1,NDE,NDE,NP2H,NDE2,130,130,90,40) (0112) CALL DMTSAD(H,UI,1.D0,1,1,NDE,1,NP2H,1,130,1,90,1) (0113) CALL DMTSAD(H,H2I,1.D0,NP2H1,1,NDE,1,NDE2,1,130,1,40,1) (0114) ICOL = 1 (0115) 21 DO 22 I=1,MT (0116) TI = THETA(DTIME,I) (0117) CALL DMTSAD(E,E11I,TI,1,ICOL,NDE,NRC,NP2H,NU2,130,240,90,48) (0118) CALL DMTSAD(E,E21I,TI,NP2H1,ICOL,NDE,NRC,NDE2,NU2,130,240,40, (0119) 1 48) (0120) CALL DMTSAD(K,KI,TI,ICOL,1,NRC,1,NU2,1,240,1,48,1) (0121) IROW = 1 (0122) 23 DO 24 J=1,MT (0123) TJ = THETA(DTIME,J) (0124) T2 = TI * TJ (0125) CALL DMTSAD(G,GI,T2,IROW,ICOL,NRC,NRC,NU2,NU2,240,240,48,48) (0126) IROW = IROW + NU2 (0127) 24 CONTINUE (0128) ICOL = ICOL + NU2 (0129) 22 CONTINUE (0130) (0131) C OUTPUT (0132) 5 IF(.NOT.LPRINT) GOTO 6 (0133) C CALL DMTOUT(D11,90,90,NDE1,NDE1,6,'D','5') (0134) C CALL DMTOUT(D21,40,90,NDE2,NDE1,6,'D','5') (0135) C CALL DMTOUT(D22,40,40,NDE2,NDE2,6,'D','5') (0136) CALL DMTOUT(E,130,240,NDE,NRC,6,'D','5') (0137) CALL DMTOUT(G,240,240,NRC,NRC,6,'D','5') (0138) CALL DMTOUT(H,130,1,NDE,1,6,'D','5') (0139) CALL DMTOUT(K,240,1,NRC,1,6,'D','5') (0140) 6 CONTINUE (0141) RETURN (0142) END PROGRAM SIZE: PROCEDURE - 001540 LINKAGE - 035376 STACK - 000106 A D /COM10/ 000000 0034S 0057S 0099A 0100A 0101A 0102A 0103A ATN11 D /COM7/ 000001 061540 0034S 0060S 0101A 0102A B D /COM10/ 026400 0034S 0057S 0095A 0096A 0097A 0098A BTN11 D /COM7/ 000001 110140 0034S 0060S 0096A 0097A 0100A D D /COM6/ 000000 000000 0034S 0059S 0070A 0106A 0107A 0108A 0111A D12I D LINKAGE 000442 0034S 0110A 0111A D21I D /COM7/ 000000 000000 0034S 0060S 0095A 0107A 0110A D22I D /COM7/ 000000 034100 0034S 0060S 0097A 0108A DMTMLT R EXTERNAL 000000 0095 0096 0097 0098 0099 0100 0101 0102 0103 DMTOUT R EXTERNAL 000000 0136 0137 0138 0139 DMTSAD R EXTERNAL 000000 0106 0107 0108 0111 0112 0113 0117 0118 0120 0125 DMTSCL R EXTERNAL 000000 0068 0069 0070 0071 0072 0078 0079 DMTTRS R EXTERNAL 000000 0110 DTIME D ARGUMENT 000067 0026S 0034S 0116A 0123A E D /COM6/ 000001 004020 0034S 0059S 0071A 0117A 0118A 0136A E11I D /COM7/ 000000 050500 0034S 0060S 0099A 0117A E21I D /COM7/ 000000 112300 0034S 0060S 0100A 0118A G D /COM6/ 000002 167620 0034S 0059S 0068A 0125A 0137A GI D /COM7/ 000000 131300 0034S 0060S 0102A 0125A H D /COM6/ 000006 071620 0034S 0059S 0072A 0112A 0113A 0138A H2I D LINKAGE 034542 0034S 0098A 0113A I I LINKAGE 000407 0081M 0082 0085M 0087 0089 0115M 0116A ICOL I LINKAGE 000415 0114M 0117A 0118A 0120A 0125A 0128M INET I ARGUMENT 000042 0026S 0067 IROW I LINKAGE 000416 0121M 0125A 0126M J I LINKAGE 000410 0086M 0087 0088 0089 0122M 0123A K D /COM6/ 000006 072630 0034S 0059S 0069A 0120A 0139A KI D LINKAGE 035002 0034S 0103A 0120A LPRINT L ARGUMENT 000061 0026S 0055S 0132 MT I ARGUMENT 000075 0026S 0031S 0115 0122 N1 D /COM7/ 000000 153300 0034S 0060S 0087M 0095A 0099A N11 D /COM7/ 000001 025440 0034S 0060S 0089M 0096A 0101A NDE I ARGUMENT 000056 0026S 0031S 0063 0070A 0071A 0072A 0106A 0107A 0108A 0111A 0112A 0113A 0117A 0118A 0136A 0138A NDE1 I LINKAGE 000400 0031S 0062M 0095A NDE2 I LINKAGE 000401 0031S 0063M 0095A 0096A 0097A 0098A 0100A 0107A 0108A 0110A 0111A 0113A 0118A NI D /COM3/ 000000 0034S 0058S 0078A 0087 0089 0106A NP2 I ARGUMENT 000045 0026S 0031S 0081 0085 0088 0095A 0096A 0097A 0098A 0099A 0100A 0101A 0102A 0103A NP2H I ARGUMENT 000050 0026S 0031S 0062 0063 0064 0078A 0079A 0086 0099A 0106A 0107A 0110A 0111A 0112A 0117A NP2H1 I LINKAGE 000402 0064M 0107A 0108A 0111A 0113A 0118A NRC I ARGUMENT 000100 0026S 0031S 0068A 0069A 0071A 0117A 0118A 0120A 0125A 0136A 0137A 0139A NU2 I ARGUMENT 000053 0026S 0031S 0099A 0100A 0101A 0102A 0103A 0117A 0118A 0120A 0125A 0126 0128 SCAL D LINKAGE 035676 0034S 0076M 0079A SCALD D ARGUMENT 000064 0026S 0034S 0076 0077 SCALD2 D LINKAGE 035702 0034S 0077M 0078A T2 D LINKAGE 035770 0034S 0124M 0125A THETA R EXTERNAL 000000 0116 0123 TI D LINKAGE 035760 0034S 0116M 0117A 0118A 0120A 0124 TJ D LINKAGE 035764 0034S 0123M 0124 U1I D LINKAGE 035302 0034S 0082M 0098A 0103A UI D /COM3/ 077220 0034S 0058S 0079A 0082 0112A VARF D ARGUMENT 000072 0026S 0034S 0076 0077 $11 000220 0081D $12 000230 0081 0083D $13 000237 0085D $14 000341 0085 0092D $15 000241 0086D $16 000332 0086 0091D $17 000274 0088D $18 000332 0088 0090D $21 001146 0115D $22 001401 0115 0129D $23 001307 0122D $24 001366 0122 0127D $5 001410 0132D $6 001524 0132 0140D $7 000014 0067D $8 000141 0067 0073D 0000 ERRORS [FTN-REV18.2] (0143) (0144) SUBROUTINE DELCYC(NE,NA,IERR,LPRINT) (0145) (0146) C ELIMINATION CYCLE OF NORMAL-HYPERMATRIX (0147) (0148) INTEGER*2 (0149) I IERR (0150) (0151) REAL*8 (0152) D D(130,130), (0153) D DINV(130,130), (0154) D DINVE(130,240), (0155) D DINVH(130,1), (0156) E E(130,240), (0157) G G(240,240), (0158) H H(130,1), (0159) K K(240,1), (0160) N NORM(240,240), (0161) U UMAT(240,1) (0162) (0163) LOGICAL LPRINT (0164) (0165) COMMON /COM6/D,E,G,H,K (0166) COMMON /COM8/NORM,UMAT (0167) COMMON /COM9/DINV,DINVE,DINVH (0168) (0169) CALL DMTINV(DINV,D,130,NE,IERR) (0170) 900 IF(IERR.NE.0) GOTO 901 (0171) IF(LPRINT) CALL DMTOUT(DINV,130,130,NE,NE,6,'D','5') (0172) CALL DMTMLT(DINVE,DINV,E,130,130,240,NE,NE,NA,0) (0173) CALL DMTMLT(NORM,E,DINVE,240,130,240,NA,NE,NA,1) (0174) IF(LPRINT) CALL DMTOUT(NORM,240,240,NA,NA,6,'D','5') (0175) CALL DMTSUB(NORM,G,NORM,240,240,NA,NA) (0176) CALL DMTMLT(DINVH,DINV,H,130,130,1,NE,NE,1,0) (0177) CALL DMTMLT(UMAT,E,DINVH,240,130,1,NA,NE,1,1) (0178) CALL DMTSUB(UMAT,K,UMAT,240,1,NA,1) (0179) (0180) C OUTPUT (0181) IF(.NOT.LPRINT) GOTO 9 (0182) CALL DMTOUT(NORM,240,240,NA,NA,6,'D','5') (0183) CALL DMTOUT(UMAT,240,1,NA,1,6,'D','5') (0184) 9 CONTINUE (0185) (0186) RETURN (0187) (0188) C ERROR MESSAGE (0189) 901 CONTINUE (0190) WRITE(1,1901) (0191) 1901 FORMAT('*** D SINGULAR IN DELCYC***'/) (0192) RETURN (0193) END PROGRAM SIZE: PROCEDURE - 000370 LINKAGE - 000070 STACK - 000056 D D /COM6/ 000000 000000 0151S 0165S 0169A DINV D /COM9/ 000000 000000 0151S 0167S 0169A 0171A 0172A 0176A DINVE D /COM9/ 000001 004020 0151S 0167S 0172A 0173A DINVH D /COM9/ 000002 167620 0151S 0167S 0176A 0177A DMTINV R EXTERNAL 000000 0169 DMTMLT R EXTERNAL 000000 0172 0173 0176 0177 DMTOUT R EXTERNAL 000000 0171 0174 0182 0183 DMTSUB R EXTERNAL 000000 0175 0178 E D /COM6/ 000001 004020 0151S 0165S 0172A 0173A 0177A G D /COM6/ 000002 167620 0151S 0165S 0175A H D /COM6/ 000006 071620 0151S 0165S 0176A IERR I ARGUMENT 000050 0144S 0148S 0169A 0170 K D /COM6/ 000006 072630 0151S 0165S 0178A LPRINT L ARGUMENT 000053 0144S 0163S 0171 0174 0181 NA I ARGUMENT 000045 0144S 0172A 0173A 0174A 0175A 0177A 0178A 0182A 0183A NE I ARGUMENT 000042 0144S 0169A 0171A 0172A 0173A 0176A 0177A NORM D /COM8/ 000000 000000 0151S 0166S 0173A 0174A 0175A 0182A UMAT D /COM8/ 000003 102000 0151S 0166S 0177A 0178A 0183A $1901 000346 0190 0191D $9 000335 0181 0184D $900 000015 0170D $901 000336 0170 0189D 0000 ERRORS [FTN-REV18.2] (0194) (0195) SUBROUTINE LSQUA(X,APVARF,ISING,NO,NU,NU2,NN,NNET,NUIPAR,FACTK, (0196) 1 SCALD,TIME,ITEST,LPRINT,NONET,NUNET,LPREAN,NUH,ALPH,NRC,ISTAT, (0197) 2 TIMSPA,MT,ISOBS,ISNU,TIME0,ALPHP,XICHI,IDIM,CRXON) (0198) (0199) C LEAST SQUARES ADJUSTMENT (0200) (0201) INTEGER*2 (0202) I ISING, /* SINGULARITY CODE (0203) I ISTAT(2), (0204) I ITEST, /* TEST OPTION # (0205) N NAME(30,4), (0206) N NO,NU, /* NUMBER OF OBSERVATIONS/UNKNOWN (0207) N NONET(50), (0208) N NUNET(50), (0209) N NUIPAR(50,2) (0210) (0211) REAL*4 (0212) A APVARF, /* A POST.VARIANCEFACTOR (0213) F FACTK, (0214) R RTPR, (0215) S SQRVAR, (0216) T TIME(50), (0217) T TIME0, (0218) T TIMSPA, (0219) X X0I (0220) (0221) REAL*8 (0222) A A(60,48), (0223) A A2R(60,2), (0224) A ALPH, (0225) A APVAR2, (0226) B B(60,40), (0227) C CRXON, (0228) C CX(240,240), (0229) D DELTA2(90,1), (0230) D DELTAE(130,1), (0231) D DTIME, (0232) D DTIMN, (0233) N NORM(240,240), (0234) R RMESS, (0235) R RMOD, (0236) R RC(240,240), (0237) S SCALD, (0238) S S0, (0239) U UMAT(240,1), (0240) V V(160,1), (0241) V VARF(50), (0242) V VARFI, (0243) X X(240,1), (0244) X X0(240,1), (0245) X XFACT, (0246) X XICHI, (0247) X XICHIV (0248) (0249) LOGICAL LPRINT,LCHIST,LPREAN,LTSTOP (0250) (0251) COMMON /COM10/ A,B,A2R (0252) COMMON /COM2/ CX (0253) COMMON /COM4/ RC (0254) COMMON /COM8/ NORM,UMAT (0255) COMMON /COM14/ NAME,VARF (0256) COMMON /STAT/ NDF1,NDF2 (0257) (0258) DATA (0259) N NDEDIM/130/, (0260) N NDE2DI/40/, (0261) N NODIM/30/, (0262) N NO2DIM/60/, (0263) N NO2HDI/90/, (0264) N NUDIM/24/, (0265) N NU2DIM/48/, (0266) N NRCDIM/240/, (0267) N NCCDIM/120/ (0268) (0269) TSTART = CRXON (0270) NO2 = 2*NO (0271) NO2H = NO2 + NUH (0272) NDE = NO2 + NN + NUH (0273) NDE1 = NO2H (0274) NDE2 = NDE - NO2H (0275) (0276) WRITE(1,1961) NO2,NU2,NRC (0277) 1961 FORMAT('L.S. APPROX.: ',I3,'OBSERV. ',I3,'REAL COEFF. ',I3, (0278) 1 'CONSTRAINED COEFF.'/) (0279) (0280) C COMPUTE DIRECT SOLUTION (0281) 33 IF(.NOT.LPRINT) GOTO 34 (0282) CALL DMTINV(CX,NORM,NRCDIM,NRC,ISING) (0283) IF(ISING.NE.0) GOTO 902 (0284) 9993 CONTINUE (0285) 6003 FORMAT(' NORM SINGULAR'/) (0286) CALL DMTMLT(X,CX,UMAT,NRCDIM,NRCDIM,1,NRC,NRC,1,0) (0287) WRITE(6,6004) (0288) 6004 FORMAT(' INV(NORM)'/) (0289) CALL DMTOUT(CX,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') (0290) WRITE(6,6005) (0291) 6005 FORMAT(' X'/) (0292) CALL DMTOUT(X,NRCDIM,1,NRC,1,6,'D','5') (0293) 34 CONTINUE (0294) (0295) C CHOLESKY DECOMPOSITION OF THE NORMAL MATRIX (0296) CALL DCHOL1(RC,NORM,NRCDIM,NRC,INDEF) (0297) IF(LPRINT) WRITE(6,6006) (0298) 6006 FORMAT(' RC'/) (0299) IF(LPRINT) CALL DMTOUT(RC,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') (0300) IF(INDEF.NE.0) GOTO 904 (0301) (0302) C TEST DECOMPOSITION (0303) 35 IF(.NOT.LPRINT) GOTO 36 (0304) CALL DMTMLT(CX,RC,RC,NRCDIM,NRCDIM,NRCDIM,NRC,NRC,NRC,1) (0305) WRITE(6,6007) (0306) 6007 FORMAT(' RTR'/) (0307) CALL DMTOUT(CX,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') (0308) 36 CONTINUE (0309) (0310) C INVERT RC-MATRIX (0311) CALL DRMINV(RC,RC,NRCDIM,NRC,IERR) (0312) IF(LPRINT) WRITE(6,6008) (0313) 6008 FORMAT(' INV(RC)'/) (0314) IF(LPRINT) CALL DMTOUT(RC,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') (0315) IF(IERR.GT.0) GOTO 903 (0316) (0317) C COMPUTE ORTHO-NORMAL SOLUTION VECTOR (0318) CALL DMTMLT(X0,RC,UMAT,NRCDIM,NRCDIM,1,NRC,NRC,1,1) (0319) (0320) C SORT ORTHONORMALIZED SOLUTION VECTOR AND RE-ARANGE R1-MATRIX (0321) CALL DSISRT(X0,RC,NRCDIM,NRCDIM,NRC,NRC) (0322) (0323) IF(LPRINT)WRITE(6,2009) (0324) 2009 FORMAT(1H ,'X0-VECTOR'/) (0325) IF(LPRINT)CALL DMTOUT(X0,NRCDIM,1,NRC,1,6,'D','5') (0326) (0327) C STATISTICAL TEST PROCEDURE OF FOURIER COEFFICIENTS (0328) (0329) 401 IF(LPREAN) GOTO 402 (0330) WRITE(6,2016) (0331) 2016 FORMAT(1H //' FOURIER COEFFICIENTS:'/' NO',9X,'COEFF.',3X, (0332) 1 'VAR.(SQRT)',6X,'TEST-CRIT.',4X,'REJECT.',5X,'RTPR',6X, (0333) 2 'POST.VAR.F.',2X, 'D.F.'/21X,'PRIOR',2X,'POSTERIOR'//) (0334) (0335) NC = 0 (0336) IDIM = -1 (0337) PRIVAR = 1. (0338) STEST = 0. (0339) LTSTOP = .FALSE. (0340) CALL DMTSCL(X,X,0.D0,NRCDIM,1,NRC,1) (0341) 13 DO 14 I=0,NRC (0342) (0343) IDIM = IDIM + 1 (0344) C TRANSFORM BACK TO ORIGINAL POLYNOMIAL COEFFICIENTS (0345) 19 IF(I.EQ.0) GOTO 20 (0346) CALL DMTMLT(X,RC,X0,NRCDIM,NRCDIM,1,NRC,I,1,0) (0347) 20 CONTINUE (0348) (0349) C BACK SOLUTION OF ELIMINATED PARAMETERS, ADJUSTED PSEUDO OBS. (0350) CALL BACKS(DELTAE,X,NRC,NDE) (0351) CALL DMTSCL(DELTAE,DELTAE,SCALD,NDEDIM,1,NDE,1) (0352) IF(LPRINT) WRITE(6,6991) (0353) 6991 FORMAT(1H ,'DELTAE'/) (0354) IF(LPRINT)CALL DMTOUT(DELTAE,NDEDIM,1,NDE,1,6,'D','5') (0355) (0356) INPAR = 1 (0357) RTPR = 0. (0358) X0I = X0(I,1) (0359) 15 IF(ITEST.EQ.-1.OR.(ITEST.EQ.-3.AND.(ABS(X0I).GT.TSTART.OR. (0360) 1 LTSTOP))) GOTO 16 (0361) REWIND 8 (0362) 41 DO 42 INET=1,NNET (0363) (0364) C ADJUSTED PSEUDO-OBSERVABLES (0365) DTIME = TIME(INET) - TIME0 (0366) IF(LPRINT) WRITE(6,6994) DTIME (0367) 6994 FORMAT(1H ,'DTIME=',F10.4/) (0368) CALL BMAT(B,A2R,NUIPAR,INET,INPAR,NO2DIM,NO2HDI,NDE,NDEDIM, (0369) 1 NO2,NO2H,NN,NDE2DI,NDE2) (0370) (0371) DTIMN = DTIME/(TIMSPA/2.) (0372) CALL ADJCOR(INET,DELTA2,DELTAE,X,A,B,NO2HDI,NO2H,NRCDIM,NRC, (0373) 1 NDEDIM,NDE,NDE2DI,NDE2,NO2DIM,NO2,DTIMN,SCALD,MT,NU2DIM,NU2) (0374) (0375) IF(LPRINT)WRITE(6,6995) (0376) 6995 FORMAT(1H ,'DELTAI'/) (0377) IF(LPRINT)CALL DMTOUT(DELTA2,1,NO2HDI,1,NO2H,6,'D','5') (0378) C CALL ASTOR2(INET) (0379) CALL AREADB(1,8) (0380) CALL DMTSCL(DELTA2,DELTA2,-1.D0,NO2HDI,1,NO2H,1) (0381) CALL RESID(NOBS,DELTA2,V,NV,NPG,S0) (0382) S0 = S0 / VARF(INET) (0383) IF(LPRINT) WRITE(6,6015)S0 (0384) 6015 FORMAT(1H ,F12.4) (0385) IF(LPRINT)WRITE(6,2011) (0386) 2011 FORMAT(1H ,'RESIDUALS'/) (0387) IF(LPRINT)CALL DMTOUT(V,1,160,1,NV,6,'D','5') (0388) RTPR = RTPR + S0 (0389) 42 CONTINUE (0390) 16 CONTINUE (0391) IDF = ISOBS - ISNU + NC - NDE -I (0392) APVARF = 1. (0393) 301 IF(IDF.LE.0) GOTO 302 (0394) APVARF = SQRT(RTPR/IDF) (0395) (0396) C CHI-SQUARE TEST ON THE VARIANCE FACTOR (0397) C IF(LCHIST(IDF,SALPH,PRIVAR,APVARF)) STEST = FACTK*APVARF (0398) (0399) 302 CONTINUE (0400) (0401) (0402) C SET INSIGNIFICANT FOURIER COEFFICIENTS TO ZERO (0403) RMESS = ' ' (0404) X0I = 0. (0405) IF(I.EQ.0) GOTO 304 (0406) X0I = X0(I,1) (0407) IF(LTSTOP) GOTO 210 (0408) 303 GOTO(200,201,202,203,204,205), IABS(ITEST)+1 (0409) (0410) 200 CONTINUE (0411) GOTO 304 (0412) (0413) 201 CONTINUE (0414) STEST = FACTK*PRIVAR (0415) IF(ABS(X0I).GT.STEST) GOTO 304 (0416) GOTO 210 (0417) (0418) 202 CONTINUE (0419) STEST = FACTK*APVARF (0420) IF(ABS(X0I).GT.STEST) GOTO 304 (0421) GOTO 210 (0422) (0423) 203 CONTINUE (0424) STEST = FACTK*PRIVAR (0425) IF(ABS(X0I).LT.TSTART) STEST = FACTK*APVARF (0426) IF(ABS(X0I).GT.STEST) GOTO 304 (0427) GOTO 210 (0428) (0429) 204 CONTINUE (0430) IF(RTPR.LT.RTPROL) GOTO 304 (0431) GOTO 210 (0432) (0433) 205 CONTINUE (0434) IF(ABS(X0I).GT.FACTK*PRIVAR.AND.ABS(X0I).GT.FACTK*APVARF (0435) 1 .AND.APVARF.LT.APVOLD) GOTO 304 (0436) (0437) 210 CONTINUE (0438) LTSTOP = .TRUE. (0439) X0(I,1) = 0.D0 (0440) IDIM = IDIM - 1 (0441) 17 DO 18 J=1,NRC (0442) RC(J,I) = 0.D0 (0443) 18 CONTINUE (0444) RMESS = 'SET TO 0' (0445) NC = NC + 1 (0446) 307 GOTO 308 (0447) 304 CONTINUE (0448) APVOLD = APVARF (0449) RTPROL = RTPR (0450) 308 CONTINUE (0451) 9991 WRITE(6,2017)I,X0I,PRIVAR,APVARF,STEST,RMESS,RTPR,APVARF,IDF (0452) 2017 FORMAT(I3,4X,F12.4,3F8.4,4X,A8,4X,2(F10.3,3X),I3) (0453) 14 CONTINUE (0454) (0455) C TRANSFORM BACK TO ORIGINAL POLYNOMIAL COEFFICIENTS (0456) CALL DMTMLT(X,RC,X0,NRCDIM,NRCDIM,1,NRC,NRC,1,0) (0457) (0458) C COMPUTE FINAL RESIDUALS AND A POSTERIORI VARIANCE FACTOR (0459) (0460) C BACK SOLUTION OF ELIMINATED PARAMETERS (0461) CALL BACKS(DELTAE,X,NRC,NDE) (0462) CALL DMTSCL(DELTAE,DELTAE,SCALD,NDEDIM,1,NDE,1) (0463) (0464) C PRINT ELIMINATED PARAMETERS (0465) WRITE(6,6025) (0466) 6025 FORMAT(1H /' ELIMINATED PARAMETERS: '/) (0467) CALL DMTOUT(DELTAE,1,NDEDIM,1,NDE,6,'F','3') (0468) (0469) C RESIDUALS OF ORIGINAL OBSERVATIONS (0470) 402 CONTINUE (0471) (0472) INPAR = 1 (0473) RTPR = 0. (0474) IDF = ISOBS - ISNU + NC - NDE - NRC (0475) REWIND 8 (0476) 43 DO 44 INET=1,NNET (0477) 403 IF(LPREAN) GOTO 404 (0478) (0479) C ADJUSTED COORDINATES (0480) DTIME = TIME(INET) - TIME0 (0481) DTIMN = DTIME/(TIMSPA/2.) (0482) (0483) CALL BMAT(B,A2R,NUIPAR,INET,INPAR,NO2DIM,NO2HDI,NDE,NDEDIM, (0484) 1 NO2,NO2H,NN,NDE2DI,NDE2) (0485) CALL ADJCOR(INET,DELTA2,DELTAE,X,A,B,NO2HDI,NO2H,NRCDIM,NRC, (0486) 1 NDEDIM,NDE,NDE2DI,NDE2,NO2DIM,NO2,DTIMN,SCALD,MT,NU2DIM,NU2) (0487) (0488) C PRINT ADJUSTED COORDINATES OF THE I-TH EPOCH (0489) C WRITE(6,6901) (0490) WRITE(6,6021) INET (0491) 6021 FORMAT(1H //' ADJUSTED COORDINATES OF THE ',I2,' -TH EPOCH'// (0492) 1' STATION',6X,'X',10X,'Y'//) (0493) 45 DO 46 J=1,NO (0494) J2=2*J (0495) J1=J2-1 (0496) WRITE(6,6022) (NAME(J,K),K=1,4),DELTA2(J1,1),DELTA2(J2,1) (0497) 6022 FORMAT(1H ,4A2,2F12.4/) (0498) 46 CONTINUE (0499) (0500) C RESIDUALS (0501) C CALL ASTOR2(INET) (0502) CALL AREADB(1,8) (0503) CALL DMTSCL(DELTA2,DELTA2,-1.D0,NO2HDI,1,NO2H,1) (0504) CALL RESID(NOBS,DELTA2,V,NV,NPG,S0) (0505) S0 = S0 / VARF(INET) (0506) (0507) C PRINT RESIDUALS OF THE I-TH EPOCH (0508) WRITE(6,6023) (0509) 6023 FORMAT(1H ,/' RESIDUALS OF ORIGINAL OBSERVATIONS:'/) (0510) CALL DMTOUT(V,1,160,1,NV,6,'F','4') (0511) VARFI = 0.D0 (0512) 305 IF(IDF.LE.0) GOTO 306 (0513) VARFI = S0 * ISOBS / (INTL(IDF)*INTL(NOBS)) (0514) IF(VARFI.LE.0.D0) GOTO 306 (0515) VARFI = DSQRT(VARFI) (0516) 306 CONTINUE (0517) WRITE(6,6024) NOBS,S0,VARFI (0518) 6024 FORMAT(1H /' NUMBER OF OBSERVATIONS:',I3/ (0519) 1 ' QUADRATIC FORM OF WEIGHTED RESIDUALS: ',F12.4/ (0520) 2 ' APPROX. OF GROUP VAR. FACTOR: ',F9.6//) (0521) (0522) RTPR = RTPR + S0 (0523) 404 CONTINUE (0524) 44 CONTINUE (0525) APVARF = 1. (0526) 311 IF(IDF.LE.0) GOTO 312 (0527) APVAR2 = RTPR/IDF (0528) APVARF = SQRT(APVAR2) (0529) NDF1 = IDF (0530) XICHIV = DICCHI(ALPH)/IDF (0531) RMOD = ' FAILS ' (0532) IF(APVAR2.LT.XICHIV) RMOD = ' PASSES ' (0533) C XTXS = XTX(1,1)/APVAR2 (0534) 312 CONTINUE (0535) NDF1 = IDIM (0536) XICHI = DICCHI(ALPH) (0537) XFACT = DSQRT(XICHI) (0538) (0539) C WRITE DEGREE OF FREEDOM AND A POSTERIORI VARIANCE FACTOR (0540) IF(.NOT.LPREAN)WRITE(6,6901) (0541) WRITE(6,6014) ISOBS,ISNU,NC,NDE,NRC,IDF,APVARF (0542) 6014 FORMAT(1H ,'DEGREES OF FREEDOM AND COVARIANCE MATRIX'// (0543) 1' TOTAL NUMBER OF ORIGINAL OBSERVATIONS: ',T55,I3/ (0544) 2' NUMBER OF NUISANCE PARAMETERS OF NETWORK ADJUSTMENT: ',T55,I3/ (0545) 3' NUMBER OF CONSTRAINED PARAMETERS: ',T55,I3/ (0546) 4' NUMBER OF ELIMINATED PARAMETERS: ',T55,I3/ (0547) 5' NUMBER OF UNKNOWN COEFFICIENTS: ',T55,I3/ (0548) 6 ' DEGREE OF FREEDOM: ',T55,I3/' A POST. VARIANCE FACTOR (SQRT):', (0549) 7 T55,F12.4//) (0550) (0551) ALPHP = ALPH * 100. (0552) (0553) IF(LPRINT)CALL DMTOUT(X,NRCDIM,1,NRC,1,6,'D','5') (0554) (0555) C COVARIANCE MATRIX OF COEFFICIENTS (0556) CALL DMTMLT(CX,RC,RC,NRCDIM,NRCDIM,NRCDIM,NRC,NRC,NRC,2) (0557) (0558) IF(ISTAT(2).EQ.1)CALL DMTSCL(CX,CX,APVAR2,NRCDIM,NRCDIM,NRC,NRC) (0559) 691 IF(NRC.GT.10) GOTO 692 (0560) WRITE(6,6017) (0561) 6017 FORMAT(1H /' COVARIANCE MATRIX OF THE COEFFICIENTS'/) (0562) IF(ISTAT(2).EQ.1) WRITE(6,6013) (0563) IF(ISTAT(2).EQ.0) WRITE(6,6012) (0564) 6013 FORMAT(1H ,'A POST.'/) (0565) 6012 FORMAT(1H ,'A PRIORI'/) (0566) CALL DMTOUT(CX,NRCDIM,NRCDIM,NRC,NRC,6,'D','5') (0567) 692 CONTINUE (0568) (0569) GOTO 9999 (0570) (0571) C ERROR MESSAGES (0572) 902 CONTINUE (0573) WRITE(1,9902) (0574) WRITE(6,9902) (0575) 9902 FORMAT(' ***NORM-MATRIX SINGULAR***'/) (0576) GOTO 9993 (0577) 903 CONTINUE (0578) WRITE(1,9903) (0579) WRITE(6,9903) (0580) 9903 FORMAT(' ***RA-MATRIX SINGULAR***'/) (0581) GOTO 9999 (0582) 904 CONTINUE (0583) WRITE(1,9904) (0584) WRITE(6,9904) (0585) 9904 FORMAT(' ***NORM-MATRIX INDEFINIT***'/) (0586) (0587) 9999 CONTINUE (0588) RETURN (0589) (0590) C NEW PAGE COMMAND (0591) 6901 FORMAT(' '/) (0592) END PROGRAM SIZE: PROCEDURE - 005016 LINKAGE - 005146 STACK - 000202 A D /COM10/ 000000 0221S 0251S 0372A 0485A A2R D /COM10/ 051200 0221S 0251S 0368A 0483A ABS R EXTERNAL 000000 0359 0415 0420 0425 0426 0434 ADJCOR R EXTERNAL 000000 0372 0485 ALPH D ARGUMENT 000132 0195S 0221S 0530A 0536A 0551 ALPHP R ARGUMENT 000162 0195S 0551M APVAR2 D LINKAGE 005522 0221S 0527M 0528A 0532 0558A APVARF R ARGUMENT 000047 0195S 0211S 0392M 0394M 0419 0425 0434 0448 0451 0525M 0528M 0541 APVOLD R LINKAGE 005502 0434 0448M AREADB R EXTERNAL 000000 0379 0502 B D /COM10/ 026400 0221S 0251S 0368A 0372A 0483A 0485A BACKS R EXTERNAL 000000 0350 0461 BMAT R EXTERNAL 000000 0368 0483 CRXON D ARGUMENT 000173 0195S 0221S 0269 CX D /COM2/ 000000 000000 0221S 0252S 0282A 0286A 0289A 0304A 0307A 0556A 0558A 0566A DCHOL1 R EXTERNAL 000000 0296 DELTA2 D LINKAGE 000476 0221S 0372A 0377A 0380A 0381A 0485A 0496 0503A 0504A DELTAE D LINKAGE 001246 0221S 0350A 0351A 0354A 0372A 0461A 0462A 0467A 0485A DICCHI R EXTERNAL 000000 0530 0536 DMTINV R EXTERNAL 000000 0282 DMTMLT R EXTERNAL 000000 0286 0304 0318 0346 0456 0556 DMTOUT R EXTERNAL 000000 0289 0292 0299 0307 0314 0325 0354 0377 0387 0467 0510 0553 0566 DMTSCL R EXTERNAL 000000 0340 0351 0380 0462 0503 0558 DRMINV R EXTERNAL 000000 0311 DSISRT R EXTERNAL 000000 0321 DSQR$X EXTERNAL 000000 0516 0540 DSQRT D EXTERNAL 000000 0515 0537 DTIME D LINKAGE 005432 0221S 0365M 0366 0371 0480M 0481 DTIMN D LINKAGE 005450 0221S 0371M 0372A 0481M 0485A FACTK R ARGUMENT 000077 0195S 0211S 0414 0419 0424 0425 0434 I I LINKAGE 000430 0341M 0345 0346A 0358 0391 0405 0406 0439 0442 0451 IABS I EXTERNAL 000000 0408 IDF I LINKAGE 000442 0391M 0393 0394 0451 0474M 0512 0513 0526 0527 0529 0530 0541 IDIM I ARGUMENT 000170 0195S 0336M 0343M 0440M 0535 IERR I LINKAGE 000424 0311A 0315 INDEF I LINKAGE 000423 0296A 0300 INET I LINKAGE 000434 0362M 0365 0368A 0372A 0382 0476M 0480 0483A 0485A 0490 0505 INPAR I LINKAGE 000431 0356M 0368A 0472M 0483A INTL I EXTERNAL 000000 0513 ISING I ARGUMENT 000052 0195S 0201S 0282A 0283 ISNU I ARGUMENT 000154 0195S 0391 0474 0541 ISOBS I ARGUMENT 000151 0195S 0391 0474 0513 0541 ISTAT I ARGUMENT 000140 0195S 0201S 0558 0562 0563 ITEST I ARGUMENT 000110 0195S 0201S 0359 0408 J I LINKAGE 000443 0441M 0442 0493M 0494 0496 J1 I LINKAGE 000450 0495M 0496 J2 I LINKAGE 000447 0494M 0495 0496 K I LINKAGE 000451 0496M LPREAN L ARGUMENT 000124 0195S 0249S 0329 0477 0540 LPRINT L ARGUMENT 000113 0195S 0249S 0281 0297 0299 0303 0312 0314 0323 0325 0352 0354 0366 0375 0377 0383 0385 0387 0553 LTSTOP L LINKAGE 000427 0249S 0339M 0359 0407 0438M MT I ARGUMENT 000146 0195S 0372A 0485A NAME I /COM14/ 000000 0201S 0255S 0496 NC I LINKAGE 000425 0335M 0391 0445M 0474 0541 NCCDIM I LINKAGE 000410 0258I NDE I LINKAGE 000413 0272M 0274 0350A 0351A 0354A 0368A 0372A 0391 0461A 0462A 0467A 0474 0483A 0485A 0541 NDE1 I LINKAGE 000414 0273M NDE2 I LINKAGE 000415 0274M 0368A 0372A 0483A 0485A NDE2DI I LINKAGE 000401 0258I 0368A 0372A 0483A 0485A NDEDIM I LINKAGE 000400 0258I 0351A 0354A 0368A 0372A 0462A 0467A 0483A 0485A NDF1 I /STAT/ 000000 0256S 0529M 0535M NN I ARGUMENT 000066 0195S 0272 0368A 0483A NNET I ARGUMENT 000071 0195S 0362 0476 NO I ARGUMENT 000055 0195S 0201S 0270 0493 NO2 I LINKAGE 000411 0270M 0271 0272 0276 0368A 0372A 0483A 0485A NO2DIM I LINKAGE 000403 0258I 0368A 0372A 0483A 0485A NO2H I LINKAGE 000412 0271M 0273 0274 0368A 0372A 0377A 0380A 0483A 0485A 0503A NO2HDI I LINKAGE 000404 0258I 0368A 0372A 0377A 0380A 0483A 0485A 0503A NOBS I LINKAGE 000436 0381A 0504A 0513 0517 NODIM I LINKAGE 000402 0258I NORM D /COM8/ 000000 000000 0221S 0254S 0282A 0296A NPG I LINKAGE 000440 0381A 0504A NRC I ARGUMENT 000135 0195S 0276 0282A 0286A 0289A 0292A 0296A 0299A 0304A 0307A 0311A 0314A 0318A 0321A 0325A 0340A 0341 0346A 0350A 0372A 0441 0456A 0461A 0474 0485A 0541 0553A 0556A 0558A 0559 0566A NRCDIM I LINKAGE 000407 0258I 0282A 0286A 0289A 0292A 0296A 0299A 0304A 0307A 0311A 0314A 0318A 0321A 0325A 0340A 0346A 0372A 0456A 0485A 0553A 0556A 0558A 0566A NU2 I ARGUMENT 000063 0195S 0276 0372A 0485A NU2DIM I LINKAGE 000406 0258I 0372A 0485A NUDIM I LINKAGE 000405 0258I NUH I ARGUMENT 000127 0195S 0271 0272 NUIPAR I ARGUMENT 000074 0195S 0201S 0368A 0483A NV I LINKAGE 000437 0381A 0387A 0504A 0510A PRIVAR R LINKAGE 005412 0337M 0414 0424 0434 0451 RC D /COM4/ 000000 000000 0221S 0253S 0296A 0299A 0304A 0311A 0314A 0318A 0321A 0346A 0442M 0456A 0556A RESID R EXTERNAL 000000 0381 0504 RMESS D LINKAGE 005474 0221S 0403M 0444M 0451 RMOD D LINKAGE 005536 0221S 0531M 0532M RTPR R LINKAGE 005422 0211S 0357M 0388M 0394 0430 0449 0451 0473M 0522M 0527 RTPROL R LINKAGE 005500 0430 0449M S0 D LINKAGE 005464 0221S 0381A 0382M 0383 0388 0504A 0505M 0513 0517 0522 SCALD D ARGUMENT 000102 0195S 0221S 0351A 0372A 0462A 0485A SQRT R EXTERNAL 000000 0394 0528 SQRT$X R EXTERNAL 000000 0399 0534 STEST R LINKAGE 005414 0338M 0414M 0415 0419M 0420 0424M 0425M 0426 0451 TIME R ARGUMENT 000105 0195S 0211S 0365 0480 TIME0 R ARGUMENT 000157 0195S 0211S 0365 0480 TIMSPA R ARGUMENT 000143 0195S 0211S 0371 0481 TSTART R LINKAGE 005356 0269M 0359 0425 UMAT D /COM8/ 000003 102000 0221S 0254S 0286A 0318A V D LINKAGE 002256 0221S 0381A 0387A 0504A 0510A VARF D /COM14/ 000170 0221S 0255S 0382 0505 VARFI D LINKAGE 005512 0221S 0511M 0513M 0514 0515M 0517 X D ARGUMENT 000044 0195S 0221S 0286A 0292A 0340A 0346A 0350A 0372A 0456A 0461A 0485A 0553A X0 D LINKAGE 003456 0221S 0318A 0321A 0325A 0346A 0358 0406 0439M 0456A X0I R LINKAGE 005424 0211S 0358M 0359A 0404M 0406M 0415A 0420A 0425A 0426A 0434A 0451 XFACT D LINKAGE 005542 0221S 0537M XICHI D ARGUMENT 000165 0195S 0221S 0536M 0537A XICHIV D LINKAGE 005532 0221S 0530M 0532 $13 001101 0341D $14 002461 0341 0453D $15 001260 0359D $16 001774 0359 0390D $17 002260 0441D $18 002306 0441 0443D $19 001106 0345D $1961 000056 0276 0277D $20 001137 0345 0347D $200 002073 0408 0410D $2009 000645 0323 0324D $201 002074 0408 0413D $2011 001716 0385 0386D $2016 000721 0330 0331D $2017 002432 0451 0452D $202 002113 0408 0418D $203 002132 0408 0423D $204 002167 0408 0429D $205 002176 0408 0433D $210 002243 0407 0416 0421 0427 0431 0437D $301 002010 0393D $302 002032 0393 0399D $303 002056 0408D $304 002324 0405 0411 0415 0420 0426 0430 0434 0447D $305 003374 0512D $306 003436 0512 0514 0516D $307 002323 0446D $308 002334 0446 0450D $311 003611 0526D $312 003666 0526 0534D $33 000125 0281D $34 000314 0281 0293D $35 000402 0303D $36 000474 0303 0308D $401 000705 0329D $402 002624 0329 0470D $403 002650 0477D $404 003576 0477 0523D $41 001313 0362D $42 001765 0362 0389D $43 002646 0476D $44 003576 0476 0524D $45 003115 0493D $46 003223 0493 0498D $6003 000151 0285D $6004 000222 0287 0288D $6005 000265 0290 0291D $6006 000344 0297 0298D $6007 000444 0305 0306D $6008 000524 0312 0313D $6012 004541 0563 0565D $6013 004530 0562 0564D $6014 004005 0541 0542D $6015 001673 0383 0384D $6017 004432 0560 0561D $6021 003042 0490 0491D $6022 003211 0496 0497D $6023 003316 0508 0509D $6024 003470 0517 0518D $6025 002560 0465 0466D $6901 004744 0540 0591D $691 004415 0559D $692 004575 0559 0567D $6991 001205 0352 0353D $6994 001356 0366 0367D $6995 001536 0375 0376D $902 004576 0283 0572D $903 004640 0315 0577D $904 004701 0300 0582D $9902 004616 0573 0574 0575D $9903 004660 0578 0579 0580D $9904 004721 0583 0584 0585D $9991 002334 0451D $9993 000151 0284D 0576 $9999 004743 0569 0581 0587D 0000 ERRORS [FTN-REV18.2] (0593) (0594) SUBROUTINE BACKS(DELTAE,X,NRC,NDE) (0595) (0596) C BACKSOLUTION OF ELIMINATED PARAMETERS (0597) (0598) REAL*8 (0599) D DINV(130,130), (0600) D DINVE(130,240), (0601) D DINVH(130,1), (0602) D DELTAE(130,1), (0603) X X(240,1) (0604) (0605) COMMON /COM9/DINV,DINVE,DINVH (0606) (0607) CALL DMTMLT(DELTAE,DINVE,X,130,240,1,NDE,NRC,1,0) (0608) CALL DMTSUB(DELTAE,DINVH,DELTAE,130,1,NDE,1) (0609) RETURN (0610) END PROGRAM SIZE: PROCEDURE - 000050 LINKAGE - 000034 STACK - 000056 DELTAE D ARGUMENT 000042 0594S 0598S 0607A 0608A DINVE D /COM9/ 000001 004020 0598S 0605S 0607A DINVH D /COM9/ 000002 167620 0598S 0605S 0608A DMTMLT R EXTERNAL 000000 0607 DMTSUB R EXTERNAL 000000 0608 NDE I ARGUMENT 000053 0594S 0607A 0608A NRC I ARGUMENT 000050 0594S 0607A X D ARGUMENT 000045 0594S 0598S 0607A 0000 ERRORS [FTN-REV18.2] (0611) (0612) SUBROUTINE ADJCOR(INET,DELTA2,DELTAE,X,A,B,NO2HDI,NO2H,NRCDIM, (0613) 1 NRC,NDEDIM,NDE,NDE2DI,NDE2,NO2DIM,NO2,DTIMN,SCALD,MT,NU2DIM,NU2) (0614) (0615) C ADJUSTED COORDINATES OF I-TH EPOCH (0616) (0617) INTEGER*2 (0618) N NDE,NDEDIM, (0619) N NDE2,NDE2DI, (0620) N NRC,NRCDIM, (0621) N NO2,NO2DIM, (0622) N NO2H,NO2HDI (0623) (0624) REAL*8 (0625) A A(60,48), (0626) B B(60,40), (0627) B BDN(60,1), (0628) D DELTAE(130,1), (0629) D DELTAN(40,1), (0630) D DELTA1(60,1), (0631) D DELTA2(90,1), (0632) D DTIMN, (0633) S SCALD, (0634) T T, (0635) T THETA, (0636) X X(240,1), (0637) X XS(48,1) (0638) (0639) 1 DO 2 I=1,NDE2 (0640) DELTAN(I,1) = DELTAE(NO2H+I,1) (0641) 2 CONTINUE (0642) (0643) CALL DMTSCL(BDN,BDN,0.D0,NO2DIM,1,NO2,1) (0644) CALL DMTMLT(BDN,B,DELTAN,NO2DIM,NDE2DI,1,NO2,NDE2,1,0) (0645) (0646) J=0 (0647) 11 DO 12 IT=1,MT (0648) T = THETA(DTIMN,IT) (0649) 13 DO 14 I=1,NU2 (0650) XS(I,1) = X(J+I,1) * T (0651) 14 CONTINUE (0652) CALL DMTMLT(DELTA1,A,XS,NO2DIM,NU2DIM,1,NO2,NU2,1,0) (0653) CALL DMTSCL(DELTA1,DELTA1,SCALD,NO2DIM,1,NO2,1) (0654) CALL DMTADD(BDN,BDN,DELTA1,NO2DIM,1,NO2,1) (0655) J = J + NU2 (0656) 12 CONTINUE (0657) (0658) 3 DO 4 I=1,NO2H (0659) DELTA2(I,1) = DELTAE(I,1) (0660) 5 IF(I.GT.NO2) GOTO 6 (0661) DELTA2(I,1) = DELTA2(I,1) + BDN(I,1) (0662) 6 CONTINUE (0663) 4 CONTINUE (0664) RETURN (0665) END PROGRAM SIZE: PROCEDURE - 000340 LINKAGE - 001542 STACK - 000146 A D ARGUMENT 000056 0612S 0624S 0652A B D ARGUMENT 000061 0612S 0624S 0644A BDN D LINKAGE 000426 0624S 0643A 0644A 0654A 0661 DELTA1 D LINKAGE 001006 0624S 0652A 0653A 0654A DELTA2 D ARGUMENT 000045 0612S 0624S 0659M 0661M DELTAE D ARGUMENT 000050 0612S 0624S 0640 0659 DELTAN D LINKAGE 001366 0624S 0640M 0644A DMTADD R EXTERNAL 000000 0654 DMTMLT R EXTERNAL 000000 0644 0652 DMTSCL R EXTERNAL 000000 0643 0653 DTIMN D ARGUMENT 000122 0612S 0624S 0648A I I LINKAGE 000400 0639M 0640 0649M 0650 0658M 0659 0660 0661 IT I LINKAGE 000404 0647M 0648A J I LINKAGE 000403 0646M 0650 0655M MT I ARGUMENT 000130 0612S 0647 NDE2 I ARGUMENT 000111 0612S 0617S 0639 0644A NDE2DI I ARGUMENT 000106 0612S 0617S 0644A NO2 I ARGUMENT 000117 0612S 0617S 0643A 0644A 0652A 0653A 0654A 0660 NO2DIM I ARGUMENT 000114 0612S 0617S 0643A 0644A 0652A 0653A 0654A NO2H I ARGUMENT 000067 0612S 0617S 0640 0658 NU2 I ARGUMENT 000136 0612S 0649 0652A 0655 NU2DIM I ARGUMENT 000133 0612S 0652A SCALD D ARGUMENT 000125 0612S 0624S 0653A T D LINKAGE 002134 0624S 0648M 0650 THETA D EXTERNAL 000000 0624S 0648 X D ARGUMENT 000053 0612S 0624S 0650 XS D LINKAGE 001626 0624S 0650M 0652A $1 000001 0639D $11 000102 0647D $12 000240 0647 0656D $13 000114 0649D $14 000137 0649 0651D $2 000023 0639 0641D $3 000247 0658D $4 000322 0658 0663D $5 000275 0660D $6 000322 0660 0662D 0000 ERRORS [FTN-REV18.2] (0666) (0667) SUBROUTINE RESID(NOBS,X,V,NV1,NPG,S0) (0668) C*********************************************************************** (0669) C* (0670) C* RESID COMPUTES RESIDUALS FOR ALL OBSERVATIONS. ALSO COMPUTES THE (0671) C* QUADRATIC FORM OF WEIGHTED RESIDUALS (0672) C* (0673) C* (0674) C* INPUT: (0675) C* -ALL DESCRIBED IN MAIN (0676) C* (0677) C* OUTPUT: (0678) C* S0- VALUE OF THE QUADRATIC FORM OF WEIGHTED RESIDUALS (0679) C* V- RESIDUALS (0680) C* (0681) C* (0682) C* WRITTEN BY: (0683) C* R.R. STEEVES, (0684) C* (0685) C*********************************************************************** (0686) IMPLICIT REAL*8(A-H,O-Z) (0687) DIMENSION IOB(130,4),A(130,6),X(90,1),W(130),WX(60), (0688) @ ICA(130,6),V(160,1),ICP(121),SPX(60,60),DOBR(130,4) (0689) (0690) COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR (0691) (0692) NOBS = NO (0693) NV1 = NV (0694) NPG = NP (0695) S0=0.D0 (0696) I=1 (0697) 10 IG=IOB(I,1) (0698) GOTO(1,3,1,1),IG (0699) C COMPUTE DISTANCE, ANGLE AND AZIMUTH RESIDUALS (0700) 1 W1=0.D0 (0701) DO 2 J=1,6 (0702) IF(ICA(I,J).EQ.0)GOTO2 (0703) W1=W1-A(I,J)*X(ICA(I,J),1) (0704) 2 CONTINUE (0705) V(I,1)=W(I)+W1 (0706) S0=S0+V(I,1)**2/DOBR(I,1)**2 (0707) I=I+1 (0708) GOTO24 (0709) C COMPUTE DIRECTION RESIDUALS (0710) 3 II=I+20 (0711) DO 4 J=I,II (0712) M=J (0713) IF(IOB(J,1).EQ.-2)GOTO5 (0714) 4 CONTINUE (0715) 5 NUM=M-I+1 (0716) SUM=0.D0 (0717) DO 7 J=I,M (0718) SUM=SUM+1.D0/DOBR(J,1)**2 (0719) W1=0.D0 (0720) DO 6 K=1,4 (0721) IF(ICA(J,K).EQ.0)GOTO6 (0722) W1=W1-A(J,K)*X(ICA(J,K),1) (0723) 6 CONTINUE (0724) V(J,1)=W(J)+W1 (0725) 7 CONTINUE (0726) SUM1=0.D0 (0727) DO 8 J=I,M (0728) W1=0.D0 (0729) DO 15 K=1,4 (0730) IF(ICA(J,K).EQ.0)GOTO15 (0731) W1=W1+A(J,K)*X(ICA(J,K),1) (0732) 15 CONTINUE (0733) W1=(W1-W(J))/DOBR(J,1)**2 (0734) SUM1=SUM1+W1 (0735) 8 CONTINUE (0736) SUM2=SUM1/SUM (0737) DO 9 J=I,M (0738) 9 V(J,1)=V(J,1)+SUM2 (0739) DO 13 J=I,M (0740) 13 S0=S0+V(J,1)**2/DOBR(J,1)**2 (0741) I=I+NUM (0742) 24 IF(I.LE.NO)GOTO10 (0743) IF(NP.EQ.0)GOTO14 (0744) NP2=NP*2 (0745) DO 11 J=1,NP2 (0746) IF(ICP(J).EQ.0)GOTO20 (0747) V(NO+J,1)=WX(J)-X(ICP(J),1) (0748) GOTO11 (0749) 20 V(NO+J,1)=WX(J) (0750) 11 CONTINUE (0751) DO 12 J=1,NP2 (0752) DO 12 K=1,NP2 (0753) 12 S0=S0+V(NO+J,1)*V(NO+K,1)*SPX(J,K) (0754) 14 RETURN (0755) END PROGRAM SIZE: PROCEDURE - 000762 LINKAGE - 000104 STACK - 000076 A D /COM5/ 001010 0687S 0690S 0703 0722 0731 DOBR D /COM5/ 046365 0687S 0690S 0706 0718 0733 0740 I I LINKAGE 000400 0696M 0697 0702 0703 0705 0706 0707M 0710 0711 0715 0717 0727 0737 0739 0741M 0742 ICA I /COM5/ 010460 0687S 0690S 0702 0703 0721 0722 0730 0731 ICP I /COM5/ 012074 0687S 0690S 0746 0747 IG I LINKAGE 000401 0697M 0698 II I LINKAGE 000406 0710M 0711 IOB I /COM5/ 000000 0687S 0690S 0697 0713 J I LINKAGE 000402 0701M 0702 0703 0711M 0712 0713 0717M 0718 0721 0722 0724 0727M 0730 0731 0733 0737M 0738 0739M 0740 0745M 0746 0747 0749 0751M 0753 K I LINKAGE 000412 0720M 0721 0722 0729M 0730 0731 0752M 0753 M I LINKAGE 000407 0712M 0715 0717 0727 0737 0739 NO I /COM5/ 052425 0690S 0692 0742 0747 0749 0753 NOBS I ARGUMENT 000044 0667S 0692M NP I /COM5/ 052427 0690S 0694 0743 0744 NP2 I LINKAGE 000414 0744M 0745 0751 0752 NPG I ARGUMENT 000060 0667S 0694M NUM I LINKAGE 000411 0715M 0741 NV I /COM5/ 052426 0690S 0693 NV1 I ARGUMENT 000055 0667S 0693M S0 D ARGUMENT 000063 0667S 0695M 0706M 0740M 0753M SPX D /COM5/ 012265 0687S 0690S 0753 SUM D LINKAGE 000462 0716M 0718M 0736 SUM1 D LINKAGE 000466 0726M 0734M 0736 SUM2 D LINKAGE 000472 0736M 0738 V D ARGUMENT 000052 0667S 0687S 0705M 0706 0724M 0738M 0740 0747M 0749M 0753 W D /COM5/ 007070 0687S 0690S 0705 0724 0733 W1 D LINKAGE 000446 0700M 0703M 0705 0719M 0722M 0724 0728M 0731M 0733M 0734 WX D /COM5/ 010100 0687S 0690S 0747 0749 X D ARGUMENT 000047 0667S 0687S 0703 0722 0731 0747 $1 000035 0698 0700D $10 000023 0697D 0742 $11 000653 0745 0748 0750D $12 000665 0751 0752 0753D $13 000506 0739 0740D $14 000747 0743 0754D $15 000407 0729 0730 0732D $2 000103 0701 0702 0704D $20 000632 0746 0749D $24 000552 0708 0742D $3 000155 0698 0710D $4 000171 0711 0714D $5 000177 0713 0715D $6 000277 0720 0721 0723D $7 000326 0717 0725D $8 000441 0727 0735D $9 000457 0737 0738D 0000 ERRORS [FTN-REV18.2] (0756) (0757) SUBROUTINE CPXPAR(CPXX,X,NU,NU2,NELIM,MT) (0758) (0759) C CONVERTS REAL INTO COMPLEX PARAMETER VECTOR, SETS ELIMINATED (0760) C COEFFICIENTS TO ZERO, REARRANGES COV.-MATRIX OF THESE COEFFICIENTS (0761) (0762) INTEGER*2 (0763) I IADR(240), (0764) N NELIM(3) (0765) (0766) REAL*8 (0767) C CX(240,240), (0768) C CXR, (0769) X X(240), (0770) X XR (0771) (0772) COMPLEX*8 (0773) C CPXX(120) (0774) (0775) COMMON /COM2/ CX (0776) (0777) NRC = NU2*MT (0778) NCC = NU*MT (0779) NU22 = NU*2 (0780) NRC2 = NU22*MT (0781) (0782) J=1 (0783) K=1 (0784) 1 DO 2 IT=1,MT (0785) 3 DO 4 I=1,NU22 (0786) IADR(J) = K (0787) 5 DO 6 IEL=1,3 (0788) IF(NELIM(IEL).NE.0.AND.I.EQ.IEL) IADR(J) = 0 (0789) 6 CONTINUE (0790) IF(IADR(J).NE.0) K=K+1 (0791) J=J+1 (0792) 4 CONTINUE (0793) 2 CONTINUE (0794) (0795) 11 DO 12 I1=1,NRC2 (0796) I=NRC2+1-I1 (0797) XR = 0.D0 (0798) L = IADR(I) (0799) IF(L.NE.0) XR = X(L) (0800) X(I) = XR (0801) 13 DO 14 I2=1,NRC2 (0802) J=NRC2+1-I2 (0803) CXR = 0.D0 (0804) K = IADR(J) (0805) IF(K.NE.0) CXR = CX(L,K) (0806) CX(I,J) = CXR (0807) 14 CONTINUE (0808) 12 CONTINUE (0809) (0810) 9 DO 10 I=1,NRC2 (0811) I2=2*I (0812) I1=I2-1 (0813) CPXX(I) = CMPLX(SNGL(X(I1)),SNGL(X(I2))) (0814) 10 CONTINUE (0815) RETURN (0816) END PROGRAM SIZE: PROCEDURE - 000410 LINKAGE - 000436 STACK - 000100 CMPLX C EXTERNAL 000000 0813 CPXX C ARGUMENT 000044 0757S 0772S 0813M CX D /COM2/ 000000 000000 0766S 0775S 0805 0806M CXR D LINKAGE 001024 0766S 0803M 0805M 0806 I I LINKAGE 000407 0785M 0788 0796M 0798 0800 0806 0810M 0811 0813 I1 I LINKAGE 000412 0795M 0796 0812M 0813 I2 I LINKAGE 000414 0801M 0802 0811M 0812 0813 IADR I LINKAGE 000436 0762S 0786M 0788M 0790 0798 0804 IEL I LINKAGE 000410 0787M 0788 IT I LINKAGE 000406 0784M J I LINKAGE 000404 0782M 0786 0788 0790 0791M 0802M 0804 0806 K I LINKAGE 000405 0783M 0786 0790M 0804M 0805 L I LINKAGE 000413 0798M 0799 0805 MT I ARGUMENT 000063 0757S 0777 0778 0780 0784 NCC I LINKAGE 000401 0778M NELIM I ARGUMENT 000060 0757S 0762S 0788 NRC I LINKAGE 000400 0777M NRC2 I LINKAGE 000403 0780M 0795 0796 0801 0802 0810 NU I ARGUMENT 000052 0757S 0778 0779 NU2 I ARGUMENT 000055 0757S 0777 NU22 I LINKAGE 000402 0779M 0780 0785 SNGL R EXTERNAL 000000 0813 X D ARGUMENT 000047 0757S 0766S 0799 0800M 0813A XR D LINKAGE 001016 0766S 0797M 0799M 0800 $1 000030 0784D $10 000366 0810 0814D $11 000123 0795D $12 000271 0795 0808D $13 000174 0801D $14 000263 0801 0807D $2 000114 0784 0793D $3 000032 0785D $4 000106 0785 0792D $5 000040 0787D $6 000067 0787 0789D $9 000277 0810D 0000 ERRORS [FTN-REV18.2] (0817) (0818) SUBROUTINE SIGMAS(SIGDA,SIGCHI,SIGPSI,CDA,CCHIPS) (0819) (0820) C VARIANCE OF DISPLACEMENT COMPONENTS AND STRAIN QUANTITIES (0821) (0822) REAL*8 (0823) C CCHIPS(4,4), (0824) C CDA(2,2) (0825) (0826) REAL *4 (0827) S SIG, (0828) S SIGCHI(2),SIGDA(2),SIGPSI(2) (0829) (0830) 1 DO 2 I=1,2 (0831) SIG = CDA(I,I) (0832) IF(SIG.LT.0.) SIG = 1.E30 (0833) SIGDA(I) = SQRT(SIG) (0834) SIG = CCHIPS(I,I) (0835) IF(SIG.LT.0.) SIG = 1.E30 (0836) SIGCHI(I) = SQRT(SIG) (0837) SIG = CCHIPS(I+2,I+2) (0838) IF(SIG.LT.0.) SIG = 1.E30 (0839) SIGPSI(I) = SQRT(SIG) (0840) 2 CONTINUE (0841) (0842) RETURN (0843) END PROGRAM SIZE: PROCEDURE - 000200 LINKAGE - 000026 STACK - 000070 CCHIPS D ARGUMENT 000056 0818S 0822S 0834 0837 CDA D ARGUMENT 000053 0818S 0822S 0831 I I LINKAGE 000400 0830M 0831 0833 0834 0836 0837 0839 SIG R LINKAGE 000422 0826S 0831M 0832M 0833A 0834M 0835M 0836A 0837M 0838M 0839A SIGCHI R ARGUMENT 000045 0818S 0826S 0836M SIGDA R ARGUMENT 000042 0818S 0826S 0833M SIGPSI R ARGUMENT 000050 0818S 0826S 0839M SQRT R EXTERNAL 000000 0833 0836 0839 SQRT$X J EXTERNAL 000000 0840 $1 000001 0830D $2 000156 0830 0840D 0000 ERRORS [FTN-REV18.2] (0844) (0845) SUBROUTINE CPLXPO(Z,P,P0,SCALP,NP,NFIX) (0846) C COMPUTES COMPLEX POSITIONS AND DISPERSION PARAMETERS (0847) (0848) INTEGER*2 (0849) N NP /* NUMBER OF POINTS (0850) (0851) REAL*8 (0852) P P(30,2),P0(2), (0853) S SCALP, (0854) S SXY(2), (0855) X XY(2),XYMIN(2),XYMAX(2) (0856) (0857) COMPLEX*8 (0858) Z Z(30) (0859) (0860) DATA (0861) S SXY/2*0.D0/, (0862) X XYMIN,XYMAX/2*1.D20,2*-1.D20/ (0863) (0864) C DISPERSION PARAMETERS (0865) 1 DO 2 I=1,NP (0866) 3 DO 4 J=1,2 (0867) XY(J) = P(I,J) (0868) SXY(J) = SXY(J) + XY(J) (0869) XYMIN(J) = DMIN1(XYMIN(J),XY(J)) (0870) XYMAX(J) = DMAX1(XYMAX(J),XY(J)) (0871) 4 CONTINUE (0872) 2 CONTINUE (0873) (0874) 11 IF(NFIX.NE.0) GOTO 12 (0875) 5 DO 6 J=1,2 (0876) P0(J) = SXY(J)/NP (0877) 6 CONTINUE (0878) 12 CONTINUE (0879) SCALP = DMAX1(XYMAX(1)-P0(1),P0(1)-XYMIN(1),XYMAX(2)-P0(2),P0(2)- (0880) 1 XYMIN(2)) (0881) (0882) C COMPLEX POSITIONS (0883) 7 DO 8 I=1,NP (0884) Z(I) = CMPLX(SNGL((P(I,1)-P0(1))/SCALP),SNGL((P(I,2)-P0(2))/ (0885) 1 SCALP)) (0886) 8 CONTINUE (0887) RETURN (0888) END PROGRAM SIZE: PROCEDURE - 000366 LINKAGE - 000100 STACK - 000120 CMPLX C EXTERNAL 000000 0884 DMAX1 D EXTERNAL 000000 0870 0879 DMIN1 D EXTERNAL 000000 0869 I I LINKAGE 000400 0865M 0867 0883M 0884 J I LINKAGE 000401 0866M 0867 0868 0869 0870 0875M 0876 NFIX I ARGUMENT 000061 0845S 0874 NP I ARGUMENT 000056 0845S 0848S 0865 0876 0883 P D ARGUMENT 000045 0845S 0851S 0867 0884 P0 D ARGUMENT 000050 0845S 0851S 0876M 0879 0884 SCALP D ARGUMENT 000053 0845S 0851S 0879M 0884 SNGL R EXTERNAL 000000 0884 SXY D LINKAGE 000424 0851S 0860I 0868M 0876 XY D LINKAGE 000454 0851S 0867M 0868 0869A 0870A XYMAX D LINKAGE 000444 0851S 0860I 0870M 0879 XYMIN D LINKAGE 000434 0851S 0860I 0869M 0879 Z C ARGUMENT 000042 0845S 0857S 0884M $1 000001 0865D $11 000123 0874D $12 000161 0874 0878D $2 000114 0865 0872D $3 000003 0866D $4 000106 0866 0871D $5 000127 0875D $6 000153 0875 0877D $7 000233 0883D $8 000343 0883 0886D 0000 ERRORS [FTN-REV18.2] (0889) (0890) SUBROUTINE DELROW(AEL,A,K,NDIM,MDIM,N,M) (0891) (0892) C ELIMINATE ROW K OF MATRIX A (REAL*8) (0893) (0894) INTEGER*2 I,J,JJ,K,N,NDIM,M,MDIM,M1 (0895) (0896) REAL*8 (0897) A A(NDIM,MDIM), (0898) A AEL(NDIM,MDIM) (0899) (0900) 8 IF(K.EQ.0.OR.K.GT.M) GOTO 9 (0901) M = M-1 (0902) 1 DO 2 J=1,M (0903) JJ=J (0904) IF(J.GE.K)JJ=J+1 (0905) 3 DO 4 I=1,N (0906) AEL(I,J) = A(I,JJ) (0907) 4 CONTINUE (0908) 2 CONTINUE (0909) 9 CONTINUE (0910) RETURN (0911) END PROGRAM SIZE: PROCEDURE - 000144 LINKAGE - 000024 STACK - 000100 A D ARGUMENT 000047 0890S 0896S 0906 AEL D ARGUMENT 000044 0890S 0896S 0906M I I LINKAGE 000402 0894S 0905M 0906 J I LINKAGE 000400 0894S 0902M 0903 0904 0906 JJ I LINKAGE 000401 0894S 0903M 0904M 0906 K I ARGUMENT 000052 0890S 0894S 0900 0904 M I ARGUMENT 000066 0890S 0894S 0900 0901M 0902 N I ARGUMENT 000063 0890S 0894S 0905 $1 000023 0902D $2 000127 0902 0908D $3 000035 0905D $4 000120 0905 0907D $8 000001 0900D $9 000136 0900 0909D 0000 ERRORS [FTN-REV18.2] (0912) (0913) SUBROUTINE TIMREG(IDAT,ITIME,IUSER) (0914) C% ZEIT IN [HR.MIN] , DATUM IN [DY.MT.YR] , INITIALEN DES BENUETZERS (0915) C% REGISTRIEREN (0916) INTEGER*2 ITIMDA(15),IDAT(3),ITIME(2),IUSER(3) (0917) (0918) CALL TIMDAT(ITIMDA,15) (0919) IDAT(1) = ITIMDA(2) (0920) IDAT(2) = ITIMDA(1) (0921) IDAT(3) = ITIMDA(3) (0922) ITIME(1) = ITIMDA(4)/60 (0923) ITIME(2) = ITIMDA(4)-ITIME(1)*60 (0924) IUSER(1) = ITIMDA(13) (0925) IUSER(2) = ITIMDA(14) (0926) IUSER(3) = ITIMDA(15) (0927) RETURN (0928) END PROGRAM SIZE: PROCEDURE - 000120 LINKAGE - 000044 STACK - 000056 IDAT I ARGUMENT 000042 0913S 0916S 0919M 0920M 0921M ITIMDA I LINKAGE 000422 0916S 0918A 0919 0920 0921 0922 0923 0924 0925 0926 ITIME I ARGUMENT 000045 0913S 0916S 0922M 0923M IUSER I ARGUMENT 000050 0913S 0916S 0924M 0925M 0926M TIMDAT R EXTERNAL 000000 0918 0000 ERRORS [FTN-REV18.2] (0929) $$$ SUBROUTINE RDNET(INET,NP,NP1,P0,NAME,P,NFIX,LPRINT,NONET,NUNET, (0001) SUBROUTINE RDNET(INET,NP,NP1,P0,NAME,P,NFIX,LPRINT,NONET,NUNET, (0002) 1 NH,NUH,NNOR,NTIT) (0003) (0004) C READ STORED ADJUSTMENT DATA OF NETWORKS FROM INPUTFILE (0005) (0006) INTEGER*2 (0007) I INET, (0008) I ITIM(15), (0009) N NAME(30,4), (0010) N NAMFIX(4), (0011) N NONET(50), (0012) N NUNET(50), (0013) N NTIT(40) (0014) (0015) REAL*8 (0016) P P0(2), (0017) P P(30,2) (0018) (0019) LOGICAL LPRINT (0020) (0021) NP = 0 (0022) READ(5,5000)(NTIT(J),J=1,40) (0023) 5000 FORMAT(40A2) (0024) IF(INET.EQ.1)WRITE(6,6901) (0025) WRITE(6,6014)INET,(NTIT(J),J=1,40) (0026) 6014 FORMAT(1H /' NETWORK # ',I2,2X,': ',40A2//) (0027) READ(5,5051) NFIX (0028) 5051 FORMAT(I3) (0029) IF(NFIX.GT.1)GOTO 902 (0030) IF(NFIX.EQ.1)READ(5,5001,END=901)NAMFIX,P0 (0031) (0032) IF(INET.EQ.1)WRITE(6,6005) (0033) 6005 FORMAT(1H //' NAME',11X,'POSITION'/16X,'X',12X,'Y'//) (0034) 1 DO 2 I=1,30 (0035) READ(5,5001,END=901)(NAME(I,J),J=1,4),(P(I,J),J=1,2) (0036) 5001 FORMAT(4A2,2F15.4) (0037) 3 IF(NAME(I,1).EQ.'$$') GOTO 4 (0038) IF(INET.EQ.1)WRITE(6,6001)(NAME(I,J),J=1,4),(P(I,J),J=1,2) (0039) 6001 FORMAT(1H ,4A2,2F13.4) (0040) 2 CONTINUE (0041) NP = 1 (0042) 4 CONTINUE (0043) (0044) C READ NUMBER OF OBSERVATIONS, UNKNOWNS AND DEGREES OF FREEDOM (0045) READ(5,5002) NNO,NNP,NN,NND,NIDF,NZERO,NH,NUH (0046) 5002 FORMAT(8I4) (0047) (0048) NONET(INET) = NNO + 2*NNP (0049) NUNET(INET) = NND + NZERO (0050) (0051) NP = NP + I -1 (0052) NP1 = NP (0053) 51 IF(NFIX.NE.1) GOTO 52 (0054) NP1 = NP + 1 (0055) 61 DO 62 I=1,4 (0056) NAME(NP1,I) = NAMFIX(I) (0057) 62 CONTINUE (0058) P(NP1,1) = P0(1) (0059) P(NP1,2) = P0(2) (0060) 52 CONTINUE (0061) (0062) C READ NORMAL EQUATIONS (0063) NNOR = 2 * NP + NUH (0064) CALL TIMDAT(ITIM,15) (0065) WRITE(1,1691)(ITIM(JT),JT=4,10) (0066) 1691 FORMAT('#3',7I6) (0067) CALL NREAD(INET,NP,NNOR,5,LPRINT) (0068) (0069) C READ DESIGN MATRICES AND STORE THEM (0070) CALL TIMDAT(ITIM,15) (0071) WRITE(1,1692)(ITIM(JT),JT=4,10) (0072) 1692 FORMAT('#4',7I6) (0073) CALL AREAD(INET,5) (0074) C IF(LPRINT) CALL AWRIT(INET,6) (0075) CALL TIMDAT(ITIM,15) (0076) WRITE(1,1693)(ITIM(JT),JT=4,10) (0077) 1693 FORMAT('#5',7I6) (0078) C CALL ASTOR1(INET) (0079) CALL AWRITB(INET,8) (0080) RETURN (0081) (0082) C NEW PAGE COMMAND (0083) 6901 FORMAT(' '/) (0084) (0085) C ERROR MESSAGES (0086) 901 CONTINUE (0087) WRITE(1,1901) (0088) 1901 FORMAT('***ERROR IN RDNET***'/) (0089) RETURN (0090) 902 CONTINUE (0091) WRITE(1,1902) (0092) 1902 FORMAT('***MORE THAN 1 FIXED STATION***'/) (0093) RETURN (0094) END PROGRAM SIZE: PROCEDURE - 001400 LINKAGE - 000114 STACK - 000120 AREAD R EXTERNAL 000000 0073 AWRITB R EXTERNAL 000000 0079 I I LINKAGE 000410 0034M 0035 0037 0038 0051 0055M 0056 INET I ARGUMENT 000042 0001S 0006S 0024 0025 0032 0038 0048 0049 0067A 0073A 0079A ITIM I LINKAGE 000446 0006S 0064A 0065 0070A 0071 0075A 0076 J I LINKAGE 000401 0022M 0025M 0035M 0038M JT I LINKAGE 000423 0065M 0071M 0076M LPRINT L ARGUMENT 000067 0001S 0019S 0067A NAME I ARGUMENT 000056 0001S 0006S 0035M 0037 0038 0056M NAMFIX I LINKAGE 000466 0006S 0030M 0056 NFIX I ARGUMENT 000064 0001S 0027M 0029 0030 0053 NH I ARGUMENT 000100 0001S 0045M NIDF I LINKAGE 000420 0045M NN I LINKAGE 000416 0045M NND I LINKAGE 000417 0045M 0049 NNO I LINKAGE 000414 0045M 0048 NNOR I ARGUMENT 000106 0001S 0063M 0067A NNP I LINKAGE 000415 0045M 0048 NONET I ARGUMENT 000072 0001S 0006S 0048M NP I ARGUMENT 000045 0001S 0021M 0041M 0051M 0052 0054 0063 0067A NP1 I ARGUMENT 000050 0001S 0052M 0054M 0056 0058 0059 NREAD I EXTERNAL 000000 0067 NTIT I ARGUMENT 000111 0001S 0006S 0022M 0025 NUH I ARGUMENT 000103 0001S 0045M 0063 NUNET I ARGUMENT 000075 0001S 0006S 0049M NZERO I LINKAGE 000421 0045M 0049 P D ARGUMENT 000061 0001S 0015S 0035M 0038 0058M 0059M P0 D ARGUMENT 000053 0001S 0015S 0030M 0058 0059 TIMDAT R EXTERNAL 000000 0064 0070 0075 $1 000302 0034D $1691 001115 0065 0066D $1692 001200 0071 0072D $1693 001255 0076 0077D $1901 001306 0087 0088D $1902 001335 0091 0092D $2 000564 0034 0040D $3 000424 0037D $4 000575 0037 0042D $5000 000041 0022 0023D $5001 000415 0030 0035 0036D $5002 000665 0045 0046D $5051 000167 0027 0028D $51 000733 0053D $52 001045 0053 0060D $6001 000553 0038 0039D $6005 000251 0032 0033D $6014 000125 0025 0026D $61 000745 0055D $62 000775 0055 0057D $6901 001272 0024 0083D $901 001276 0030 0035 0086D $902 001325 0029 0090D 0000 ERRORS [FTN-REV18.2] (0095) (0096) SUBROUTINE NREAD(INET,NP,N12,IFIL,LPRINT) (0097) (0098) C READ NORMAL EQUATIONS OF NETWORKS FROM INPUT FILE (0099) (0100) REAL*8 (0101) N NI(90,90), (0102) U UI(90,1) (0103) (0104) LOGICAL LPRINT (0105) (0106) COMMON /COM3/NI,UI (0107) (0108) (0109) DATA (0110) N N12DIM/90/ (0111) (0112) 73 DO 74 I=1,N12 (0113) JSTART = I (0114) READ(IFIL,5052)(NI(I,J),J=JSTART,N12) (0115) 5052 FORMAT(4D20.13) (0116) 74 CONTINUE (0117) (0118) 75 DO 76 I=1,N12 (0119) READ(IFIL,5053)UI(I,1) (0120) 5053 FORMAT(D20.13) (0121) 76 CONTINUE (0122) (0123) (0124) C DUPLICATE ELEMENTS IN UPPER HALF FILLED SYMMETRIC MATRIX (0125) CALL DMTSYM(NI,N12DIM,N12) (0126) 81 IF(.NOT.LPRINT) GOTO 82 (0127) WRITE(6,6111) (0128) 6111 FORMAT(' NI'/) (0129) CALL DMTOUT(NI,N12DIM,N12DIM,N12,N12,6,'D','5') (0130) WRITE(6,6121) (0131) 6121 FORMAT(' UI'/) (0132) CALL DMTOUT(UI,N12DIM,1,N12,1,6,'D','5') (0133) 82 CONTINUE (0134) (0135) RETURN (0136) END PROGRAM SIZE: PROCEDURE - 000236 LINKAGE - 000056 STACK - 000064 DMTOUT R EXTERNAL 000000 0129 0132 DMTSYM R EXTERNAL 000000 0125 I I LINKAGE 000401 0112M 0113 0114 0118M 0119 IFIL I ARGUMENT 000053 0096S 0114 0119 J I LINKAGE 000403 0114M JSTART I LINKAGE 000402 0113M 0114 LPRINT L ARGUMENT 000056 0096S 0104S 0126 N12 I ARGUMENT 000050 0096S 0112 0114 0118 0125A 0129A 0132A N12DIM I LINKAGE 000400 0109I 0125A 0129A 0132A NI D /COM3/ 000000 0100S 0106S 0114M 0125A 0129A UI D /COM3/ 077220 0100S 0106S 0119M 0132A $5052 000044 0114 0115D $5053 000107 0119 0120D $6111 000147 0127 0128D $6121 000206 0130 0131D $73 000001 0112D $74 000052 0112 0116D $75 000061 0118D $76 000114 0118 0121D $81 000133 0126D $82 000235 0126 0133D 0000 ERRORS [FTN-REV18.2] (0137) (0138) SUBROUTINE NWRIT(INET,NP,N12,IFIL) (0139) (0140) C WRITE NORMAL EQUATIONS OF NETWORKS (0141) (0142) REAL*8 (0143) N NI(90,90), (0144) U UI(90,1) (0145) (0146) COMMON /COM3/NI,UI (0147) 73 DO 74 I=1,N12 (0148) JSTART = I (0149) WRITE(IFIL,5052)(NI(I,J),J=JSTART,N12) (0150) 5052 FORMAT(4D20.13) (0151) 74 CONTINUE (0152) (0153) 75 DO 76 I=1,N12 (0154) WRITE(IFIL,5053)UI(I,1) (0155) 5053 FORMAT(D20.13) (0156) 76 CONTINUE (0157) (0158) RETURN (0159) END PROGRAM SIZE: PROCEDURE - 000124 LINKAGE - 000040 STACK - 000060 I I LINKAGE 000400 0147M 0148 0149 0153M 0154 IFIL I ARGUMENT 000053 0138S 0149 0154 J I LINKAGE 000402 0149M JSTART I LINKAGE 000401 0148M 0149 N12 I ARGUMENT 000050 0138S 0147 0149 0153 NI D /COM3/ 000000 0142S 0146S 0149 UI D /COM3/ 077220 0142S 0146S 0154 $5052 000044 0149 0150D $5053 000107 0154 0155D $73 000001 0147D $74 000052 0147 0151D $75 000061 0153D $76 000114 0153 0156D 0000 ERRORS [FTN-REV18.2] (0160) (0161) SUBROUTINE AWRIT(INET,IFI) (0162) (0163) C WRITE DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS ON PUNCH- (0164) C FILE (0165) (0166) IMPLICIT REAL*8 (A-H,O-Z) (0167) DIMENSION IOB(130,4),A(130,6),W(130),WX(60),ICA(130,6),ICP(121), (0168) 1 SPX(60,60),DOBR(130,4) (0169) (0170) COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR (0171) (0172) WRITE(IFI,5201)NO,NP,NV,NR (0173) 5201 FORMAT(4I4) (0174) (0175) 1 DO 2 I=1,NO (0176) WRITE(IFI,5202)(IOB(I,J),J=1,4) (0177) WRITE(IFI,5203)(A(I,J),J=1,6) (0178) WRITE(IFI,5203)W(I) (0179) WRITE(IFI,5202)(ICA(I,J),J=1,6) (0180) WRITE(IFI,5203)(DOBR(I,J),J=1,4) (0181) 5202 FORMAT(I5) (0182) 5203 FORMAT(D20.13) (0183) 2 CONTINUE (0184) IF(NR.LE.0) GOTO 8 (0185) 11 DO 12 I=1,NR (0186) WRITE(IFI,5202) ICP(I) (0187) 12 CONTINUE (0188) 3 DO 4 I=1,NNOR (0189) WRITE(IFI,5203)WX(I),(SPX(I,J),J=1,NNOR) (0190) 4 CONTINUE (0191) 8 CONTINUE (0192) RETURN (0193) END PROGRAM SIZE: PROCEDURE - 000432 LINKAGE - 000072 STACK - 000052 A D /COM5/ 001010 0167S 0170S 0177 DOBR D /COM5/ 046365 0167S 0170S 0180 I I LINKAGE 000401 0175M 0176 0177 0178 0179 0180 0185M 0186 0188M 0189 ICA I /COM5/ 010460 0167S 0170S 0179 ICP I /COM5/ 012074 0167S 0170S 0186 IFI I ARGUMENT 000045 0161S 0172 0176 0177 0178 0179 0180 0186 0189 IOB I /COM5/ 000000 0167S 0170S 0176 J I LINKAGE 000402 0176M 0177M 0179M 0180M 0189M NNOR I /COM5/ 052430 0170S 0188 0189 NO I /COM5/ 052425 0170S 0172 0175 NP I /COM5/ 052427 0170S 0172 NR I /COM5/ 052431 0170S 0172 0184 0185 NV I /COM5/ 052426 0170S 0172 SPX D /COM5/ 012265 0167S 0170S 0189 W D /COM5/ 007070 0167S 0170S 0178 WX D /COM5/ 010100 0167S 0170S 0189 $1 000045 0175D $11 000310 0185D $12 000335 0185 0187D $2 000275 0175 0183D $3 000344 0188D $4 000422 0188 0190D $5201 000041 0172 0173D $5202 000265 0176 0179 0181D 0186 $5203 000270 0177 0178 0180 0182D 0189 $8 000431 0184 0191D 0000 ERRORS [FTN-REV18.2] (0194) (0195) SUBROUTINE AWRITB(INET,IFI) (0196) (0197) C WRITE DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS ON PUNCH- (0198) C FILE (0199) (0200) IMPLICIT REAL*8 (A-H,O-Z) (0201) DIMENSION IOB(130,4),A(130,6),W(130),WX(60),ICA(130,6),ICP(121), (0202) 1 SPX(60,60),DOBR(130,4) (0203) (0204) COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR (0205) (0206) WRITE(IFI)NO,NP,NV,NR (0207) 5201 FORMAT(4I4) (0208) 1 DO 2 I=1,NO (0209) WRITE(IFI)(IOB(I,J),J=1,4) (0210) WRITE(IFI)(A(I,J),J=1,6) (0211) WRITE(IFI)W(I) (0212) WRITE(IFI)(ICA(I,J),J=1,6) (0213) WRITE(IFI)(DOBR(I,J),J=1,4) (0214) 2 CONTINUE (0215) IF(NR.LE.0) GOTO 8 (0216) 11 DO 12 I=1,NR (0217) WRITE(IFI) ICP(I) (0218) 12 CONTINUE (0219) 3 DO 4 I=1,NNOR (0220) WRITE(IFI)WX(I),(SPX(I,J),J=1,NNOR) (0221) 4 CONTINUE (0222) 8 CONTINUE (0223) RETURN (0224) END PROGRAM SIZE: PROCEDURE - 000402 LINKAGE - 000072 STACK - 000052 A D /COM5/ 001010 0201S 0204S 0210 DOBR D /COM5/ 046365 0201S 0204S 0213 I I LINKAGE 000401 0208M 0209 0210 0211 0212 0213 0216M 0217 0219M 0220 ICA I /COM5/ 010460 0201S 0204S 0212 ICP I /COM5/ 012074 0201S 0204S 0217 IFI I ARGUMENT 000045 0195S 0206 0209 0210 0211 0212 0213 0217 0220 IOB I /COM5/ 000000 0201S 0204S 0209 J I LINKAGE 000402 0209M 0210M 0212M 0213M 0220M NNOR I /COM5/ 052430 0204S 0219 0220 NO I /COM5/ 052425 0204S 0206 0208 NP I /COM5/ 052427 0204S 0206 NR I /COM5/ 052431 0204S 0206 0215 0216 NV I /COM5/ 052426 0204S 0206 SPX D /COM5/ 012265 0201S 0204S 0220 W D /COM5/ 007070 0201S 0204S 0211 WX D /COM5/ 010100 0201S 0204S 0220 $1 000043 0208D $11 000264 0216D $12 000307 0216 0218D $2 000251 0208 0214D $3 000316 0219D $4 000372 0219 0221D $5201 000037 0207D $8 000401 0215 0222D 0000 ERRORS [FTN-REV18.2] (0225) (0226) SUBROUTINE AREAD(INET,IFI) (0227) (0228) C READ DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS FROM PUNCH- (0229) C FILE (0230) (0231) IMPLICIT REAL*8 (A-H,O-Z) (0232) DIMENSION IOB(130,4),A(130,6),W(130),WX(60),ICA(130,6),ICP(121), (0233) 1 SPX(60,60),DOBR(130,4) (0234) (0235) COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR (0236) (0237) READ(IFI,5201)NO,NP,NV,NR (0238) C WRITE(1,5201)NO,NP,NV,NR (0239) 5201 FORMAT(4I4) (0240) (0241) 1 DO 2 I=1,NO (0242) READ(IFI,5202)(IOB(I,J),J=1,4) (0243) READ(IFI,5203)(A(I,J),J=1,6) (0244) READ(IFI,5203)W(I) (0245) READ(IFI,5202)(ICA(I,J),J=1,6) (0246) READ(IFI,5203)(DOBR(I,J),J=1,4) (0247) 5202 FORMAT(I5) (0248) 5203 FORMAT(D20.13) (0249) 2 CONTINUE (0250) IF(NR.LE.0)GOTO 8 (0251) 11 DO 12 I=1,NR (0252) READ(IFI,5202) ICP(I) (0253) 12 CONTINUE (0254) 3 DO 4 I=1,NNOR (0255) READ(IFI,5203)WX(I),(SPX(I,J),J=1,NNOR) (0256) 4 CONTINUE (0257) 8 CONTINUE (0258) RETURN (0259) END PROGRAM SIZE: PROCEDURE - 000432 LINKAGE - 000072 STACK - 000052 A D /COM5/ 001010 0232S 0235S 0243M DOBR D /COM5/ 046365 0232S 0235S 0246M I I LINKAGE 000401 0241M 0242 0243 0244 0245 0246 0251M 0252 0254M 0255 ICA I /COM5/ 010460 0232S 0235S 0245M ICP I /COM5/ 012074 0232S 0235S 0252M IFI I ARGUMENT 000045 0226S 0237 0242 0243 0244 0245 0246 0252 0255 IOB I /COM5/ 000000 0232S 0235S 0242M J I LINKAGE 000402 0242M 0243M 0245M 0246M 0255M NNOR I /COM5/ 052430 0235S 0254 0255 NO I /COM5/ 052425 0235S 0237M 0241 NP I /COM5/ 052427 0235S 0237M NR I /COM5/ 052431 0235S 0237M 0250 0251 NV I /COM5/ 052426 0235S 0237M SPX D /COM5/ 012265 0232S 0235S 0255M W D /COM5/ 007070 0232S 0235S 0244M WX D /COM5/ 010100 0232S 0235S 0255M $1 000045 0241D $11 000310 0251D $12 000335 0251 0253D $2 000275 0241 0249D $3 000344 0254D $4 000422 0254 0256D $5201 000041 0237 0239D $5202 000265 0242 0245 0247D 0252 $5203 000270 0243 0244 0246 0248D 0255 $8 000431 0250 0257D 0000 ERRORS [FTN-REV18.2] (0260) (0261) SUBROUTINE AREADB(INET,IFI) (0262) (0263) C READ DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS FROM PUNCH- (0264) C FILE (0265) (0266) IMPLICIT REAL*8 (A-H,O-Z) (0267) DIMENSION IOB(130,4),A(130,6),W(130),WX(60),ICA(130,6),ICP(121), (0268) 1 SPX(60,60),DOBR(130,4) (0269) (0270) COMMON /COM5/IOB,A,W,WX,ICA,ICP,SPX,DOBR,NO,NV,NP,NNOR,NR (0271) (0272) READ(IFI)NO,NP,NV,NR (0273) C WRITE(1,5201)NO,NP,NV,NR (0274) 5201 FORMAT(4I4) (0275) (0276) 1 DO 2 I=1,NO (0277) READ(IFI)(IOB(I,J),J=1,4) (0278) READ(IFI)(A(I,J),J=1,6) (0279) READ(IFI)W(I) (0280) READ(IFI)(ICA(I,J),J=1,6) (0281) READ(IFI)(DOBR(I,J),J=1,4) (0282) 2 CONTINUE (0283) IF(NR.LE.0)GOTO 8 (0284) 11 DO 12 I=1,NR (0285) READ(IFI) ICP(I) (0286) 12 CONTINUE (0287) 3 DO 4 I=1,NNOR (0288) READ(IFI)WX(I),(SPX(I,J),J=1,NNOR) (0289) 4 CONTINUE (0290) 8 CONTINUE (0291) RETURN (0292) END PROGRAM SIZE: PROCEDURE - 000402 LINKAGE - 000072 STACK - 000052 A D /COM5/ 001010 0267S 0270S 0278M DOBR D /COM5/ 046365 0267S 0270S 0281M I I LINKAGE 000401 0276M 0277 0278 0279 0280 0281 0284M 0285 0287M 0288 ICA I /COM5/ 010460 0267S 0270S 0280M ICP I /COM5/ 012074 0267S 0270S 0285M IFI I ARGUMENT 000045 0261S 0272 0277 0278 0279 0280 0281 0285 0288 IOB I /COM5/ 000000 0267S 0270S 0277M J I LINKAGE 000402 0277M 0278M 0280M 0281M 0288M NNOR I /COM5/ 052430 0270S 0287 0288 NO I /COM5/ 052425 0270S 0272M 0276 NP I /COM5/ 052427 0270S 0272M NR I /COM5/ 052431 0270S 0272M 0283 0284 NV I /COM5/ 052426 0270S 0272M SPX D /COM5/ 012265 0267S 0270S 0288M W D /COM5/ 007070 0267S 0270S 0279M WX D /COM5/ 010100 0267S 0270S 0288M $1 000043 0276D $11 000264 0284D $12 000307 0284 0286D $2 000251 0276 0282D $3 000316 0287D $4 000372 0287 0289D $5201 000037 0274D $8 000401 0283 0290D 0000 ERRORS [FTN-REV18.2] (0293) $$$ REAL*8 FUNCTION THETA(T,M) (0001) REAL*8 FUNCTION THETA(T,M) (0002) C ALGEBRAIC TIME POLYNOMIAL WITH LINEAR EPISODES (0003) (0004) REAL*8 T,BE(5,2) (0005) (0006) COMMON /EPISOD/ BE,N (0007) (0008) THETA = 1.D0 (0009) IF(M.EQ.0) RETURN (0010) (0011) 3 IF(M.GT.N) GOTO 4 (0012) (0013) 1 DO 2 I=1,M (0014) THETA = THETA * T (0015) 2 CONTINUE (0016) RETURN (0017) (0018) 4 CONTINUE (0019) THETA = 0.D0 (0020) IF(T.GE.BE(M,1).AND.T.LE.BE(M,2)) (0021) 1 THETA=(T-BE(M,1))/(BE(M,2)-BE(M,1)) (0022) IF(T.GT.BE(M,2)) THETA = 1.D0 (0023) RETURN (0024) END PROGRAM SIZE: PROCEDURE - 000130 LINKAGE - 000034 STACK - 000056 BE D /EPISOD/ 000000 0004S 0006S 0020 0022 I I LINKAGE 000400 0013M M I ARGUMENT 000047 0001S 0009 0011 0013 0020 0022 N I /EPISOD/ 000050 0006S 0011 T D ARGUMENT 000044 0001S 0004S 0014 0020 0022 THETA D LINKAGE 000422 0001S 0008M 0014M 0019M 0020M 0022M $1 000022 0013D $2 000032 0013 0015D $3 000014 0011D $4 000042 0011 0018D 0000 ERRORS [FTN-REV18.2] REAL*8 FUNCTION DTHETA(T,M) (0025) REAL*8 FUNCTION DTHETA(T,M) (0026) (0027) C DERIVATIVE OF THE ALGEBRAIC TIME POLYNOMIAL WITH LINEAR EPISODES (0028) (0029) REAL*8 T,T1,BE(5,2) (0030) (0031) COMMON /EPISOD/ BE,N (0032) (0033) DTHETA = 0.D0 (0034) IF(M.EQ.0) RETURN (0035) T1 = 1.D0 (0036) DTHETA = T1 (0037) IF(M.EQ.1) RETURN (0038) (0039) 3 IF(M.GT.N) GOTO 4 (0040) 1 DO 2 I=2,M (0041) T1 = T1 * T (0042) 2 CONTINUE (0043) DTHETA = M * T1 (0044) RETURN (0045) (0046) 4 CONTINUE (0047) DTHETA = 0.D0 (0048) IF(T.GE.BE(M,1).AND.T.LE.BE(M,2)) DTHETA=1.D0/(BE(M,2)-BE(M,1)) (0049) RETURN (0050) END PROGRAM SIZE: PROCEDURE - 000136 LINKAGE - 000042 STACK - 000056 BE D /EPISOD/ 000000 0029S 0031S 0048 DTHETA D LINKAGE 000424 0025S 0033M 0036M 0043M 0047M 0048M I I LINKAGE 000402 0040M M I ARGUMENT 000047 0025S 0034 0037 0039 0040 0043 0048 N I /EPISOD/ 000050 0031S 0039 T D ARGUMENT 000044 0025S 0029S 0041 0048 T1 D LINKAGE 000430 0029S 0035M 0036 0041M 0043 $1 000035 0040D $2 000045 0040 0042D $3 000027 0039D $4 000065 0039 0046D 0000 ERRORS [FTN-REV18.2] (0051) (0052) SUBROUTINE CALPOL(PHI,Z,MDIM,N,M) (0053) (0054) C BASEFUNCTION OF THE GENERALIZED COMPLEX ALGEBRAIC POLYNOMIAL (0055) (0056) INTEGER (0057) N N, /* POWER OF COMPLEX ALGEBRAIC POLYNOMIAL (0058) N NPER(3,2), /* VECTOR OF BEGINNING/ENDING # OF POLYGON VERTICES (0059) M M /* NUMBER OF TERMS (INCLUDING BLOCK MOTIOM TERMS) (0060) (0061) REAL*4 (0062) P PINPOL (0063) (0064) COMPLEX*8 (0065) P P,PHI(1,MDIM), (0066) Z Z, (0067) Z ZP(30) (0068) (0069) (0070) (0071) COMMON /BLOCK/ ZP,NPER (0072) (0073) N1 = N+1 (0074) PHI(1,1) = (0.,0.) (0075) IF(N.LE.0) GOTO 7 (0076) P = (1.,0.) (0077) 1 DO 2 I=1,N (0078) P = P * Z (0079) PHI(1,I) = P (0080) 2 CONTINUE (0081) (0082) 7 IF(M.LE.N) GOTO 8 (0083) 3 DO 4 I=N1,M (0084) IBLOC = I-N (0085) PHI(1,I) = (0.,0.) (0086) PHI(1,I) = (1.,0.) * PINPOL(Z,ZP,NPER(IBLOC,1),NPER(IBLOC,2),3) (0087) 4 CONTINUE (0088) 8 CONTINUE (0089) RETURN (0090) END PROGRAM SIZE: PROCEDURE - 000214 LINKAGE - 000050 STACK - 000070 I I LINKAGE 000401 0077M 0079 0083M 0084 0085 0086 IBLOC I LINKAGE 000402 0084M 0086 M I ARGUMENT 000056 0052S 0056S 0082 0083 N I ARGUMENT 000053 0052S 0056S 0073 0075 0077 0082 0084 N1 I LINKAGE 000400 0073M 0083 NPER I /BLOCK/ 000170 0056S 0071S 0086A P C LINKAGE 000430 0064S 0076M 0078M 0079 PHI C ARGUMENT 000042 0052S 0064S 0074M 0079M 0085M 0086M PINPOL R EXTERNAL 000000 0061S 0086 Z C ARGUMENT 000045 0052S 0064S 0078 0086A ZP C /BLOCK/ 000000 0064S 0071S 0086A $1 000031 0077D $2 000070 0077 0080D $3 000105 0083D $4 000172 0083 0087D $7 000077 0075 0082D $8 000201 0082 0088D 0000 ERRORS [FTN-REV18.2] (0091) (0092) SUBROUTINE DCALPO(PHI,Z,MDIM,N,M) (0093) (0094) C DERIVATIVE OF THE BASEFUNCTION OF THE COMPLEX ALGEBRAIC POLYNOMIAL (0095) (0096) COMPLEX*8 (0097) P P,PHI(1,MDIM), (0098) Z Z (0099) (0100) N1 = N+1 (0101) PHI(1,1) = (0.,0.) (0102) IF(N.EQ.0) GOTO 7 (0103) P = (1.,0.) (0104) PHI(1,1) = P (0105) IF(N.EQ.1) GOTO 7 (0106) 1 DO 2 I=2,N (0107) P = P * Z (0108) PHI(1,I) = I*P (0109) 2 CONTINUE (0110) (0111) 7 IF(M.LE.N) GOTO 8 (0112) 3 DO 4 I=N1,M (0113) PHI(1,I) = (0.,0.) (0114) 4 CONTINUE (0115) 8 CONTINUE (0116) RETURN (0117) END PROGRAM SIZE: PROCEDURE - 000166 LINKAGE - 000040 STACK - 000064 I I LINKAGE 000403 0106M 0108 0112M 0113 M I ARGUMENT 000056 0092S 0111 0112 N I ARGUMENT 000053 0092S 0100 0102 0105 0106 0111 N1 I LINKAGE 000400 0100M 0112 P C LINKAGE 000430 0096S 0103M 0104 0107M 0108 PHI C ARGUMENT 000042 0092S 0096S 0101M 0104M 0108M 0113M Z C ARGUMENT 000045 0092S 0096S 0107 $1 000042 0106D $2 000104 0106 0109D $3 000121 0112D $4 000143 0112 0114D $7 000113 0102 0105 0111D $8 000152 0111 0115D 0000 ERRORS [FTN-REV18.2] (0118) $$$ SUBROUTINE PREDIC(DA,CHI,PSI,CDA,CCHIPS,Z,CPXX,CX,MDIM,MCONF, (0001) SUBROUTINE PREDIC(DA,CHI,PSI,CDA,CCHIPS,Z,CPXX,CX,MDIM,MCONF, (0002) 1 MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1) (0003) (0004) C PREDICTION OF COMPLEX DISPLACEMENTS AND STRAIN COMPONENTS (0005) (0006) REAL*8 (0007) A AK(2,240), (0008) C CX(240,240), (0009) C CXAKT(240,2), (0010) C CDA(2,2), (0011) D D0(2), (0012) D DFACT2, (0013) D DTHETA, (0014) D DTIMN, (0015) A AL(4,240), (0016) C CXALT(240,4), (0017) C CCHIPS(4,4), (0018) R RPHI(2,24), (0019) S SCALD, (0020) S SCALR, (0021) S SFACT2, (0022) T T(10), (0023) T THETA (0024) (0025) REAL*4 (0026) T TIMSPA (0027) (0028) COMPLEX*8 (0029) D DA(1,1), (0030) C CHI, (0031) P PHI(1,12), (0032) P PSI, (0033) C CPXX(120,1), (0034) Z Z, (0035) Z ZC, (0036) C CPXK(1,120), (0037) C CPXL(2,120), (0038) C CHIPSI(2,1) (0039) (0040) NU2 = 2*NU (0041) NCC = NU*MT (0042) NRC = NCC*2 (0043) MCONF2 = 2*MCONF (0044) (0045) C TIME FUNCTIONS (0046) 19 DO 20 I=1,MT (0047) IF(IABS(IPREDO).EQ.1) T(I) = THETA(DTIMN,I) (0048) IF(IABS(IPREDO).EQ.2) T(I) = DTHETA(DTIMN,I) / (TIMSPA/2.) (0049) 20 CONTINUE (0050) (0051) C CONFORMAL TERMS (0052) CALL CALPOL(PHI,Z,MDIM,MCONF1,MCONF) (0053) CALL DMREAL(PHI,RPHI,1,12,2,24,1,NU) (0054) JT=0 (0055) JJT=0 (0056) 11 DO 12 IT=1,MT (0057) 1 DO 2 J=1,MCONF (0058) CPXK(1,JT+J) = PHI(1,J) * SNGL(T(IT)) (0059) JJ=2*J-1 (0060) 31 DO 32 II=1,2 (0061) AK(II,JJT+JJ) = RPHI(II,JJ) * T(IT) (0062) AK(II,JJT+JJ+1) = RPHI(II,JJ+1) * T(IT) (0063) 32 CONTINUE (0064) 2 CONTINUE (0065) JT=JT+NU (0066) JJT=JJT+NU2 (0067) 12 CONTINUE (0068) CALL DCALPO(PHI,Z,MDIM,MCONF1,MCONF) (0069) CALL DMREAL(PHI,RPHI,1,12,2,24,1,NU) (0070) JT=0 (0071) JJT=0 (0072) 13 DO 14 IT=1,MT (0073) 3 DO 4 J=1,MCONF (0074) CPXL(1,JT+J) = PHI(1,J) * SNGL(T(IT)) (0075) CPXL(2,JT+J) = (0.,0.) (0076) JJ=2*J-1 (0077) 33 DO 34 II=1,2 (0078) AL(II,JJT+JJ) = RPHI(II,JJ) * T(IT) (0079) AL(II,JJT+JJ+1) = RPHI(II,JJ+1) * T(IT) (0080) AL(II+2,JJT+JJ) = 0.D0 (0081) AL(II+2,JJT+JJ+1) = 0.D0 (0082) 34 CONTINUE (0083) 4 CONTINUE (0084) JT=JT+NU (0085) JJT=JJT+NU2 (0086) 14 CONTINUE (0087) (0088) C ANTICONFORMAL TERMS (0089) ZC = CONJG(Z) (0090) CALL CALPOL(PHI,ZC,MDIM,MANTIC,MANTIC) (0091) CALL DMREAL(PHI,RPHI,1,12,2,24,1,NU) (0092) JT=0 (0093) JJT=0 (0094) 15 DO 16 IT=1,MT (0095) 5 DO 6 J=1,MANTIC (0096) CPXK(1,MCONF+JT+J) = PHI(1,J) * SNGL(T(IT)) (0097) JJ=J*2-1 (0098) 35 DO 36 II=1,2 (0099) AK(II,MCONF2+JJT+JJ) = RPHI(II,JJ) * T(IT) (0100) AK(II,MCONF2+JJT+JJ+1) = RPHI(II,JJ+1) * T(IT) (0101) 36 CONTINUE (0102) 6 CONTINUE (0103) JT=JT+NU (0104) JJT=JJT+NU2 (0105) 16 CONTINUE (0106) CALL DCALPO(PHI,ZC,MDIM,MANTIC,MANTIC) (0107) CALL DMREAL(PHI,RPHI,1,12,2,24,1,NU) (0108) JT=0 (0109) JJT=0 (0110) 17 DO 18 IT=1,MT (0111) 7 DO 8 J=1,MANTIC (0112) CPXL(1,MCONF+JT+J) = (0.,0.) (0113) CPXL(2,MCONF+JT+J) = PHI(1,J) * SNGL(T(IT)) (0114) JJ=J*2-1 (0115) 37 DO 38 II=1,2 (0116) AL(II,MCONF2+JJT+JJ) = 0.D0 (0117) AL(II,MCONF2+JJT+JJ+1) = 0.D0 (0118) AL(II+2,MCONF2+JJT+JJ) = RPHI(II,JJ) * T(IT) (0119) AL(II+2,MCONF2+JJT+JJ+1) = RPHI(II,JJ+1) * T(IT) (0120) 38 CONTINUE (0121) 8 CONTINUE (0122) JT=JT+NU (0123) JJT=JJT+NU2 (0124) 18 CONTINUE (0125) (0126) C COMPLEX DISPLACEMENTS (0127) CALL CMTMLT(DA,CPXK,CPXX,1,120,1,1,NCC,1) (0128) DA(1,1) = DA(1,1)*SNGL(SCALD) + CMPLX(SNGL(D0(1)),SNGL(D0(2))) (0129) IF(CABS(DA(1,1)).GE.100.) DA(1,1) = (0.,0.) (0130) (0131) C COMPLEX STRAIN COMPONENTS (0132) CALL CMTMLT(CHIPSI,CPXL,CPXX,2,120,1,2,NCC,1) (0133) SFACT = 1.E6/SCALR (0134) CHI = CHIPSI(1,1) * SFACT (0135) PSI = CHIPSI(2,1) * SFACT (0136) IF(CABS(CHI).GE.1000.) CHI = (0.,0.) (0137) IF(CABS(PSI).GE.1000.) PSI = (0.,0.) (0138) (0139) C COVARIANCE MATRICES (0140) CALL DMTMLT(CXAKT,CX,AK,240,240,2,NRC,NRC,2,2) (0141) CALL DMTMLT(CDA,AK,CXAKT,2,240,2,2,NRC,2,0) (0142) DFACT2 = SCALD*SCALD (0143) CALL DMTSCL(CDA,CDA,DFACT2,2,2,2,2) (0144) (0145) CALL DMTMLT(CXALT,CX,AL,240,240,4,NRC,NRC,4,2) (0146) CALL DMTMLT(CCHIPS,AL,CXALT,4,240,4,4,NRC,4,0) (0147) SFACT2 = SFACT*SFACT (0148) CALL DMTSCL(CCHIPS,CCHIPS,SFACT2,4,4,4,4) (0149) RETURN (0150) END PROGRAM SIZE: PROCEDURE - 001730 LINKAGE - 032026 STACK - 000156 AK D LINKAGE 000444 0006S 0061M 0062M 0099M 0100M 0140A 0141A AL D LINKAGE 004244 0006S 0078M 0079M 0080M 0081M 0116M 0117M 0118M 0119M 0145A 0146A CABS R EXTERNAL 000000 0129 0136 0137 CALPOL R EXTERNAL 000000 0052 0090 CCHIPS D ARGUMENT 000060 0001S 0006S 0146A 0148A CDA D ARGUMENT 000055 0001S 0006S 0141A 0143A CHI C ARGUMENT 000047 0001S 0028S 0134M 0136M CHIPSI C LINKAGE 013644 0028S 0132A 0134 0135 CMPLX C EXTERNAL 000000 0128 CMTMLT R EXTERNAL 000000 0127 0132 CONJG C EXTERNAL 000000 0089 CPXK C LINKAGE 013654 0028S 0058M 0096M 0127A CPXL C LINKAGE 014614 0028S 0074M 0075M 0112M 0113M 0132A CPXX C ARGUMENT 000066 0001S 0028S 0127A 0132A CX D ARGUMENT 000071 0001S 0006S 0140A 0145A CXAKT D LINKAGE 016514 0006S 0140A 0141A CXALT D LINKAGE 022314 0006S 0145A 0146A D0 D ARGUMENT 000116 0001S 0006S 0128A DA C ARGUMENT 000044 0001S 0028S 0127A 0128M 0129M DCALPO R EXTERNAL 000000 0068 0106 DFACT2 D LINKAGE 032414 0006S 0142M 0143A DMREAL R EXTERNAL 000000 0053 0069 0091 0107 DMTMLT R EXTERNAL 000000 0140 0141 0145 0146 DMTSCL R EXTERNAL 000000 0143 0148 DTHETA D EXTERNAL 000000 0006S 0048 DTIMN D ARGUMENT 000121 0001S 0006S 0047A 0048A I I LINKAGE 000404 0046M 0047A 0048A IABS I EXTERNAL 000000 0047 0048 II I LINKAGE 000416 0060M 0061 0062 0077M 0078 0079 0080 0081 0098M 0099 0100 0115M 0116 0117 0118 0119 IPREDO I ARGUMENT 000127 0001S 0047 0048 IT I LINKAGE 000413 0056M 0058 0061 0062 0072M 0074 0078 0079 0094M 0096 0099 0100 0110M 0113 0118 0119 J I LINKAGE 000414 0057M 0058 0059 0073M 0074 0075 0076 0095M 0096 0097 0111M 0112 0113 0114 JJ I LINKAGE 000415 0059M 0061 0062 0076M 0078 0079 0080 0081 0097M 0099 0100 0114M 0116 0117 0118 0119 JJT I LINKAGE 000412 0055M 0061 0062 0066M 0071M 0078 0079 0080 0081 0085M 0093M 0099 0100 0104M 0109M 0116 0117 0118 0119 0123M JT I LINKAGE 000411 0054M 0058 0065M 0070M 0074 0075 0084M 0092M 0096 0103M 0108M 0112 0113 0122M MANTIC I ARGUMENT 000102 0001S 0090A 0095 0106A 0111 MCONF I ARGUMENT 000077 0001S 0043 0052A 0057 0068A 0073 0096 0112 0113 MCONF1 I ARGUMENT 000135 0001S 0052A 0068A MCONF2 I LINKAGE 000403 0043M 0099 0100 0116 0117 0118 0119 MDIM I ARGUMENT 000074 0001S 0052A 0068A 0090A 0106A MT I ARGUMENT 000124 0001S 0041 0046 0056 0072 0094 0110 NCC I LINKAGE 000401 0041M 0042 0127A 0132A NRC I LINKAGE 000402 0042M 0140A 0141A 0145A 0146A NU I ARGUMENT 000105 0001S 0040 0041 0053A 0065 0069A 0084 0091A 0103 0107A 0122 NU2 I LINKAGE 000400 0040M 0066 0085 0104 0123 PHI C LINKAGE 031714 0028S 0052A 0053A 0058 0068A 0069A 0074 0090A 0091A 0096 0106A 0107A 0113 PSI C ARGUMENT 000052 0001S 0028S 0135M 0137M RPHI D LINKAGE 031774 0006S 0053A 0061 0062 0069A 0078 0079 0091A 0099 0100 0107A 0118 0119 SCALD D ARGUMENT 000110 0001S 0006S 0128A 0142 SCALR D ARGUMENT 000113 0001S 0006S 0133 SFACT R LINKAGE 032410 0133M 0134 0135 0147 SFACT2 D LINKAGE 032422 0006S 0147M 0148A SNGL R EXTERNAL 000000 0058 0074 0096 0113 0128 T D LINKAGE 032274 0006S 0047M 0048M 0058A 0061 0062 0074A 0078 0079 0096A 0099 0100 0113A 0118 0119 THETA D EXTERNAL 000000 0006S 0047 TIMSPA R ARGUMENT 000132 0001S 0025S 0048 Z C ARGUMENT 000063 0001S 0028S 0052A 0068A 0089A ZC C LINKAGE 032374 0028S 0089M 0090A 0106A $1 000147 0057D $11 000145 0056D $12 000303 0056 0067D $13 000353 0072D $14 000536 0072 0086D $15 000616 0094D $16 000757 0094 0105D $17 001027 0110D $18 001216 0110 0124D $19 000021 0046D $2 000265 0057 0064D $20 000075 0046 0049D $3 000355 0073D $31 000216 0060D $32 000257 0060 0063D $33 000443 0077D $34 000512 0077 0082D $35 000671 0098D $36 000733 0098 0101D $37 001121 0115D $38 001172 0115 0120D $4 000520 0073 0083D $5 000620 0095D $6 000741 0095 0102D $7 001031 0111D $8 001200 0111 0121D 0000 ERRORS [FTN-REV18.2] (0151) (0152) SUBROUTINE EVALU(RMAJ,RMIN,THETA,CHI,PSI) (0153) (0154) C LENGTH AND ORIENTATION OF SEMI-MAJOR AND MINOR AXES OF THE STRAIN (0155) C ELLIPSE FROM COMPLEX STRAIN COMPONENTS (0156) (0157) COMPLEX*8 (0158) C CHI, (0159) P PSI (0160) (0161) THETA = 0. (0162) (0163) SQR = SQRT(REAL(PSI)**2 + AIMAG(PSI)**2) (0164) RMAJ = REAL(CHI) + SQR (0165) RMIN = REAL(CHI) - SQR (0166) 1 IF(CABS(PSI).LT.1.E-20) GOTO 2 (0167) THETA = ATAN2(AIMAG(PSI),REAL(PSI))/2. (0168) 2 CONTINUE (0169) (0170) RETURN (0171) END PROGRAM SIZE: PROCEDURE - 000130 LINKAGE - 000034 STACK - 000066 AIMAG R EXTERNAL 000000 0163 0167 ATAN2 R EXTERNAL 000000 0167 CABS R EXTERNAL 000000 0166 CHI C ARGUMENT 000053 0152S 0157S 0164A 0165A PSI C ARGUMENT 000056 0152S 0157S 0163A 0166A 0167A REAL R EXTERNAL 000000 0163 0164 0165 0167 RMAJ R ARGUMENT 000042 0152S 0164M RMIN R ARGUMENT 000045 0152S 0165M SQR R LINKAGE 000426 0163M 0164 0165 SQRT R EXTERNAL 000000 0163 SQRT$X R EXTERNAL 000000 0166 THETA R ARGUMENT 000050 0152S 0161M 0167M $1 000061 0166D $2 000120 0166 0168D 0000 ERRORS [FTN-REV18.2] (0172) (0173) SUBROUTINE TSHEAR(TSHR,SHRAZ,STSHR,SSHRAZ,PSI,CCHIPS) (0174) (0175) C TOTAL SHEAR, AZIMUTH OF TOTAL SHEAR (0176) (0177) REAL*4 (0178) S SHRAZ, (0179) T TSHR (0180) (0181) REAL*8 (0182) A A(1,4), (0183) A AC(1,4), (0184) C CCHIPS(4,4), (0185) S STSHR, (0186) S SSHRAZ (0187) (0188) COMPLEX*8 (0189) P PSI (0190) (0191) RHOGON = 50./ATAN(1.) (0192) SHRAZ = 0. (0193) STSHR = 0.D0 (0194) SSHRAZ = 0.D0 (0195) (0196) C TOTAL SHEAR (0197) TSHR = CABS(PSI) (0198) (0199) C AZIMUTH OF MAX. SHEAR (0200) 1 IF(TSHR.LT.1.E-12) GOTO 2 (0201) SHRAZ = ATAN2(AIMAG(PSI),REAL(PSI))/2. (0202) SHRAZ = SHRAZ * RHOGON + 50. (0203) (0204) C VARIANCE OF TOTAL SHEAR (0205) A(1,1) = 0.D0 (0206) A(1,2) = 0.D0 (0207) A(1,3) = REAL(PSI)/TSHR (0208) A(1,4) = AIMAG(PSI)/TSHR (0209) CALL DMTMLT(AC,A,CCHIPS,1,4,4,1,4,4,0) (0210) CALL DMTMLT(STSHR,AC,A,1,4,1,1,4,1,2) (0211) IF(STSHR.LE.0.D0) STSHR = 0.D0 (0212) STSHR = DSQRT(STSHR) (0213) (0214) C VARIANCE OF AZIMUTH (0215) TSHR22 = 2. * TSHR * TSHR (0216) A(1,3) = - AIMAG(PSI) / TSHR22 (0217) A(1,4) = REAL(PSI) / TSHR22 (0218) CALL DMTMLT(AC,A,CCHIPS,1,4,4,1,4,4,0) (0219) CALL DMTMLT(SSHRAZ,AC,A,1,4,1,1,4,1,2) (0220) IF(SSHRAZ.LE.0.D0) SSHRAZ = 0.D0 (0221) SSHRAZ = DSQRT(SSHRAZ) * RHOGON (0222) 2 CONTINUE (0223) (0224) RETURN (0225) END PROGRAM SIZE: PROCEDURE - 000376 LINKAGE - 000106 STACK - 000074 A D LINKAGE 000424 0181S 0205M 0206M 0207M 0208M 0209A 0210A 0216M 0217M 0218A 0219A AC D LINKAGE 000444 0181S 0209A 0210A 0218A 0219A AIMAG R EXTERNAL 000000 0201 0208 0216 ATAN R EXTERNAL 000000 0191 ATAN$X EXTERNAL 000000 0200 ATAN2 R EXTERNAL 000000 0201 CABS R EXTERNAL 000000 0197 CCHIPS D ARGUMENT 000061 0173S 0181S 0209A 0218A DMTMLT R EXTERNAL 000000 0209 0210 0218 0219 DSQR$X D EXTERNAL 000000 0222 DSQRT D EXTERNAL 000000 0212 0221 PSI C ARGUMENT 000056 0173S 0188S 0197A 0201A 0207A 0208A 0216A 0217A REAL R EXTERNAL 000000 0201 0207 0217 RHOGON R LINKAGE 000466 0191M 0202 0221 SHRAZ R ARGUMENT 000045 0173S 0177S 0192M 0201M 0202M SSHRAZ D ARGUMENT 000053 0173S 0181S 0194M 0219A 0220M 0221M STSHR D ARGUMENT 000050 0173S 0181S 0193M 0210A 0211M 0212M TSHR R ARGUMENT 000042 0173S 0177S 0197M 0200 0207 0208 0215 TSHR22 R LINKAGE 000504 0215M 0216 0217 $1 000035 0200D $2 000355 0200 0222D 0000 ERRORS [FTN-REV18.2] (0226) (0227) (0228) REAL*4 FUNCTION PINPOL(ZQ,ZP,NB,NE,ICODE) (0229) C (0230) C **************************************************************** (0231) C * * (0232) C * WRITTEN BY D.SCHNEIDER * (0233) C * UNIVERSITY OF NEW BRUNSWICK * (0234) C * FREDERICTON, 1980 * (0235) C * * (0236) C **************************************************************** (0237) C (0238) C DETERMINES WHETHER A POINT IS OUTSIDE,INSIDE,ON A VERTICE OR ON A (0239) C SIDE OF A POLYGON (0240) C (0241) C ICODE IN ON SIDE ON VERTICE OUT (0242) C 1 1. 0. 0. 0. (0243) C 2 1. 1. 1. 0. (0244) C 1 1. 0.5 0.5 0. (0245) C (0246) C VARIABLES: P(X,Y): POLYGON VERTICES (0247) C Q(X,Y): TESTPOINTS, CR: RESULT CODE (0248) C A(I),B: AREA*2 OF TRIANGLE (0249) C XMIN,XMAX,YMIN,YMAX: COORD. OF CIRCUMRECTANGLE (0250) C CIN: NUMBER OF SAMEORIENTED TRIANGLES WHERE Q IS IN (0251) C NB: # OF 1-ST VERTICE OF POLYGON (0252) C NE: # OF LAST (=1-ST) VERTICE (0253) (0254) IMPLICIT REAL*8(A-H,O-Z) (0255) (0256) REAL*8 (0257) A A(30), (0258) A ARE2, (0259) C C,CIN,CR, (0260) P P(30,2), (0261) Q Q(2),Q1,Q2, (0262) X XMAX,XMIN, (0263) Y YMAX,YMIN (0264) (0265) COMPLEX*8 (0266) Z ZQ, (0267) Z ZP(30) (0268) (0269) (0270) C STATEMENT FUNCTION DEFINITION (0271) ARE2(X1,Y1,X2,Y2,X3,Y3)=- X1*Y2-X2*Y3-X3*Y1+Y1*X2+Y2*X3+Y3*X1 (0272) N1 = NE-1 (0273) C (0274) 51 DO 52 I=NB,NE (0275) P(I,1) = INT(REAL(ZP(I))*1.E3) (0276) P(I,2) = INT(AIMAG(ZP(I))*1.E3) (0277) 52 CONTINUE (0278) (0279) C DETERMINE AREA (ORIENT.) OF TRIANGEL(NB,I,I+1) AND CIRCUMRECTANGLE (0280) XMIN=P(NB,1) (0281) XMAX=P(NB,1) (0282) YMIN=P(NB,2) (0283) YMAX=P(NB,2) (0284) AREA=0.D0 (0285) 3 DO 4 I=NB,N1 (0286) XMIN=DMIN1(XMIN,P(I,1)) (0287) XMAX=DMAX1(XMAX,P(I,1)) (0288) YMIN=DMIN1(YMIN,P(I,2)) (0289) YMAX=DMAX1(YMAX,P(I,2)) (0290) A(I)=ARE2(P(NB,1),P(NB,2),P(I,1),P(I,2),P(I+1,1),P(I+1,2)) (0291) AREA=AREA+A(I) (0292) 4 CONTINUE (0293) C (0294) Q1 = INT(REAL(ZQ)*1.E3) (0295) Q2 = INT(AIMAG(ZQ)*1.E3) (0296) CIN=0.D0 (0297) CR=0.D0 (0298) C (0299) C IS POINT Q IN CIRCUMRECTANGLE (0300) IF(Q1.LT.XMIN.OR.Q1.GT.XMAX.OR.Q2.LT.YMIN.OR.Q2.GT.YMAX)GOTO 6 (0301) C (0302) C IS Q IN TRIANGLE NB,I,I+1 (0303) 7 DO 8 I=NB,N1 (0304) B=ARE2(P(NB,1),P(NB,2),P(I,1),P(I,2),Q1,Q2) (0305) IF(DABS(A(I))-DABS(B).LT.0.D0)GOTO 8 (0306) C=1.D0 (0307) S = A(I)*B (0308) IF(DABS(S).LT.1.D-4)GOTO 20 (0309) 19 IF(S)8,20,21 (0310) 20 C=0.5D0 (0311) 21 I1=I+1 (0312) B=ARE2(P(I1,1),P(I1,2),P(NB,1),P(NB,2),Q1,Q2) (0313) IF(DABS(A(I))-DABS(B).LT.0.D0)GOTO 8 (0314) S = A(I)*B (0315) IF(DABS(S).LT.1.D-4) GOTO 23 (0316) 22 IF(S)8,23,24 (0317) 23 C=0.5D0 (0318) 24 B=ARE2(P(I,1),P(I,2),P(I1,1),P(I1,2),Q1,Q2) (0319) S = A(I)*B (0320) IF(DABS(S).LT.1.D-4) GOTO 26 (0321) 25 IF(S)8,26,27 (0322) C (0323) C SPECIAL CASE: AREA(TRIANGLE)=0 (0324) 26 IF(DABS(A(I)).GT.1.D-3)GOTO 29 (0325) S=(Q1-P(I,1))*(Q1-P(I1,1))+(Q2-P(I,2))*(Q2-P(I1,2)) (0326) IF(DABS(S).LT.1.D-4) GOTO 29 (0327) IF(S)30,29,8 (0328) 30 C=1.D0 (0329) 29 CONTINUE (0330) CR = 2.D0*C + 1.D0 (0331) 5 GOTO 6 (0332) 27 CIN=CIN+DSIGN(C,A(I)*AREA) (0333) 8 CONTINUE (0334) CR=CIN (0335) 6 CONTINUE (0336) C (0337) C SET VALUE OF FUNCTION (0338) PINPOL = 0.D0 (0339) IF(ICODE.EQ.1.AND.CR.EQ.1.D0) PINPOL = 1.0 (0340) IF(ICODE.EQ.2.AND.CR.GT.0.D0) PINPOL = 1.0 (0341) IF(ICODE.EQ.3.AND.CR.EQ.1.D0) PINPOL = 1.0 (0342) IF(ICODE.EQ.3.AND.CR.GE.2.D0) PINPOL = 0.5 (0343) (0344) RETURN (0345) END PROGRAM SIZE: PROCEDURE - 001426 LINKAGE - 000702 STACK - 000152 A D LINKAGE 000424 0256S 0290M 0291 0305A 0307 0313A 0314 0319 0324A 0332 AIMAG R EXTERNAL 000000 0276 0295 ARE2 D 000000 0256S 0271S 0290 0304 0312 0318 AREA D LINKAGE 001230 0284M 0291M 0332 B D LINKAGE 001260 0304M 0305A 0307 0312M 0313A 0314 0318M 0319 C D LINKAGE 001266 0256S 0306M 0310M 0317M 0328M 0330 0332A CIN D LINKAGE 001250 0256S 0296M 0332M 0334 CR D LINKAGE 001254 0256S 0297M 0330M 0334M 0339 0340 0341 0342 DABS D EXTERNAL 000000 0305 0308 0313 0315 0320 0324 0326 DMAX1 D EXTERNAL 000000 0287 0289 DMIN1 D EXTERNAL 000000 0286 0288 DSIGN D EXTERNAL 000000 0332 I I LINKAGE 000401 0274M 0275 0276 0285M 0286 0287 0288 0289 0290 0291 0303M 0304 0305 0307 0311 0313 0314 0318 0319 0324 0325 0332 I1 I LINKAGE 000402 0311M 0312 0318 0325 ICODE I ARGUMENT 000062 0228S 0339 0340 0341 0342 INT I EXTERNAL 000000 0275 0276 0294 0295 N1 I LINKAGE 000400 0272M 0285 0303 NB I ARGUMENT 000054 0228S 0274 0280 0281 0282 0283 0285 0290 0303 0304 0312 NE I ARGUMENT 000057 0228S 0272 0274 P D LINKAGE 000614 0256S 0275M 0276M 0280 0281 0282 0283 0286A 0287A 0288A 0289A 0290A 0304A 0312A 0318A 0325 PINPOL R LINKAGE 001300 0228S 0338M 0339M 0340M 0341M 0342M Q1 D LINKAGE 001240 0256S 0294M 0300 0304A 0312A 0318A 0325 Q2 D LINKAGE 001244 0256S 0295M 0300 0304A 0312A 0318A 0325 REAL R EXTERNAL 000000 0275 0294 S D LINKAGE 001272 0307M 0308A 0309 0314M 0315A 0316 0319M 0320A 0321 0325M 0326A 0327 X1 D 000000 0271 X2 D 000000 0271 X3 D 000000 0271 XMAX D LINKAGE 001214 0256S 0281M 0287M 0300 XMIN D LINKAGE 001210 0256S 0280M 0286M 0300 Y1 D 000000 0271 Y2 D 000000 0271 Y3 D 000000 0271 YMAX D LINKAGE 001224 0256S 0283M 0289M 0300 YMIN D LINKAGE 001220 0256S 0282M 0288M 0300 ZP C ARGUMENT 000051 0228S 0265S 0275A 0276A ZQ C ARGUMENT 000046 0228S 0265S 0294A 0295A $19 000624 0309D $20 000633 0308 0309 0310D $21 000637 0309 0311D $22 000770 0316D $23 000777 0315 0316 0317D $24 001003 0316 0318D $25 001102 0321D $26 001111 0320 0321 0324D $27 001231 0321 0332D $29 001220 0324 0326 0327 0329D $3 000171 0285D $30 001214 0327 0328D $4 000364 0285 0292D $5 001230 0331D $51 000065 0274D $52 000134 0274 0277D $6 001265 0300 0331 0335D $7 000467 0303D $8 001253 0303 0305 0309 0313 0316 0321 0327 0333D 0000 ERRORS [FTN-REV18.2] SUBROUTINE BLOC(ZBLC,NPER,MBLOC,XYBLOC,SXYBLC,BLOCAZ,CPXX,CX, (0346) SUBROUTINE BLOC(ZBLC,NPER,MBLOC,XYBLOC,SXYBLC,BLOCAZ,CPXX,CX, (0347) 1MDIM,MCONF,MANTIC,NU,SCALD,SCALR,D0,DTIMN,MT,IPREDO,TIMSPA,MCONF1) (0348) (0349) C PREDICTION OF COMPLEX BLOC MOTION (0350) (0351) INTEGER*2 (0352) N NPER(3,2) (0353) (0354) REAL*8 (0355) A A(2,4), (0356) A ACC(2,4), (0357) A AK(4,240), (0358) B BLOCAZ(10), (0359) C CX(240,240), (0360) C CXAKT(240,4), (0361) C CCBLOC(4,4), (0362) C CDBLOC(2,2), (0363) D D0(2), (0364) D DFACT2, (0365) D DTHETA, (0366) D DTIMN, (0367) R RHOGON, (0368) S S, (0369) S SCALD, (0370) S SCALR, (0371) S SFACT2, (0372) S SXYBLC(10,2), (0373) T THETA, (0374) X X, (0375) X XYBLOC(10,2), (0376) Y Y (0377) (0378) REAL*4 (0379) T T(10), (0380) T TIMSPA (0381) (0382) COMPLEX*8 (0383) C CBLOC(2,1), (0384) P PHII(1,12), (0385) P PHIJ(1,12), (0386) C CPXX(120,1), (0387) C CPXK(2,120), (0388) Z ZBLC(30), (0389) Z ZI,ZJ (0390) (0391) COMMON /COMZ/ AK,CXAKT,CPXK (0392) (0393) RHOGON = 50.D0/DATAN(1.D0) (0394) (0395) NCC = NU*MT (0396) NRC = NCC*2 (0397) (0398) CALL DMTSCL(A,A,0.D0,2,4,2,4) (0399) A(1,1) = 1.D0 (0400) A(2,2) = 1.D0 (0401) A(1,3) = -1.D0 (0402) A(2,4) = -1.D0 (0403) (0404) C TIME FUNCTIONS (0405) 19 DO 20 I=1,MT (0406) IF(IABS(IPREDO).EQ.1) T(I) = THETA(DTIMN,I) (0407) IF(IABS(IPREDO).EQ.2) T(I) = DTHETA(DTIMN,I) / (TIMSPA/2.) (0408) 20 CONTINUE (0409) (0410) IJ=1 (0411) ZI = (0.,0.) (0412) MBLOC1 = MBLOC-1 (0413) 3 DO 4 IBLOC = 0,MBLOC1 (0414) IBLOC1 = IBLOC + 1 (0415) 5 DO 6 JBLOC = IBLOC1,MBLOC (0416) IF(IBLOC.NE.0) ZI = ZBLC(NPER(IBLOC,2)+1) (0417) ZJ = ZBLC(NPER(JBLOC,2)+1) (0418) (0419) 31 DO 32 I=1,NCC (0420) CPXK(1,I) = (0.,0.) (0421) CPXK(2,I) = (0.,0.) (0422) 32 CONTINUE (0423) (0424) C CONFORMAL TERMS (0425) CALL CALPOL(PHII,ZI,MDIM,MCONF1,MCONF) (0426) CALL CALPOL(PHIJ,ZJ,MDIM,MCONF1,MCONF) (0427) JT=0 (0428) 11 DO 12 IT=1,MT (0429) 1 DO 2 J=1,MCONF (0430) IF(J.GT.MCONF1) CPXK(1,JT+J) = PHII(1,J) * T(IT) (0431) IF(J.GT.MCONF1) CPXK(2,JT+J) = PHIJ(1,J) * T(IT) (0432) 2 CONTINUE (0433) JT=JT+NU (0434) 12 CONTINUE (0435) (0436) C COMPLEX DISPLACEMENTS (0437) CALL CMTMLT(CBLOC,CPXK,CPXX,2,120,1,2,NCC,1) (0438) CBLOC(1,1) = CBLOC(1,1)*SNGL(SCALD) (0439) 1 + CMPLX(SNGL(D0(1)),SNGL(D0(2))) (0440) CBLOC(2,1) = CBLOC(2,1)*SNGL(SCALD) (0441) 1 + CMPLX(SNGL(D0(1)),SNGL(D0(2))) (0442) (0443) C COVARIANCE MATRICES (0444) CALL DMREAL(CPXK,AK,2,120,4,240,2,NCC) (0445) CALL DMTMLT(CXAKT,CX,AK,240,240,4,NRC,NRC,4,2) (0446) CALL DMTMLT(CCBLOC,AK,CXAKT,4,240,4,4,NRC,4,0) (0447) DFACT2 = SCALD*SCALD (0448) CALL DMTSCL(CCBLOC,CCBLOC,DFACT2,4,4,4,4) (0449) (0450) CALL DMTMLT(ACC,A,CCBLOC,2,4,4,2,4,4,0) (0451) CALL DMTMLT(CDBLOC,ACC,A,2,4,2,2,4,2,2) (0452) (0453) X = REAL(CBLOC(2,1)-CBLOC(1,1)) (0454) Y = AIMAG(CBLOC(2,1)-CBLOC(1,1)) (0455) XYBLOC(IJ,1) = X * 1.D3 (0456) XYBLOC(IJ,2) = Y * 1.D3 (0457) BLOCAZ(IJ) = 0.D0 (0458) IF(X.NE.0.D0.AND.Y.NE.0.D0) BLOCAZ(IJ) = DATAN2(X,Y) * RHOGON (0459) (0460) S = CDBLOC(1,1) (0461) IF(S.LT.0.D0)S=0.D0 (0462) SXYBLC(IJ,1) = DSQRT(S) * 1.D3 (0463) S= CDBLOC(2,2) (0464) IF(S.LT.0.D0)S=0.D0 (0465) SXYBLC(IJ,2) = DSQRT(S) * 1.D3 (0466) IJ=IJ+1 (0467) (0468) 6 CONTINUE (0469) 4 CONTINUE (0470) RETURN (0471) END PROGRAM SIZE: PROCEDURE - 001354 LINKAGE - 000576 STACK - 000162 A D LINKAGE 000442 0354S 0398A 0399M 0400M 0401M 0402M 0450A 0451A ACC D LINKAGE 000502 0354S 0450A 0451A AIMAG R EXTERNAL 000000 0454 AK D /COMZ/ 000000 0354S 0391S 0444A 0445A 0446A BLOCAZ D ARGUMENT 000063 0346S 0354S 0457M 0458M CALPOL R EXTERNAL 000000 0425 0426 CBLOC C LINKAGE 000542 0382S 0437A 0438M 0440M 0453 0454 CCBLOC D LINKAGE 000552 0354S 0446A 0448A 0450A CDBLOC D LINKAGE 000652 0354S 0451A 0460 0463 CMPLX C EXTERNAL 000000 0438 0440 CMTMLT R EXTERNAL 000000 0437 CPXK C /COMZ/ 017000 0382S 0391S 0420M 0421M 0430M 0431M 0437A 0444A CPXX C ARGUMENT 000066 0346S 0382S 0437A CX D ARGUMENT 000071 0346S 0354S 0445A CXAKT D /COMZ/ 007400 0354S 0391S 0445A 0446A D0 D ARGUMENT 000116 0346S 0354S 0438A 0440A DATAN D EXTERNAL 000000 0393 DATAN2 D EXTERNAL 000000 0458 DATN$X EXTERNAL 000000 0405 DFACT2 D LINKAGE 001144 0354S 0447M 0448A DMREAL R EXTERNAL 000000 0444 DMTMLT R EXTERNAL 000000 0445 0446 0450 0451 DMTSCL R EXTERNAL 000000 0398 0448 DSQR$X J EXTERNAL 000000 0468 DSQRT D EXTERNAL 000000 0462 0465 DTHETA D EXTERNAL 000000 0354S 0407 DTIMN D ARGUMENT 000121 0346S 0354S 0406A 0407A I I LINKAGE 000404 0405M 0406A 0407A 0419M 0420 0421 IABS I EXTERNAL 000000 0406 0407 IBLOC I LINKAGE 000407 0413M 0414 0416 IBLOC1 I LINKAGE 000410 0414M 0415 IJ I LINKAGE 000405 0410M 0455 0456 0457 0458 0462 0465 0466M IPREDO I ARGUMENT 000127 0346S 0406 0407 IT I LINKAGE 000413 0428M 0430 0431 J I LINKAGE 000414 0429M 0430 0431 JBLOC I LINKAGE 000411 0415M 0417 JT I LINKAGE 000412 0427M 0430 0431 0433M MBLOC I ARGUMENT 000052 0346S 0412 0415 MBLOC1 I LINKAGE 000406 0412M 0413 MCONF I ARGUMENT 000077 0346S 0425A 0426A 0429 MCONF1 I ARGUMENT 000135 0346S 0425A 0426A 0430 0431 MDIM I ARGUMENT 000074 0346S 0425A 0426A MT I ARGUMENT 000124 0346S 0395 0405 0428 NCC I LINKAGE 000400 0395M 0396 0419 0437A 0444A NPER I ARGUMENT 000047 0346S 0351S 0416 0417 NRC I LINKAGE 000401 0396M 0445A 0446A NU I ARGUMENT 000105 0346S 0395 0433 PHII C LINKAGE 000672 0382S 0425A 0430 PHIJ C LINKAGE 000752 0382S 0426A 0431 REAL R EXTERNAL 000000 0453 RHOGON D LINKAGE 001060 0354S 0393M 0458 S D LINKAGE 001170 0354S 0460M 0461M 0462A 0463M 0464M 0465A SCALD D ARGUMENT 000110 0346S 0354S 0438A 0440A 0447 SNGL R EXTERNAL 000000 0438 0440 SXYBLC D ARGUMENT 000060 0346S 0354S 0462M 0465M T R LINKAGE 001032 0378S 0406M 0407M 0430 0431 THETA D EXTERNAL 000000 0354S 0406 TIMSPA R ARGUMENT 000132 0346S 0378S 0407 X D LINKAGE 001154 0354S 0453M 0455 0458A XYBLOC D ARGUMENT 000055 0346S 0354S 0455M 0456M Y D LINKAGE 001162 0354S 0454M 0456 0458A ZBLC C ARGUMENT 000044 0346S 0382S 0416 0417 ZI C LINKAGE 001100 0382S 0411M 0416M 0425A ZJ C LINKAGE 001104 0382S 0417M 0426A $1 000356 0429D $11 000354 0428D $12 000476 0428 0434D $19 000061 0405D $2 000463 0429 0432D $20 000140 0405 0408D $3 000165 0413D $31 000255 0419D $32 000314 0419 0422D $4 001303 0413 0469D $5 000171 0415D $6 001274 0415 0468D 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE DMTMLT(C,A,B,DIMN,DIMM,DIML,N,M,L,NT) C% (0001) SUBROUTINE DMTMLT(C,A,B,DIMN,DIMM,DIML,N,M,L,NT) (0002) C% (0003) C% PRODUKT ZWEIER MATRIZEN IN ALLEN ERLAUBTEN TRANSPONIERTEN (0004) C% KOMBINATIONEN (DOUBLE PRECISION) (0005) C% NT=0) C(DIMN,DIML) = A(DIMN,DIMM) * B(DIMM,DIML) (0006) C% NT=1) C(DIMN,DIML) = A(DIMM,DIMN)T * B(DIMM,DIML) (0007) C% NT=2) C(DIMN,DIML) = A(DIMN,DIMM) * B(DIML,DIMM)T (0008) C% NT=3) C(DIMN,DIML) = A(DIMM,DIMN)T * B(DIML,DIMM)T (0009) C% N,M,L: AKTUELLE PARAMETER (0010) C% DIMN,DIMM,DIML: DIMENSIONEN IM HAUPTPROGRAMM (0011) (0012) C BUNDESAMT FUER LANDESTOPOGRAPHIE (0013) C D.SCHNEIDER (0014) C WABERN, 1981 (0015) (0016) C% (0017) INTEGER*2 N,M,L,DIMN,DIMM,DIML,NT (0018) INTEGER*2 I,J,K,NT1,IM,JM,KL,KN (0019) REAL*8 C,A,B,AEL,BEL,CIJ (0020) DIMENSION C(DIMN,DIML),A(1),B(1) (0021) (0022) C TEST DER ARRAYDIMENSIONEN: (0023) 41 IF(N.LE.DIMN.AND.M.LE.DIMM.AND.L.LE.DIML)GOTO 42 (0024) WRITE(1,9901)N,DIMN,M,DIMM,L,DIML (0025) 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTMLT***'/ (0026) 1 'N = ',I4,' DIMN = ',I4/ (0027) 2 'M = ',I4,' DIMM = ',I4/ (0028) 3 'L = ',I4,' DIML = ',I4/) (0029) 42 CONTINUE (0030) (0031) IF(N.EQ.0.OR.M.EQ.0.OR.L.EQ.0) RETURN (0032) NT1 = NT+1 (0033) GOTO (100,101,102,103),NT1 (0034) (0035) C A*B (0036) 100 CONTINUE (0037) 1 DO 2 I=1,N (0038) JM=0 (0039) 3 DO 4 J=1,L (0040) CIJ = 0.D0 (0041) KN=I (0042) 5 DO 6 K=1,M (0043) AEL = A(KN) (0044) BEL = B(K+JM) (0045) KN = KN+DIMN (0046) 7 IF(AEL.EQ.0.D0.OR.BEL.EQ.0.D0) GOTO 8 (0047) CIJ = CIJ + AEL * BEL (0048) 8 CONTINUE (0049) 6 CONTINUE (0050) C(I,J) = CIJ (0051) JM=JM+DIMM (0052) 4 CONTINUE (0053) 2 CONTINUE (0054) RETURN (0055) (0056) C AT*B (0057) 101 CONTINUE (0058) IM=0 (0059) 11 DO 12 I=1,N (0060) JM=0 (0061) 13 DO 14 J=1,L (0062) CIJ = 0.D0 (0063) 15 DO 16 K=1,M (0064) AEL = A(K+IM) (0065) BEL = B(K+JM) (0066) 17 IF(AEL.EQ.0.D0.OR.BEL.EQ.0.D0) GOTO 18 (0067) CIJ = CIJ + AEL * BEL (0068) 18 CONTINUE (0069) 16 CONTINUE (0070) C(I,J) = CIJ (0071) JM=JM+DIMM (0072) 14 CONTINUE (0073) IM=IM+DIMM (0074) 12 CONTINUE (0075) RETURN (0076) (0077) C A*BT (0078) 102 CONTINUE (0079) 21 DO 22 I=1,N (0080) 23 DO 24 J=1,L (0081) CIJ = 0.D0 (0082) KN=I (0083) KL=J (0084) 25 DO 26 K=1,M (0085) AEL = A(KN) (0086) BEL = B(KL) (0087) KN=KN+DIMN (0088) KL=KL+DIML (0089) 27 IF(AEL.EQ.0.D0.OR.BEL.EQ.0.D0) GOTO 28 (0090) CIJ = CIJ + AEL * BEL (0091) 28 CONTINUE (0092) 26 CONTINUE (0093) C(I,J) = CIJ (0094) 24 CONTINUE (0095) 22 CONTINUE (0096) RETURN (0097) (0098) C AT*BT (0099) 103 CONTINUE (0100) IM=0 (0101) 31 DO 32 I=1,N (0102) 33 DO 34 J=1,L (0103) CIJ = 0.D0 (0104) KL=J (0105) 35 DO 36 K=1,M (0106) AEL = A(K+IM) (0107) BEL = B(KL) (0108) KL=KL+DIML (0109) 37 IF(AEL.EQ.0.D0.OR.BEL.EQ.0.D0) GOTO 38 (0110) CIJ = CIJ + AEL * BEL (0111) 38 CONTINUE (0112) 36 CONTINUE (0113) C(I,J) = CIJ (0114) 34 CONTINUE (0115) IM=IM+DIMM (0116) 32 CONTINUE (0117) RETURN (0118) END PROGRAM SIZE: PROCEDURE - 001200 LINKAGE - 000054 STACK - 000104 A D ARGUMENT 000047 0001S 0019S 0020S 0043 0064 0085 0106 AEL D LINKAGE 000444 0019S 0043M 0046 0047 0064M 0066 0067 0085M 0089 0090 0106M 0109 0110 B D ARGUMENT 000052 0001S 0019S 0020S 0044 0065 0086 0107 BEL D LINKAGE 000450 0019S 0044M 0046 0047 0065M 0066 0067 0086M 0089 0090 0107M 0109 0110 C D ARGUMENT 000044 0001S 0019S 0020S 0050M 0070M 0093M 0113M CIJ D LINKAGE 000440 0019S 0040M 0047M 0050 0062M 0067M 0070 0081M 0090M 0093 0103M 0110M 0113 DIML I ARGUMENT 000063 0001S 0017S 0020S 0023 0024 0088 0108 DIMM I ARGUMENT 000060 0001S 0017S 0023 0024 0051 0071 0073 0115 DIMN I ARGUMENT 000055 0001S 0017S 0020S 0023 0024 0045 0087 I I LINKAGE 000402 0018S 0037M 0041 0050 0059M 0070 0079M 0082 0093 0101M 0113 IM I LINKAGE 000407 0018S 0058M 0064 0073M 0100M 0106 0115M J I LINKAGE 000404 0018S 0039M 0050 0061M 0070 0080M 0083 0093 0102M 0104 0113 JM I LINKAGE 000403 0018S 0038M 0044 0051M 0060M 0065 0071M K I LINKAGE 000406 0018S 0042M 0044 0063M 0064 0065 0084M 0105M 0106 KL I LINKAGE 000410 0018S 0083M 0086 0088M 0104M 0107 0108M KN I LINKAGE 000405 0018S 0041M 0043 0045M 0082M 0085 0087M L I ARGUMENT 000074 0001S 0017S 0023 0024 0031 0039 0061 0080 0102 M I ARGUMENT 000071 0001S 0017S 0023 0024 0031 0042 0063 0084 0105 N I ARGUMENT 000066 0001S 0017S 0023 0024 0031 0037 0059 0079 0101 NT I ARGUMENT 000077 0001S 0017S 0032 NT1 I LINKAGE 000401 0018S 0032M 0033 $1 000235 0037D $100 000235 0033 0036D $101 000424 0033 0057D $102 000613 0033 0078D $103 001001 0033 0099D $11 000426 0059D $12 000603 0059 0074D $13 000432 0061D $14 000570 0061 0072D $15 000440 0063D $16 000520 0063 0069D $17 000475 0066D $18 000520 0066 0068D $2 000414 0037 0053D $21 000613 0079D $22 000771 0079 0095D $23 000615 0080D $24 000762 0080 0094D $25 000627 0084D $26 000716 0084 0092D $27 000673 0089D $28 000716 0089 0091D $3 000241 0039D $31 001003 0101D $32 001157 0101 0116D $33 001005 0102D $34 001144 0102 0114D $35 001015 0105D $36 001100 0105 0112D $37 001055 0109D $38 001100 0109 0111D $4 000405 0039 0052D $41 000001 0023D $42 000202 0023 0029D $5 000251 0042D $6 000335 0042 0049D $7 000312 0046D $8 000335 0046 0048D $9901 000102 0024 0025D 0000 ERRORS [FTN-REV18.2] SUBROUTINE DMTSYM(A,NDIM,N) (0119) SUBROUTINE DMTSYM(A,NDIM,N) (0120) (0121) C DUPLICATE ELEMENTS IN UPPER HALF FILLED SYMMETRIC MATRICE (0122) (0123) INTEGER*2 (0124) N N, /* ACTUAL SIZE OF MATRIX (0125) N NDIM /* DIMENSION OF A (0126) (0127) REAL*8 (0128) A A(NDIM,NDIM) /* UPPER HALF FILLED MATRIX / SYMM. MATRIX (0129) (0130) C CHECK ARRAY DIMENSIONS (0131) 900 IF(N.GT.NDIM) GOTO 901 (0132) (0133) IF(N.LE.1) RETURN (0134) (0135) 1 DO 2 I=2,N (0136) IEND=I-1 (0137) 3 DO 4 K=1,IEND (0138) A(I,K) = A(K,I) (0139) 4 CONTINUE (0140) 2 CONTINUE (0141) RETURN (0142) (0143) C ERROR MESSAGES (0144) 901 CONTINUE (0145) WRITE(1,1901) (0146) 1901 FORMAT(' ***ARRAY SIZE EXCEEDS DIMENSIONS IN "MTSYM"***'/) (0147) RETURN (0148) END PROGRAM SIZE: PROCEDURE - 000170 LINKAGE - 000032 STACK - 000064 A D ARGUMENT 000042 0119S 0127S 0138M I I LINKAGE 000401 0135M 0136 0138 IEND I LINKAGE 000402 0136M 0137 K I LINKAGE 000403 0137M 0138 N I ARGUMENT 000050 0119S 0123S 0131 0133 0135 NDIM I ARGUMENT 000045 0119S 0123S 0127S 0131 $1 000012 0135D $1901 000130 0145 0146D $2 000110 0135 0140D $3 000016 0137D $4 000102 0137 0139D $900 000001 0131D $901 000120 0131 0144D 0000 ERRORS [FTN-REV18.2] (0149) (0150) (0151) SUBROUTINE DMTSAD(A,ASUB,S,IROW,ICOL,M,N,MSUB,NSUB,MDIM,NDIM, (0152) 1 MSDIM,NSDIM) (0153) (0154) C ADDS SUBMATRIX S*ASUB TO A (REAL*8) (0155) (0156) INTEGER*2 (0157) I IROW,ICOL, /* INDIZES VON ASUB(1,1) IN A (0158) M M,MSUB, /* AKTUELLE DIMENSIONEN VON A,ASUB (0159) M MDIM,MSDIM, /* MAX.DIMENSION VON A , ASUB (0160) N N,NSUB, /* AKTUELLE DIMENSIONEN VON A,ASUB (0161) N NDIM,NSDIM /* MAX.DIMENSION VON A , ASUB (0162) (0163) REAL *8 (0164) A A(MDIM,NDIM), /* GANZE MATRIX (0165) A ASUB(MSDIM,NSDIM),/*SUB-MATRIX (0166) S S, /* SCALAR FACTOR (0167) S SASUB (0168) (0169) LOGICAL LS1 (0170) (0171) C PRUEFEN DER ARRAYGRENZEN (0172) 905 IF(IROW.LT.1.OR.IROW+MSUB.GT.M+1.OR.ICOL.LT.1.OR.ICOL+NSUB.GT.N+1) (0173) 1 GOTO 906 (0174) (0175) IF(M.EQ.0.OR.N.EQ.0.OR.MSUB.EQ.0.OR.NSUB.EQ.0) RETURN (0176) IF(S.EQ.0.D0) RETURN (0177) LS1 = .FALSE. (0178) IF(S.EQ.1.D0) LS1 = .TRUE. (0179) (0180) 1 DO 2 I=1,MSUB (0181) IA=IROW+I-1 (0182) 3 DO 4 K=1,NSUB (0183) KA=ICOL+K-1 (0184) SASUB = ASUB(I,K) (0185) IF(.NOT.LS1) SASUB = S * SASUB (0186) A(IA,KA) = A(IA,KA) + SASUB (0187) 4 CONTINUE (0188) 2 CONTINUE (0189) RETURN (0190) (0191) C FEHLERMELDUNG (0192) 906 CONTINUE (0193) WRITE(1,9906)IROW,MSUB,M,ICOL,NSUB,N (0194) 9906 FORMAT(' ***ARRAY-UEBERSCHREITUNG (DMTSAD)***'/3I3/3I3/) (0195) RETURN (0196) END PROGRAM SIZE: PROCEDURE - 000372 LINKAGE - 000040 STACK - 000120 A D ARGUMENT 000046 0151S 0163S 0186M ASUB D ARGUMENT 000051 0151S 0163S 0184 I I LINKAGE 000401 0180M 0181 0184 IA I LINKAGE 000402 0181M 0186 ICOL I ARGUMENT 000062 0151S 0156S 0172 0183 0193 IROW I ARGUMENT 000057 0151S 0156S 0172 0181 0193 K I LINKAGE 000403 0182M 0183 0184 KA I LINKAGE 000404 0183M 0186 LS1 L LINKAGE 000400 0169S 0177M 0178M 0185 M I ARGUMENT 000065 0151S 0156S 0172 0175 0193 MSUB I ARGUMENT 000073 0151S 0156S 0172 0175 0180 0193 N I ARGUMENT 000070 0151S 0156S 0172 0175 0193 NSUB I ARGUMENT 000076 0151S 0156S 0172 0175 0182 0193 S D ARGUMENT 000054 0151S 0163S 0176 0178 0185 SASUB D LINKAGE 000426 0163S 0184M 0185M 0186 $1 000112 0180D $2 000242 0180 0188D $3 000120 0182D $4 000233 0182 0187D $905 000001 0172D $906 000252 0172 0192D $9906 000326 0193 0194D 0000 ERRORS [FTN-REV18.2] (0197) (0198) SUBROUTINE DCHOL1(C,A,NDIM,N,INDEF) (0199) C AUFLOESUNG DES SYMMETRISCH DEFINITEN GLEICHUNGSSYSTEMS A*X+B = 0 (0200) C NACH CHOLESKY (0201) C 1. SCHRITT: REDUKTION VON A AUF EINE OBERE DREIECKSMATRIX (0202) (0203) INTEGER*2 (0204) I INDEF, /* INDEF=0 FUER A: POS.-DEFINIT, ANDERNFALLS INDEF=1 (0205) N N, /* AKTUELLE DIMENSION DER KOEFFIZIENTEN-MATRIX (0206) N NDIM /* MAX. DIMENSION DER KOEFFIZIENTEN-MATRIX (0207) (0208) REAL*8 (0209) A A(NDIM,NDIM), /* KOEFFIZIENTEN-MATRIX (0210) C C(NDIM,NDIM) /* OBERE DREIECKSMATRIX (0211) (0212) INDEF=0 (0213) 1 DO 2 I=1,N (0214) 11 IF(A(I,I).LE.1.D-12) GOTO 12 (0215) 14 CONTINUE (0216) (0217) C LINKE SEITE VON C NULL SETZEN (0218) I1=I-1 (0219) 9 DO 10 JL=1,I1 (0220) C(I,JL) = 0.D0 (0221) 10 CONTINUE (0222) (0223) (0224) C REDUKTION DER ZEILEN (0225) C(I,I) = DSQRT(A(I,I)) (0226) M = I+1 (0227) 3 DO 4 J=M,N (0228) C(I,J) = A(I,J)/C(I,I) (0229) 4 CONTINUE (0230) (0231) C REDUZIERTE OBERE DREIECKSMATRIX (0232) 5 DO 6 J=M,N (0233) 7 DO 8 K=J,N (0234) A(J,K) = A(J,K) - C(I,J)*C(I,K) (0235) 8 CONTINUE (0236) 6 CONTINUE (0237) 2 CONTINUE (0238) INDEF=0 (0239) RETURN (0240) 12 CONTINUE (0241) INDEF=1 (0242) WRITE(1,1901)I,A(I,I) (0243) WRITE(6,1901)I,A(I,I) (0244) 1901 FORMAT(1H ,'*** A INDEF. IN DCHOL1: I = ',I3,' ,A(I,I) = ',E13.6, (0245) 1 ' ***'/) (0246) A(I,I) = A(I,I) + 1.D9 (0247) 13 GOTO 14 (0248) END PROGRAM SIZE: PROCEDURE - 000702 LINKAGE - 000044 STACK - 000072 A D ARGUMENT 000045 0198S 0208S 0214 0225A 0228 0234M 0242 0243 0246M C D ARGUMENT 000042 0198S 0208S 0220M 0225M 0228M 0234 DSQR$X J EXTERNAL 000000 0227 DSQRT D EXTERNAL 000000 0225 I I LINKAGE 000400 0213M 0214 0218 0220 0225 0226 0228 0234 0242 0243 0246 I1 I LINKAGE 000401 0218M 0219 INDEF I ARGUMENT 000056 0198S 0203S 0212M 0238M 0241M J I LINKAGE 000404 0227M 0228 0232M 0233 0234 JL I LINKAGE 000402 0219M 0220 K I LINKAGE 000405 0233M 0234 M I LINKAGE 000403 0226M 0227 0232 N I ARGUMENT 000053 0198S 0203S 0213 0227 0232 0233 $1 000004 0213D $10 000104 0219 0221D $11 000006 0214D $12 000430 0214 0240D $13 000661 0247D $14 000043 0215D 0247 $1901 000561 0242 0243 0244D $2 000415 0213 0237D $3 000162 0227D $4 000256 0227 0229D $5 000265 0232D $6 000406 0232 0236D $7 000267 0233D $8 000377 0233 0235D $9 000046 0219D 0000 ERRORS [FTN-REV18.2] (0249) (0250) SUBROUTINE DMTOUT(A,NDIM,MDIM,N,M,IOUT,IF1,IF2) (0251) C% (0252) C% OUTPUT VON GROSSEN MATRIZEN (DOUBLE PRECISION) (0253) DIMENSION A(NDIM,MDIM) (0254) REAL*8 A /* ZU DRUCKENDE MATRIX (0255) INTEGER*2 (0256) I IOUT, /* OUTPUT FTN-UNIT NUMMER (0257) I IF1, /* 'F' OR 'D' FORMAT (0258) I IF2, /* ANZ. DEZ.STELLEN DER ELEMENTE VON A (D12.'IF') (0259) N N,NDIM, /* AKTUELLE UND MAX.DIMENSION VON A (0260) M M,MDIM /* AKTUELLE UND MAX.DIMENSION VON A (0261) INTEGER*2 I,IFORM(20),J,K,MA,ME (0262) (0263) DATA IFORM/'(','1','H',' ','/',' ','1','X',',','I','3',',','1', (0264) 1 '0','D','1','2','.','0',')'/ (0265) (0266) C% BUNDESAMT FUER LANDESTOPOGRAPHIE (0267) C% D.SCHNEIDER (0268) C% WABERN 1981 (0269) C% (0270) C FORMAT FESTLEGEN (0271) IFORM(15) = IF1 (0272) IFORM(19) = IF2 (0273) (0274) C MATRIX DRUCKEN (0275) IF(M.EQ.0.OR.N.EQ.0) RETURN (0276) MA=1 (0277) ME=10 (0278) 1 DO 2 K=1,10 (0279) IF(ME.GT.M) ME=M (0280) WRITE(IOUT,2001)(J,J=MA,ME) (0281) 3 DO 4 I=1,N (0282) WRITE(IOUT,IFORM)I,(A(I,J),J=MA,ME) (0283) 4 CONTINUE (0284) IF(ME.GE.M) RETURN (0285) MA=MA+10 (0286) 2 ME=ME+10 (0287) RETURN (0288) 2001 FORMAT(1H / 6X,10(I3,9X)) (0289) END PROGRAM SIZE: PROCEDURE - 000224 LINKAGE - 000064 STACK - 000076 A D ARGUMENT 000044 0250S 0253S 0254S 0282 I I LINKAGE 000406 0261S 0281M 0282 IF1 I ARGUMENT 000066 0250S 0255S 0271 IF2 I ARGUMENT 000071 0250S 0255S 0272 IFORM I LINKAGE 000430 0261S 0263I 0271M 0272M 0282 IOUT I ARGUMENT 000063 0250S 0255S 0280 0282 J I LINKAGE 000404 0261S 0280M 0282M K I LINKAGE 000403 0261S 0278M M I ARGUMENT 000060 0250S 0255S 0275 0279 0284 MA I LINKAGE 000400 0261S 0276M 0280 0282 0285M ME I LINKAGE 000402 0261S 0277M 0279M 0280 0282 0284 0286M N I ARGUMENT 000055 0250S 0255S 0275 0281 $1 000030 0278D $2 000173 0278 0286D $2001 000205 0280 0288D $3 000066 0281D $4 000154 0281 0283D 0000 ERRORS [FTN-REV18.2] (0290) (0291) SUBROUTINE DMTADD(C,A,B,DIMN,DIMM,N,M) (0292) C% (0293) C% MATRIZENADDITION (DOUBLE PRECISION): C(N,M) = A(N,M)*B(N,M) (0294) C% N,M : AKTUELLE DIMENSIONEN (0295) C% DIMN,DIMM : DIMENSIONEN IM HAUPTPROGRAMM (0296) C% (0297) INTEGER*2 N,M,DIMN,DIMM (0298) REAL*8 A,B,C (0299) DIMENSION A(DIMN,DIMM),B(DIMN,DIMM),C(DIMN,DIMM) (0300) (0301) C TEST DER ARRAYDIMENSIONEN: (0302) 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 (0303) WRITE(1,9901)N,DIMN,M,DIMM (0304) 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTADD***'/ (0305) 1 'N = ',I4,' DIMN = ',I4/ (0306) 2 'M = ',I4,' DIMM = ',I4/) (0307) 22 CONTINUE (0308) (0309) IF(N.EQ.0.OR.M.EQ.0) RETURN (0310) 1 DO 2 I=1,N (0311) 3 DO 4 J=1,M (0312) C(I,J) = A(I,J)+B(I,J) (0313) 4 CONTINUE (0314) 2 CONTINUE (0315) RETURN (0316) END PROGRAM SIZE: PROCEDURE - 000262 LINKAGE - 000032 STACK - 000100 A D ARGUMENT 000047 0291S 0298S 0299S 0312 B D ARGUMENT 000052 0291S 0298S 0299S 0312 C D ARGUMENT 000044 0291S 0298S 0299S 0312M DIMM I ARGUMENT 000060 0291S 0297S 0299S 0302 0303 DIMN I ARGUMENT 000055 0291S 0297S 0299S 0302 0303 I I LINKAGE 000401 0310M 0312 J I LINKAGE 000402 0311M 0312 M I ARGUMENT 000066 0291S 0297S 0302 0303 0309 0311 N I ARGUMENT 000063 0291S 0297S 0302 0303 0309 0310 $1 000156 0310D $2 000245 0310 0314D $21 000001 0302D $22 000143 0302 0307D $3 000160 0311D $4 000236 0311 0313D $9901 000057 0303 0304D 0000 ERRORS [FTN-REV18.2] SUBROUTINE DMTINV(AIN,A,DIMN,N,ISING) C% (0317) SUBROUTINE DMTINV(AIN,A,DIMN,N,ISING) (0318) C% (0319) C% INVERTIEREN DER MATRIX A(N,N) (DOUBLE PECISION) (0320) C% NACH DER DIAGONAL STRATEGIE (0321) C% MAX.DIMENSION : N=200 (0322) C% (0323) C% N,M: AKTUELLE DIMENSIONEN VON A UND AIN (0324) C% DIMN,DIMM: DIMENSIONEN VON A UND AIN IM HAUPTPROGRAMM (0325) INTEGER*2 N,DIMN,ISING (0326) INTEGER*2 I,J,P (0327) REAL*8 A,AIN (0328) REAL*8 KZ (0329) DIMENSION A(DIMN,DIMN),AIN(DIMN,DIMN) (0330) DIMENSION KZ(200) (0331) (0332) C TEST DER ARRAYDIMENSIONEN: (0333) 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 (0334) WRITE(1,9901)N,DIMN,M,DIMM (0335) 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTINV***'/ (0336) 1 'N = ',I4,' DIMN = ',I4/ (0337) 2 'M = ',I4,' DIMM = ',I4/) (0338) 22 CONTINUE (0339) (0340) ISING = 0 (0341) 1 DO 2 I=1,N (0342) 3 DO4 J=1,N (0343) AIN(I,J)=A(I,J) (0344) 4 CONTINUE (0345) 2 CONTINUE (0346) (0347) C AUSTAUSCHVERFAHREN (0348) C (0349) 7 DO 8 P=1,N (0350) C TEST DER PIVOTS (0351) 31 IF((DABS(AIN(P,P)).GT.1.D-16.OR.DABS(AIN(P,P)).LT.1.D16).AND. (0352) 1 (DABS(AIN(P,P)).GT.DABS(A(P,P))*1.D-16)) GOTO 32 (0353) WRITE(1,2001)P,P,AIN(P,P) (0354) ISING=P (0355) 5 DO 6 I=1,N (0356) AIN(P,I)=0.D0 (0357) AIN(I,P)=0.D0 (0358) 6 CONTINUE (0359) AIN(P,P)=1.D30 (0360) GOTO 8 (0361) 32 CONTINUE (0362) (0363) C PIVOTELEMENT (0364) AIN(P,P)=1.D0/AIN(P,P) (0365) (0366) C KELLERZEILE SETZEN (0367) 11 DO 12 I=1,N (0368) KZ(I)=-AIN(P,I)*AIN(P,P) (0369) 12 CONTINUE (0370) (0371) C UEBRIGE ELEMENTE BERECHNEN (0372) 13 DO 14 I=1,N (0373) 23 IF(I.EQ.P) GOTO 24 (0374) 15 DO 16 J=1,N (0375) 25 IF(J.EQ.P)GOTO 26 (0376) AIN(I,J)=KZ(J)*AIN(I,P)+AIN(I,J) (0377) 26 CONTINUE (0378) 16 CONTINUE (0379) 24 CONTINUE (0380) 14 CONTINUE (0381) (0382) C ELEMENTE IN DER PIVOTZEILE (0383) 17 DO 18 J=1,N (0384) 27 IF(J.EQ.P)GOTO 28 (0385) AIN(P,J)=-AIN(P,J)*AIN(P,P) (0386) 28 CONTINUE (0387) 18 CONTINUE (0388) (0389) C ELEMENTE IN DER PIVOTKOLONNE (0390) 19 DO 20 I=1,N (0391) 29 IF(I.EQ.P)GOTO 30 (0392) AIN(I,P)=AIN(I,P)*AIN(P,P) (0393) 30 CONTINUE (0394) 20 CONTINUE (0395) 8 CONTINUE (0396) RETURN (0397) 2001 FORMAT(1H ,'***PIVOT(',I3,',',I3,') = ',D12.4,' UND WIRD = 1D30 ', (0398) 1'GESETZT***'/) (0399) END PROGRAM SIZE: PROCEDURE - 001332 LINKAGE - 001506 STACK - 000100 A D ARGUMENT 000047 0317S 0327S 0329S 0343 0351A AIN D ARGUMENT 000044 0317S 0327S 0329S 0343M 0351A 0353 0356M 0357M 0359M 0364M 0368 0376M 0385M 0392M DABS D EXTERNAL 000000 0351 DIMM R LINKAGE 002070 0333 0334 DIMN I ARGUMENT 000052 0317S 0325S 0329S 0333 0334 I I LINKAGE 000403 0326S 0341M 0343 0355M 0356 0357 0367M 0368 0372M 0373 0376 0390M 0391 0392 ISING I ARGUMENT 000060 0317S 0325S 0340M 0354M J I LINKAGE 000404 0326S 0342M 0343 0374M 0375 0376 0383M 0384 0385 KZ D LINKAGE 000430 0328S 0330S 0368M 0376 M I LINKAGE 000400 0333 0334 N I ARGUMENT 000055 0317S 0325S 0333 0334 0341 0342 0349 0355 0367 0372 0374 0383 0390 P I LINKAGE 000405 0326S 0349M 0351 0353 0354 0356 0357 0359 0364 0368 0373 0375 0376 0384 0385 0391 0392 $1 000146 0341D $11 000615 0367D $12 000704 0367 0369D $13 000713 0372D $14 001024 0372 0380D $15 000721 0374D $16 001015 0374 0378D $17 001033 0383D $18 001124 0383 0387D $19 001133 0390D $2 000225 0341 0345D $20 001214 0390 0394D $2001 001233 0353 0397D $21 000001 0333D $22 000143 0333 0338D $23 000715 0373D $24 001024 0373 0379D $25 000723 0375D $26 001015 0375 0377D $27 001035 0384D $28 001124 0384 0386D $29 001135 0391D $3 000150 0342D $30 001214 0391 0393D $31 000236 0351D $32 000560 0351 0361D $4 000216 0342 0344D $5 000425 0355D $6 000515 0355 0358D $7 000234 0349D $8 001223 0349 0360 0395D $9901 000057 0334 0335D 0000 ERRORS [FTN-REV18.2] SUBROUTINE DMTSUB(C,A,B,DIMN,DIMM,N,M) C% (0400) SUBROUTINE DMTSUB(C,A,B,DIMN,DIMM,N,M) (0401) C% (0402) C% MATRIZENSUBTRAKTION (DOUBLE PRECISION): C(N,M) = A(N,M)*B(N,M) (0403) C% N,M : AKTUELLE DIMENSIONEN (0404) C% DIMN,DIMM : DIMENSIONEN IM HAUPTPROGRAMM (0405) C% (0406) INTEGER*2 N,M,DIMN,DIMM (0407) REAL*8 A,B,C (0408) DIMENSION A(DIMN,DIMM),B(DIMN,DIMM),C(DIMN,DIMM) (0409) (0410) C TEST DER ARRAYDIMENSIONEN: (0411) 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 (0412) WRITE(1,9901)N,DIMN,M,DIMM (0413) 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTSUB***'/ (0414) 1 'N = ',I4,' DIMN = ',I4/ (0415) 2 'M = ',I4,' DIMM = ',I4/) (0416) 22 CONTINUE (0417) IF(N.EQ.0.OR.M.EQ.0) RETURN (0418) (0419) 1 DO 2 I=1,N (0420) 3 DO 4 J=1,M (0421) C(I,J) = A(I,J)-B(I,J) (0422) 4 CONTINUE (0423) 2 CONTINUE (0424) RETURN (0425) END PROGRAM SIZE: PROCEDURE - 000262 LINKAGE - 000032 STACK - 000100 A D ARGUMENT 000047 0400S 0407S 0408S 0421 B D ARGUMENT 000052 0400S 0407S 0408S 0421 C D ARGUMENT 000044 0400S 0407S 0408S 0421M DIMM I ARGUMENT 000060 0400S 0406S 0408S 0411 0412 DIMN I ARGUMENT 000055 0400S 0406S 0408S 0411 0412 I I LINKAGE 000401 0419M 0421 J I LINKAGE 000402 0420M 0421 M I ARGUMENT 000066 0400S 0406S 0411 0412 0417 0420 N I ARGUMENT 000063 0400S 0406S 0411 0412 0417 0419 $1 000156 0419D $2 000245 0419 0423D $21 000001 0411D $22 000143 0411 0416D $3 000160 0420D $4 000236 0420 0422D $9901 000057 0412 0413D 0000 ERRORS [FTN-REV18.2] C% C% (0426) C% (0427) SUBROUTINE DMTSCL(C,A,S,DIMN,DIMM,N,M) (0428) C% (0429) C% MULTIPLIKATION MATRIX*SKALAR (DOUBLE PRECISION): C(N,M)=A(N,M)*S (0430) C% N,M : AKTUELLE DIMENSIONEN (0431) C% DIMN,DIMM : DIMENSIONEN IM HAUPTPROGRAMM (0432) C% (0433) INTEGER*2 N,M,DIMN,DIMM (0434) REAL*8 A,C,S (0435) DIMENSION A(DIMN,DIMM),C(DIMN,DIMM) (0436) C% (0437) C TEST DER ARRAYDIMENSIONEN: (0438) 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 (0439) WRITE(1,9901)N,DIMN,M,DIMM (0440) 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTSCL***'/ (0441) 1 'N = ',I4,' DIMN = ',I4/ (0442) 2 'M = ',I4,' DIMM = ',I4/) (0443) 22 CONTINUE (0444) IF(N.EQ.0.OR.M.EQ.0) RETURN (0445) (0446) 31 IF(S.EQ.0.D0) GOTO 32 (0447) (0448) 1 DO 2 I=1,N (0449) 3 DO 4 J=1,M (0450) C(I,J)=A(I,J)*S (0451) 4 CONTINUE (0452) 2 CONTINUE (0453) RETURN (0454) (0455) 32 CONTINUE (0456) 5 DO 6 I=1,N (0457) 7 DO 8 J=1,M (0458) C(I,J) = 0.D0 (0459) 8 CONTINUE (0460) 6 CONTINUE (0461) RETURN (0462) END PROGRAM SIZE: PROCEDURE - 000342 LINKAGE - 000032 STACK - 000076 A D ARGUMENT 000047 0427S 0434S 0435S 0450 C D ARGUMENT 000044 0427S 0434S 0435S 0450M 0458M DIMM I ARGUMENT 000060 0427S 0433S 0435S 0438 0439 DIMN I ARGUMENT 000055 0427S 0433S 0435S 0438 0439 I I LINKAGE 000401 0448M 0450 0456M 0458 J I LINKAGE 000402 0449M 0450 0457M 0458 M I ARGUMENT 000066 0427S 0433S 0438 0439 0444 0449 0457 N I ARGUMENT 000063 0427S 0433S 0438 0439 0444 0448 0456 S D ARGUMENT 000052 0427S 0434S 0446 0450 $1 000162 0448D $2 000243 0448 0452D $21 000001 0438D $22 000143 0438 0443D $3 000164 0449D $31 000156 0446D $32 000253 0446 0455D $4 000234 0449 0451D $5 000253 0456D $6 000322 0456 0460D $7 000255 0457D $8 000313 0457 0459D $9901 000057 0439 0440D 0000 ERRORS [FTN-REV18.2] (0463) (0464) SUBROUTINE DMTTRS(C,A,M,N,DIMM,DIMN) (0465) C% MATRIX TRANSPONIEREN (DOUBLE PRECISION): C(DIMM,DIMN)= (0466) C% A(DIMN,DIMM)T (0467) C% (0468) C% N,M: AKTUELLE DIMENSIONEN (0469) C% DIMN,DIMM: DIMENSIONEN IM HAUPTPROGRAMM (0470) C% (0471) INTEGER*2 N,M,DIMN,DIMM (0472) REAL*8 A,C (0473) DIMENSION A(DIMN,DIMM),C(DIMM,DIMN) (0474) C% (0475) C TEST DER ARRAYDIMENSIONEN: (0476) 21 IF(N.LE.DIMN.AND.M.LE.DIMM)GOTO 22 (0477) WRITE(1,9901)N,DIMN,M,DIMM (0478) 9901 FORMAT(1H ,'***FALSCHE ARRAYDIMENSIONIERUNG IN DMTTRS***'/ (0479) 1 'N = ',I4,' DIMN = ',I4/ (0480) 2 'M = ',I4,' DIMM = ',I4/) (0481) 22 CONTINUE (0482) IF(N.EQ.0.OR.M.EQ.0) RETURN (0483) (0484) 1 DO 2 I=1,N (0485) 3 DO 4 J=1,M (0486) C(J,I) = A(I,J) (0487) 4 CONTINUE (0488) 2 CONTINUE (0489) RETURN (0490) END PROGRAM SIZE: PROCEDURE - 000274 LINKAGE - 000032 STACK - 000074 A D ARGUMENT 000047 0464S 0472S 0473S 0486 C D ARGUMENT 000044 0464S 0472S 0473S 0486M DIMM I ARGUMENT 000060 0464S 0471S 0473S 0476 0477 DIMN I ARGUMENT 000063 0464S 0471S 0473S 0476 0477 I I LINKAGE 000401 0484M 0486 J I LINKAGE 000402 0485M 0486 M I ARGUMENT 000052 0464S 0471S 0476 0477 0482 0485 N I ARGUMENT 000055 0464S 0471S 0476 0477 0482 0484 $1 000156 0484D $2 000257 0484 0488D $21 000001 0476D $22 000143 0476 0481D $3 000160 0485D $4 000250 0485 0487D $9901 000057 0477 0478D 0000 ERRORS [FTN-REV18.2] (0491) (0492) SUBROUTINE DMREAL(CPXA,A,MDIM,NDIM,M2DIM,N2DIM,M,N) (0493) COMPLEX*8 CPXA(MDIM,NDIM),CPXAIJ (0494) REAL*8 A(M2DIM,N2DIM) (0495) (0496) 1 DO 2 I=1,M (0497) I2=2*I (0498) I1=I2-1 (0499) 3 DO 4 J=1,N (0500) J2=2*J (0501) J1=J2-1 (0502) CPXAIJ = CPXA(I,J) (0503) A(I1,J1)=REAL(CPXAIJ) (0504) A(I1,J2)=-AIMAG(CPXAIJ) (0505) A(I2,J1)=AIMAG(CPXAIJ) (0506) A(I2,J2)=REAL(CPXAIJ) (0507) 4 CONTINUE (0508) 2 CONTINUE (0509) RETURN (0510) END PROGRAM SIZE: PROCEDURE - 000246 LINKAGE - 000042 STACK - 000102 A D ARGUMENT 000045 0492S 0494S 0503M 0504M 0505M 0506M AIMAG R EXTERNAL 000000 0504 0505 CPXA C ARGUMENT 000042 0492S 0493S 0502 CPXAIJ C LINKAGE 000432 0493S 0502M 0503A 0504A 0505A 0506A I I LINKAGE 000400 0496M 0497 0502 I1 I LINKAGE 000402 0498M 0503 0504 I2 I LINKAGE 000401 0497M 0498 0505 0506 J I LINKAGE 000403 0499M 0500 0502 J1 I LINKAGE 000405 0501M 0503 0505 J2 I LINKAGE 000404 0500M 0501 0504 0506 M I ARGUMENT 000064 0492S 0496 N I ARGUMENT 000067 0492S 0499 REAL R EXTERNAL 000000 0503 0506 $1 000001 0496D $2 000231 0496 0508D $3 000007 0499D $4 000222 0499 0507D 0000 ERRORS [FTN-REV18.2] (0511) (0512) SUBROUTINE CMTMLT(C,A,B,NDIM,MDIM,LDIM,N,M,L) (0513) (0514) C PRODUCT OF TWO COMPLEX MATRICES (0515) COMPLEX*8 (0516) A A(NDIM,MDIM), (0517) B B(MDIM,LDIM), (0518) C C(NDIM,LDIM) (0519) (0520) 1 DO 2 I=1,N (0521) 3 DO 4 J=1,L (0522) C(I,J) = (0.,0.) (0523) 5 DO 6 K=1,M (0524) C(I,J) = A(I,K) * B(K,J) + C(I,J) (0525) 6 CONTINUE (0526) 4 CONTINUE (0527) 2 CONTINUE (0528) RETURN (0529) END PROGRAM SIZE: PROCEDURE - 000224 LINKAGE - 000034 STACK - 000110 A C ARGUMENT 000045 0512S 0515S 0524 B C ARGUMENT 000050 0512S 0515S 0524 C C ARGUMENT 000042 0512S 0515S 0522M 0524M I I LINKAGE 000400 0520M 0522 0524 J I LINKAGE 000401 0521M 0522 0524 K I LINKAGE 000402 0523M 0524 L I ARGUMENT 000072 0512S 0521 M I ARGUMENT 000067 0512S 0523 N I ARGUMENT 000064 0512S 0520 $1 000001 0520D $2 000203 0520 0527D $3 000003 0521D $4 000174 0521 0526D $5 000045 0523D $6 000165 0523 0525D 0000 ERRORS [FTN-REV18.2] (0530) (0531) SUBROUTINE DRMINV(B,A,NDIM,N,IERR) (0532) C INVERSE 'B' OF RIGHT RECTANGULAR MATRIX 'A' (REAL*8) (0533) C (NOTE: 'A' AND 'B' MAY BE EQUAL IN CALLING STATEMENT) (0534) (0535) INTEGER*2 (0536) N N, /* ACTUAL DIMENSION OF A,B (0537) N NDIM /* MAX. DIMENSION OF A,B (0538) (0539) REAL*8 (0540) A A(NDIM,NDIM), /* ORIG. RIGHT RECTANGULAR MATRIX (0541) A AII, (0542) B B(NDIM,NDIM), /* INVERSE OF A (0543) S S (0544) (0545) C TEST ELEMENTS ON LEFT SIDE OF 'A' (0546) 1 DO 2 I=2,N (0547) I1=I-1 (0548) 3 DO 4 J=1,I1 (0549) 900 IF(ABS(A(I,J)).GT.1.D-12) GOTO 901 (0550) B(I,J) = 0.D0 (0551) 4 CONTINUE (0552) 2 CONTINUE (0553) (0554) C COMPUTE INVERSE 'B' ROW BY ROW (0555) 5 DO 6 II=1,N (0556) I=N-II+1 (0557) I1 = I+1 (0558) AII = A(I,I) (0559) 902 IF(DABS(AII).LT.1.D-12) GOTO 903 (0560) 7 DO 8 KK=I1,N (0561) K=N-KK+I1 (0562) S = 0.D0 (0563) 9 DO 10 JJ=I1,K (0564) J=K-JJ+I1 (0565) S = S + A(I,J) * B(J,K) (0566) 10 CONTINUE (0567) B(I,K) = -S/AII (0568) 8 CONTINUE (0569) B(I,I) = 1.D0/AII (0570) 6 CONTINUE (0571) (0572) RETURN (0573) (0574) C ERROR MESSAGES (0575) 901 CONTINUE (0576) WRITE(1,9901)I,J,A(I,J) (0577) 9901 FORMAT(' ***ELEMENT A(',I2,',',I2,')=',E12.4,'>1.D-12 IN RMINV***' (0578) 1/) (0579) A(I,J) = 0.D0 (0580) GOTO 900 (0581) (0582) 903 CONTINUE (0583) WRITE(1,9903) I,I,AII (0584) 9903 FORMAT(' ***DIAGONAL ELEMENT A(',I2,',',I2,')=',E12.4,'<1.D-12 IN' (0585) 1 ,' RMINV***'/) (0586) AII = 1.D-12 (0587) IERR = I (0588) GOTO 902 (0589) END PROGRAM SIZE: PROCEDURE - 000720 LINKAGE - 000056 STACK - 000070 A D ARGUMENT 000045 0531S 0539S 0549A 0558 0565 0576 0579M ABS R EXTERNAL 000000 0549 AII D LINKAGE 000434 0539S 0558M 0559A 0567 0569 0583 0586M B D ARGUMENT 000042 0531S 0539S 0550M 0565 0567M 0569M DABS D EXTERNAL 000000 0559 I I LINKAGE 000401 0546M 0547 0549 0550 0556M 0557 0558 0565 0567 0569 0576 0579 0583 0587 I1 I LINKAGE 000402 0547M 0548 0557M 0560 0561 0563 0564 IERR I ARGUMENT 000056 0531S 0587M II I LINKAGE 000404 0555M 0556 J I LINKAGE 000403 0548M 0549 0550 0564M 0565 0576 0579 JJ I LINKAGE 000407 0563M 0564 K I LINKAGE 000406 0561M 0563 0564 0565 0567 KK I LINKAGE 000405 0560M 0561 N I ARGUMENT 000053 0531S 0535S 0546 0555 0556 0560 0561 S D LINKAGE 000442 0539S 0562M 0565M 0567 $1 000001 0546D $10 000264 0563 0566D $2 000073 0546 0552D $3 000005 0548D $4 000065 0548 0551D $5 000102 0555D $6 000376 0555 0570D $7 000157 0560D $8 000332 0560 0568D $9 000172 0563D $900 000007 0549D 0580 $901 000406 0549 0575D $902 000146 0559D 0588 $903 000567 0559 0582D $9901 000471 0576 0577D $9903 000621 0583 0584D 0000 ERRORS [FTN-REV18.2] (0590) (0591) SUBROUTINE DSISRT(V,A,NDIM,MDIM,N,M) (0592) C SIMULTANEOUS SORTING OF VECTOR 'V' AND REARANGING OF COLUMN (0593) C VECTORS OF MATRIC 'A' (REAL*8) ( N < NDIM < 200 ) (0594) (0595) REAL*8 (0596) A A(NDIM,MDIM), (0597) U U, (0598) V V(MDIM) (0599) (0600) M1=M-1 (0601) 1 DO 2 I=1,M1 (0602) J=I (0603) I1=I+1 (0604) 3 DO 4 K=I1,M (0605) IF(DABS(V(K)).GT.DABS(V(J))) J = K (0606) 4 CONTINUE (0607) U = V(I) (0608) V(I) = V(J) (0609) V(J) = U (0610) 5 DO 6 IN=1,N (0611) U = A(IN,I) (0612) A(IN,I) = A(IN,J) (0613) A(IN,J) = U (0614) 6 CONTINUE (0615) 2 CONTINUE (0616) RETURN (0617) END PROGRAM SIZE: PROCEDURE - 000240 LINKAGE - 000034 STACK - 000076 A D ARGUMENT 000045 0591S 0595S 0611 0612M 0613M DABS D EXTERNAL 000000 0605 I I LINKAGE 000401 0601M 0602 0603 0607 0608 0611 0612 I1 I LINKAGE 000403 0603M 0604 IN I LINKAGE 000405 0610M 0611 0612 0613 J I LINKAGE 000402 0602M 0605M 0608 0609 0612 0613 K I LINKAGE 000404 0604M 0605 M I ARGUMENT 000061 0591S 0600 0604 M1 I LINKAGE 000400 0600M 0601 N I ARGUMENT 000056 0591S 0610 U D LINKAGE 000430 0595S 0607M 0609 0611M 0613 V D ARGUMENT 000042 0591S 0595S 0605A 0607 0608M 0609M $1 000005 0601D $2 000225 0601 0615D $3 000012 0604D $4 000056 0604 0606D $5 000123 0610D $6 000216 0610 0614D 0000 ERRORS [FTN-REV18.2] (0618) (0619) SUBROUTINE DMTSYM(A,NDIM,N) (0620) C (0621) C **************************************************************** (0622) C * * (0623) C * WRITTEN BY D.SCHNEIDER * (0624) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0625) C * CH-3084 WABERN, 1981 * (0626) C * * (0627) C **************************************************************** (0628) C (0629) (0630) C DUPLICATE ELEMENTS IN UPPER HALF FILLED SYMMETRIC MATRICE (0631) (0632) INTEGER*2 (0633) N N, /* ACTUAL SIZE OF MATRIX (0634) N NDIM /* DIMENSION OF A (0635) (0636) REAL*8 (0637) A A(NDIM,NDIM) /* UPPER HALF FILLED MATRIX / SYMM. MATRIX (0638) (0639) C CHECK ARRAY DIMENSIONS (0640) 900 IF(N.GT.NDIM) GOTO 901 (0641) (0642) 1 DO 2 I=2,N (0643) IEND=I-1 (0644) 3 DO 4 K=1,IEND (0645) A(I,K) = A(K,I) (0646) 4 CONTINUE (0647) 2 CONTINUE (0648) RETURN (0649) (0650) C ERROR MESSAGES (0651) 901 CONTINUE (0652) WRITE(1,1901) (0653) 1901 FORMAT(' ***ARRAY SIZE EXCEEDS DIMENSIONS IN "DMTSYM"***'/) (0654) RETURN (0655) END PROGRAM SIZE: PROCEDURE - 000166 LINKAGE - 000032 STACK - 000064 A D ARGUMENT 000042 0619S 0636S 0645M I I LINKAGE 000401 0642M 0643 0645 IEND I LINKAGE 000402 0643M 0644 K I LINKAGE 000403 0644M 0645 N I ARGUMENT 000050 0619S 0632S 0640 0642 NDIM I ARGUMENT 000045 0619S 0632S 0636S 0640 $1 000007 0642D $1901 000125 0652 0653D $2 000105 0642 0647D $3 000013 0644D $4 000077 0644 0646D $900 000001 0640D $901 000115 0640 0651D 0000 ERRORS [FTN-REV18.2] $$$ REAL*8 FUNCTION DCHISQ(X) (0001) REAL*8 FUNCTION DCHISQ(X) (0002) C (0003) C **************************************************************** (0004) C * * (0005) C * WRITTEN BY D.SCHNEIDER * (0006) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0007) C * CH-3084 WABERN, 1981 * (0008) C * * (0009) C **************************************************************** (0010) C (0011) (0012) C DENSITY FUNCTION OF THE CHI-SQUARE PROBABILITY DISTRIBUTION (0013) (0014) REAL*8 (0015) C C, (0016) D DGAMMA, (0017) X X /* ARGUMENT OF FUNCTION (0018) (0019) INTEGER*2 (0020) N NDF1, /* DEGREES OF FREEDOM (0021) N NDF2 /* DEGREES OF FREEDOM (0022) (0023) COMMON /STAT/ NDF1,NDF2 (0024) (0025) 1 IF(X.LE.0.D0) GOTO 2 (0026) C = 2.D0**(NDF1/2.D0)* DGAMMA(NDF1) (0027) DCHISQ = X**(NDF1/2.D0 - 1.D0) * DEXP(-X/2.D0) / C (0028) RETURN (0029) 2 CONTINUE (0030) DCHISQ = 0.D0 (0031) RETURN (0032) END PROGRAM SIZE: PROCEDURE - 000132 LINKAGE - 000040 STACK - 000056 C D LINKAGE 000426 0014S 0026M 0027 DCHISQ D LINKAGE 000434 0001S 0027M 0030M DEXP D EXTERNAL 000000 0027 DEXP$X D EXTERNAL 000000 0029 DGAMMA D EXTERNAL 000000 0014S 0026 NDF1 I /STAT/ 000000 0019S 0023S 0026A 0027 X D ARGUMENT 000042 0001S 0014S 0025 0027 $1 000001 0025D $2 000100 0025 0029D 0000 ERRORS [FTN-REV18.2] (0033) (0034) REAL*8 FUNCTION DCCHIS(X) (0035) C (0036) C **************************************************************** (0037) C * * (0038) C * WRITTEN BY D.SCHNEIDER * (0039) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0040) C * CH-3084 WABERN, 1981 * (0041) C * * (0042) C **************************************************************** (0043) C (0044) C CUMULATIVE CHI-SQUARED PROBABILITY DISTRIBUTION FUNCTION (0045) (0046) INTEGER*2 (0047) N NDF1, /* DEGREES OF FREEDOM (0048) N NDF2 /* DEGREES OF FREEDOM (0049) (0050) REAL*8 (0051) D DCHISQ, (0052) F F01, (0053) F F9(15), (0054) G GRZW, /* CRIT. VALUE FOR ITERATION TERMINATION (0055) R RNDF, (0056) R RNDF2, (0057) R ROMINT, (0058) X X,X1 (0059) (0060) LOGICAL KONVER,GTNDF,GTNDF2 (0061) (0062) COMMON /STAT/ NDF1,NDF2 (0063) (0064) EXTERNAL DCHISQ (0065) (0066) DATA (0067) F F01/0.982069D-3/, (0068) F F9/2.70554D0,4.60517D0,6.25139D0,7.77944D0,9.23635D0,10.6446D0, (0069) F 12.0170D0,13.3616D0,14.6837D0,15.9871D0,17.2750D0,18.5494D0, (0070) F 19.8119D0,21.0642D0,22.3072D0/ (0071) (0072) GRZW = 1.D-5 (0073) IF(NDF1.LE.15) GRZW = 1.D-4 (0074) RNDF = NDF1 (0075) RNDF2 = 2*NDF1 (0076) GTNDF = .FALSE. (0077) GTNDF2 = .FALSE. (0078) DCCHIS = 0.D0 (0079) X1 = X (0080) (0081) IF(X.LT.0.D0) GOTO 902 (0082) 8 IF(X.EQ.0.D0) GOTO 9 (0083) IF(X.GT.RNDF) GTNDF = .TRUE. (0084) IF(X.GT.RNDF2) GTNDF2 = .TRUE. (0085) IF(NDF1.EQ.1) GOTO 1 (0086) IF(NDF1.GE.2) GOTO 2 (0087) GOTO 901 (0088) (0089) C 1 DEGREE OF FREEDOM (0090) 1 CONTINUE (0091) 101 IF(.NOT.GTNDF) GOTO 102 (0092) DCCHIS = -ROMINT(DCHISQ,X,F9(1),GRZW,K,KONVER) + 0.9D0 (0093) RETURN (0094) 102 CONTINUE (0095) DCCHIS = DCCHIS - ROMINT(DCHISQ,X1,F01,GRZW,K,KONVER) + 0.025D0 (0096) RETURN (0097) (0098) C NDF>=2 (0099) 2 CONTINUE (0100) (0101) 103 IF(NDF1.GT.15.OR..NOT.GTNDF) GOTO 104 (0102) DCCHIS = - ROMINT(DCHISQ,X,F9(NDF1),GRZW,K,KONVER) + 0.9D0 (0103) RETURN (0104) (0105) 104 CONTINUE (0106) IF(GTNDF2) DCCHIS = - ROMINT(DCHISQ,X,RNDF2,GRZW,K,KONVER) (0107) IF(GTNDF2) X1=RNDF2 (0108) DCCHIS = DCCHIS - ROMINT(DCHISQ,X1,0.D0,GRZW,K,KONVER) (0109) RETURN (0110) (0111) 9 CONTINUE (0112) DCCHIS = 0.D0 (0113) RETURN (0114) 901 CONTINUE (0115) WRITE(1,1901) (0116) 1901 FORMAT(' *** NDF<1 IN DCCHIS ***'/) (0117) RETURN (0118) 902 CONTINUE (0119) WRITE(1,1902) (0120) 1902 FORMAT(' *** X<0. IN DCCHIS ***'/) (0121) RETURN (0122) END PROGRAM SIZE: PROCEDURE - 000422 LINKAGE - 000166 STACK - 000052 DCCHIS D LINKAGE 000546 0034S 0078M 0092M 0095M 0102M 0106M 0108M 0112M DCHISQ D EXTERNAL 000000 0050S 0064S 0092A 0095A 0102A 0106A 0108A F01 D LINKAGE 000430 0050S 0066I 0095A F9 D LINKAGE 000434 0050S 0066I 0092A 0102A GRZW D LINKAGE 000530 0050S 0072M 0073M 0092A 0095A 0102A 0106A 0108A GTNDF L LINKAGE 000401 0060S 0076M 0083M 0091 0101 GTNDF2 L LINKAGE 000402 0060S 0077M 0084M 0106 0107 K I LINKAGE 000405 0092A 0095A 0102A 0106A 0108A KONVER L LINKAGE 000406 0060S 0092A 0095A 0102A 0106A 0108A NDF1 I /STAT/ 000000 0046S 0062S 0073 0074 0075 0085 0086 0101 0102 RNDF D LINKAGE 000536 0050S 0074M 0083 RNDF2 D LINKAGE 000542 0050S 0075M 0084 0106A 0107 ROMINT D EXTERNAL 000000 0050S 0092 0095 0102 0106 0108 X D ARGUMENT 000044 0034S 0050S 0079 0081 0082 0083 0084 0092A 0102A 0106A X1 D LINKAGE 000552 0050S 0079M 0095A 0107M 0108A $1 000104 0085 0090D $101 000104 0091D $102 000133 0091 0094D $103 000161 0101D $104 000226 0101 0105D $1901 000322 0115 0116D $1902 000355 0119 0120D $2 000161 0086 0099D $8 000050 0082D $9 000305 0082 0111D $901 000312 0087 0114D $902 000345 0081 0118D 0000 ERRORS [FTN-REV18.2] (0123) (0124) REAL*8 FUNCTION DICCHI(F) (0125) C (0126) C **************************************************************** (0127) C * * (0128) C * WRITTEN BY D.SCHNEIDER * (0129) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0130) C * CH-3084 WABERN, 1981 * (0131) C * * (0132) C **************************************************************** (0133) C (0134) (0135) C INVERSE CHI-SQUARED CUMULATIVE PDF (FOR X < 10000.) (0136) (0137) INTEGER*2 (0138) N NDF1, /* DEGREES OF FREEDOM (0139) N NDF2 /* DEGREES OF FREEDOM (0140) REAL*8 (0141) D DF, (0142) D DFALSI, (0143) D DCCHIS, (0144) D DX, (0145) F F, (0146) X X(3) (0147) (0148) COMMON /STAT/ NDF1,NDF2 (0149) (0150) EXTERNAL DCCHIS (0151) (0152) X(1) = 0.D0 (0153) IF(F.GE.0.75D0) X(1) = NDF1 (0154) DX = 1.D-2 (0155) IF(NDF1.GT.50) DX = 0.2D0 (0156) IF(NDF1.GT.100) DX = 0.5D0 (0157) IF(NDF1.GT.500) DX = 0.7D0 (0158) (0159) C CHECK INTERVAL OF ARGUMENT (0160) IF(F.GE.1.D0) GOTO 901 (0161) (0162) C APPROX. VALUES X(1),X(2) (0163) 1 DO 2 I=1,20 (0164) X(2) = X(1) + DX (0165) DF = DCCHIS(X(2)) - F (0166) 11 IF(DF.GT.0.D0) GOTO 12 (0167) X(1) = X(2) (0168) DX = 2.D0*DX (0169) 2 CONTINUE (0170) GOTO 902 (0171) 12 CONTINUE (0172) (0173) C REGULA FALSI (0174) DICCHI = DFALSI(DCCHIS,F,X) (0175) RETURN (0176) 901 CONTINUE (0177) WRITE(1,1901) (0178) 1901 FORMAT(' *** F>= 1. ***'/) (0179) RETURN (0180) 902 CONTINUE (0181) WRITE(1,1902) X(2) (0182) 1902 FORMAT(' *** X> ',F8.2,'***'/) (0183) RETURN (0184) END PROGRAM SIZE: PROCEDURE - 000270 LINKAGE - 000074 STACK - 000046 DCCHIS D EXTERNAL 000000 0140S 0150S 0165 0174A DF D LINKAGE 000454 0140S 0165M 0166 DFALSI D EXTERNAL 000000 0140S 0174 DICCHI D LINKAGE 000462 0124S 0174M DX D LINKAGE 000446 0140S 0154M 0155M 0156M 0157M 0164 0168M F D ARGUMENT 000042 0124S 0140S 0153 0160 0165 0174A I I LINKAGE 000403 0163M NDF1 I /STAT/ 000000 0137S 0148S 0153 0155 0156 0157 X D LINKAGE 000430 0140S 0152M 0153M 0164M 0165A 0167M 0174A 0181 $1 000066 0163D $11 000106 0166D $12 000132 0166 0171D $1901 000155 0177 0178D $1902 000211 0181 0182D $2 000124 0163 0169D $901 000145 0160 0176D $902 000173 0170 0180D 0000 ERRORS [FTN-REV18.2] (0185) (0186) REAL*8 FUNCTION DGAMMA(N) (0187) C (0188) C **************************************************************** (0189) C * * (0190) C * WRITTEN BY D.SCHNEIDER * (0191) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0192) C * CH-3084 WABERN, 1981 * (0193) C * * (0194) C **************************************************************** (0195) C (0196) (0197) C GAMMA FUNCTION FOR BETA = 2 (0198) C GAMMA = C(ALFA) = C(N/BETA) = C(N/2) (0199) (0200) INTEGER*2 N,N2 (0201) (0202) REAL*8 PI (0203) (0204) 900 IF(N.LE.0) GOTO 901 (0205) PI = 4.D0*DATAN(1.D0) (0206) DGAMMA = 1.D0 (0207) IF(MOD(N,2).EQ.1) DGAMMA = DSQRT(PI) (0208) (0209) 11 IF(N.LE.2) GOTO 12 (0210) N2 = (N+1)/2 - 1 (0211) 1 DO 2 I=1,N2 (0212) DGAMMA = DGAMMA * (N/2.D0 - I) (0213) 2 CONTINUE (0214) 12 CONTINUE (0215) RETURN (0216) (0217) C ERROR MESSAGE (0218) 901 CONTINUE (0219) WRITE(1,1901) (0220) 1901 FORMAT(' ***ILLEGAL ARGUMENT N<=0 IN FUNCTION DGAMMA***'/) (0221) DGAMMA = 0.D0 (0222) RETURN (0223) END PROGRAM SIZE: PROCEDURE - 000200 LINKAGE - 000044 STACK - 000052 DATAN D EXTERNAL 000000 0205 DATN$X EXTERNAL 000000 0209 DGAMMA D LINKAGE 000432 0186S 0206M 0207M 0212M 0221M DSQR$X I EXTERNAL 000000 0209 DSQRT D EXTERNAL 000000 0207 I I LINKAGE 000402 0211M 0212 MOD I EXTERNAL 000000 0207 N I ARGUMENT 000042 0186S 0200S 0204 0207 0209 0210 0212 N2 I LINKAGE 000401 0200S 0210M 0211 PI D LINKAGE 000426 0202S 0205M 0207A $1 000052 0211D $11 000037 0209D $12 000104 0209 0214D $1901 000117 0219 0220D $2 000076 0211 0213D $900 000001 0204D $901 000107 0204 0218D 0000 ERRORS [FTN-REV18.2] (0224) (0225) REAL*8 FUNCTION ROMINT(FCT,A,B,GRZW,K,KONVER) (0226) C (0227) C **************************************************************** (0228) C * * (0229) C * WRITTEN BY D.SCHNEIDER * (0230) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0231) C * CH-3084 WABERN, 1981 * (0232) C * * (0233) C **************************************************************** (0234) C (0235) (0236) C ROMBERG INTEGRATION (0237) (0238) INTEGER*2 J,L,K (0239) REAL*8 (0240) H H, (0241) T T, (0242) T TOLD, (0243) A A, (0244) B B, (0245) S SF, (0246) M M, (0247) K K1, (0248) G GRZW (0249) (0250) DIMENSION T(20,2) (0251) (0252) LOGICAL KONVER (0253) (0254) EXTERNAL FCT (0255) (0256) KONVER = .FALSE. (0257) H = B-A (0258) T(1,1) = (FCT(A) + FCT(B)) * H / 2.D0 (0259) M = H * FCT(A+H/2.D0) (0260) J=2 (0261) 101 DO 102 K=2,20 (0262) J=2*J (0263) H = H/2.D0 (0264) T(1,2) = (T(1,1)+M)/2.D0 (0265) SF = 0.D0 (0266) 103 DO 104 L=1,J,2 (0267) 104 SF = SF + FCT(A + L*H/2.D0) (0268) M = H*SF (0269) K1=4.D0 (0270) 1 IF(K.LT.3)GOTO 2 (0271) L = K-1 (0272) 105 DO 106 I=2,L (0273) T(I,2) = (K1*T(I-1,2)-T(I-1,1))/(K1-1.D0) (0274) T(I-1,1) = T(I-1,2) (0275) 106 K1 = K1 * K1 (0276) 2 I=K (0277) T(I,1) = (K1*T(I-1,2)-T(I-1,1))/(K1-1.D0) (0278) C WRITE(1,1097) K,T(K,1) (0279) 1097 FORMAT(I4,D16.8) (0280) 203 IF(DABS(T(I,1)-TOLD).LT.GRZW) GOTO 204 (0281) TOLD=T(K,1) (0282) T(I-1,1) = T(I-1,2) (0283) 102 CONTINUE (0284) 205 GOTO 206 (0285) 204 KONVER = .TRUE. (0286) ROMINT = T(K,1) (0287) C WRITE(1,1098) K (0288) 1098 FORMAT('K=',I4) (0289) RETURN (0290) (0291) 206 CONTINUE (0292) ROMINT = 0.D0 (0293) WRITE(1,1099) (0294) 1099 FORMAT('*** NO CONVERGENCE IN ROMINT ***'/) (0295) RETURN (0296) END PROGRAM SIZE: PROCEDURE - 000436 LINKAGE - 000326 STACK - 000072 A D ARGUMENT 000045 0225S 0239S 0257 0258A 0259 0267 B D ARGUMENT 000050 0225S 0239S 0257 0258A DABS D EXTERNAL 000000 0280 FCT R ARGUMENT 000042 0225S 0254S 0258 0259 0267 GRZW D ARGUMENT 000053 0225S 0239S 0280 H D LINKAGE 000670 0239S 0257M 0258 0259 0263M 0267 0268 I I LINKAGE 000404 0272M 0273 0274 0276M 0277 0280 0282 J I LINKAGE 000401 0238S 0260M 0262M 0266 K I ARGUMENT 000056 0225S 0238S 0261M 0270 0271 0276 0281 0286 K1 D LINKAGE 000704 0239S 0269M 0273 0275M 0277 KONVER L ARGUMENT 000061 0225S 0252S 0256M 0285M L I LINKAGE 000402 0238S 0266M 0267 0271M 0272 M D LINKAGE 000674 0239S 0259M 0264 0268M ROMINT D LINKAGE 000716 0225S 0286M 0292M SF D LINKAGE 000700 0239S 0265M 0267M 0268 T D LINKAGE 000430 0239S 0250S 0258M 0264M 0273M 0274M 0277M 0280 0281 0282M 0286 TOLD D LINKAGE 000710 0239S 0280 0281M $1 000156 0270D $101 000060 0261D $102 000322 0261 0283D $103 000110 0266D $104 000112 0266 0267D $105 000166 0272D $106 000216 0272 0275D $1097 000257 0279D $1098 000343 0288D $1099 000370 0293 0294D $2 000232 0270 0276D $203 000265 0280D $204 000332 0280 0285D $205 000331 0284D $206 000354 0284 0291D 0000 ERRORS [FTN-REV18.2] (0297) (0298) REAL*8 FUNCTION DFALSI(FCT,F0,X) (0299) C (0300) C **************************************************************** (0301) C * * (0302) C * WRITTEN BY D.SCHNEIDER * (0303) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0304) C * CH-3084 WABERN, 1981 * (0305) C * * (0306) C **************************************************************** (0307) C (0308) (0309) C SOLVE THE EQUATION FCT(X) = F0 , FOR FCT MONOTON INSCREASING (0310) C USING THE REGULA FALSI (0311) (0312) REAL*8 (0313) D DCRIT, (0314) D DF, (0315) F F(3), (0316) F F0, (0317) F FCT, (0318) X X(3) (0319) (0320) EXTERNAL FCT (0321) (0322) DATA DCRIT/5.D-4/ (0323) (0324) 1 DO 2 I=1,2 (0325) F(I) = FCT(X(I)) (0326) 2 CONTINUE (0327) (0328) C CHECK MONOTONITY (0329) IF ((F(2)-F(1)).EQ.0.D0) GOTO 901 (0330) (0331) C ITERATION (0332) 3 DO 4 I=1,100 (0333) X(3) = X(1) + (X(2)-X(1)) / (F(2)-F(1)) * (F0-F(1)) (0334) F(3) = FCT(X(3)) (0335) DF = F(3) - F0 (0336) (0337) C TEST FOR ITERATION TERMINATION (0338) IF(DABS(DF).LT.DCRIT) GOTO 12 (0339) (0340) C NEW APPROX. VALUES X(1), X(2) (0341) 13 IF(DF.LT.0.D0) GOTO 14 (0342) X(1) = X(3) (0343) F(1) = F(3) (0344) 15 GOTO 16 (0345) 14 CONTINUE (0346) X(2) = X(3) (0347) F(2) = F(3) (0348) 16 CONTINUE (0349) C WRITE(1,1999) X,F (0350) 1999 FORMAT(6D12.3) (0351) 4 CONTINUE (0352) (0353) 12 CONTINUE (0354) DFALSI = X(3) (0355) RETURN (0356) (0357) 901 CONTINUE (0358) WRITE(1,1901) (0359) 1901 FORMAT(' *** FCT NOT MONOTONE INCREASING IN DFALSI **'/) (0360) RETURN (0361) END PROGRAM SIZE: PROCEDURE - 000300 LINKAGE - 000062 STACK - 000070 DABS D EXTERNAL 000000 0338 DCRIT D LINKAGE 000424 0312S 0322I 0338 DF D LINKAGE 000444 0312S 0335M 0338A 0341 DFALSI D LINKAGE 000452 0298S 0354M F D LINKAGE 000430 0312S 0325M 0329 0333 0334M 0335 0343M 0347M F0 D ARGUMENT 000045 0298S 0312S 0333 0335 FCT D ARGUMENT 000042 0298S 0312S 0320S 0325 0334 I I LINKAGE 000400 0324M 0325 0332M X D ARGUMENT 000050 0298S 0312S 0325A 0333M 0334A 0342M 0346M 0354 $1 000001 0324D $12 000212 0338 0353D $13 000130 0341D $14 000153 0341 0345D $15 000152 0344D $16 000177 0344 0348D $1901 000235 0358 0359D $1999 000177 0350D $2 000023 0324 0326D $3 000037 0332D $4 000204 0332 0351D $901 000225 0329 0357D 0000 ERRORS [FTN-REV18.2] (0362) (0363) (0364) REAL*8 FUNCTION DNORM(X) (0365) C (0366) C **************************************************************** (0367) C * * (0368) C * WRITTEN BY D.SCHNEIDER * (0369) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0370) C * CH-3084 WABERN, 1981 * (0371) C * * (0372) C **************************************************************** (0373) C (0374) REAL*8 X (0375) C (0376) C WAHRSCHEINLICHKEITSDICHTE DER NORMALVERTEILUNG (0377) C (0378) REAL *8 ZPI (0379) DATA ZPI /2.506628275D0/ (0380) DNORM = DEXP(-X*X/2.D0)/ZPI (0381) RETURN (0382) END PROGRAM SIZE: PROCEDURE - 000026 LINKAGE - 000032 STACK - 000052 DEXP D EXTERNAL 000000 0380 DEXP$X D EXTERNAL 000000 0382 DNORM D LINKAGE 000426 0364S 0380M X D ARGUMENT 000042 0364S 0374S 0380 ZPI D LINKAGE 000420 0378S 0379I 0380 0000 ERRORS [FTN-REV18.2] (0383) (0384) REAL*8 FUNCTION DCNORM(X) (0385) C (0386) C **************************************************************** (0387) C * * (0388) C * WRITTEN BY D.SCHNEIDER * (0389) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0390) C * CH-3084 WABERN, 1981 * (0391) C * * (0392) C **************************************************************** (0393) C (0394) C NORMAL CUMULATIVE PROBABILITY DISTRIBUTION FUNCTION (0395) (0396) REAL*8 (0397) D DNORM, (0398) D DSIMPS, (0399) X X (0400) (0401) LOGICAL KONVER (0402) (0403) EXTERNAL DNORM (0404) (0405) DCNORM = -ROMINT(DNORM,X,0.D0,1.D-5,K,KONVER) (0406) RETURN (0407) END PROGRAM SIZE: PROCEDURE - 000034 LINKAGE - 000032 STACK - 000046 DCNORM D LINKAGE 000426 0384S 0405M DNORM D EXTERNAL 000000 0396S 0403S 0405A K I LINKAGE 000400 0405A KONVER L LINKAGE 000401 0401S 0405A ROMINT R EXTERNAL 000000 0405 X D ARGUMENT 000042 0384S 0396S 0405A 0000 ERRORS [FTN-REV18.2] (0408) (0409) REAL*8 FUNCTION DNEWTO(F,F1,F0,X) (0410) C (0411) C **************************************************************** (0412) C * * (0413) C * WRITTEN BY D.SCHNEIDER * (0414) C * BUNDESAMT FUER LANDESTOPOGRAPHIE * (0415) C * CH-3084 WABERN, 1981 * (0416) C * * (0417) C **************************************************************** (0418) C (0419) C NEWTONS ITERATIVE METHOD TO SOLVE THE EQUATION: F(X) = F0 (0420) (0421) REAL*8 (0422) D DF, (0423) F F, (0424) F F0, (0425) F F1, (0426) F F1X, (0427) X X (0428) (0429) EXTERNAL F,F1 (0430) (0431) 1 DO 2 I=1,20 (0432) F1X = F1(X) (0433) IF(DABS(F1X).LT.1.D-24) F1X=1.D-24 (0434) DF = F(X) - F0 (0435) 3 IF(DABS(DF).LT.1.D-4) GOTO 4 (0436) X = X - DF/F1X (0437) 2 CONTINUE (0438) 4 CONTINUE (0439) DNEWTO = X (0440) RETURN (0441) END PROGRAM SIZE: PROCEDURE - 000102 LINKAGE - 000040 STACK - 000056 DABS D EXTERNAL 000000 0433 0435 DF D LINKAGE 000430 0421S 0434M 0435A 0436 DNEWTO D LINKAGE 000434 0409S 0439M F D ARGUMENT 000042 0409S 0421S 0429S 0434 F0 D ARGUMENT 000050 0409S 0421S 0434 F1 D ARGUMENT 000045 0409S 0421S 0429S 0432 F1X D LINKAGE 000422 0421S 0432M 0433M 0436 I I LINKAGE 000400 0431M X D ARGUMENT 000053 0409S 0421S 0432A 0434A 0436M 0439 $1 000001 0431D $2 000057 0431 0437D $3 000035 0435D $4 000065 0435 0438D 0000 ERRORS [FTN-REV18.2] (0442) $$$ 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 LOGICAL OPEN,LSTOP C DIMENSIONES FOR 1000 OBS. 30 FIXED, 60 UNKNOWN STAT. 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),NHFIX(30),CNHF(30) MAIN0150 C CHANGE NOR BELOW MAIN0151 DIMENSION A(1000,6),ICA(1000,6),IOB(1000,4),DOB(1000,4),W(1000), @ CIO(1000,3),DOBR(1000,4),AS(1000,6),B(1000,6),VCLS(1000), @ DLDH(1000,2) C CHANGE NSR BELOW MAIN0154 DIMENSION AP(60,12),IC(60,3),CNAM(60),ICER(60),ZZ(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(1060) C THE FOLLOWING DIMENSIONS MUST NOT BE CHANGED MAIN0170 DIMENSION FAC(5),TL(10),CENT(4) MAIN0171 INTEGER*2 IFELDI(16),IFELDO(16),IFELDP(16) COMMON /BIG/ A,DOB,W,CIO,DOBR,AS,B,VCLS,DLDH COMMON /LT/RN,SPX,SBH,BH,PX COMMON /STATIS/ NDF1 $INSERT SYSCOM>A$KEYS LSTOP = .FALSE. LT INP = 5 IOUT = 6 IPUN = 7 802 OPEN=OPNP$A('INPUTFILE',INTS(9),A$READ+A$SAMF,IFELDI,INTS(32), 1INTS(INP-4)) IF(.NOT.OPEN)GOTO 802 803 OPEN=OPNP$A('OUTPUTFILE',INTS(10),A$WRIT+A$SAMF,IFELDO,INTS(32), 1INTS(IOUT-4)) IF(.NOT.OPEN)GOTO 803 804 OPEN=OPNP$A('PUNCHFILE',INTS(9),A$WRIT+A$SAMF,IFELDP,INTS(32), 1INTS(IPUN-4)) IF(.NOT.OPEN)GOTO 804 CALL GEND$A(INTS(IPUN-4)) LT C PRINTER CONTROLE RECORD WRITE(6,9902) 9902 FORMAT('F+'/) C INITIALIZE VARIABLES FOR DIMENSIONED SIZES MAIN0172 NR=121 MAIN0173 NFR=30 MAIN0174 NOR=1000 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,NUTM, MAIN0189 @ N3DIM,NHF,CNHF) C IF(N3DIM.EQ.2) CALL CHREAD( ) 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,CNHF,NHF,NHFIX) 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,LSTOP,NS,N3DIM,NH,NUH,NHF) LTIN0198 WRITE(7,7121) NO,NP,N,ND,IDF,NZERO,NH,NUH LT 7121 FORMAT(8I4) LT C GENERATE DESIGN MATRIX AND NORMAL EQUATION COLUMN CODES MAIN0199 CALL COL(NFIX,NF,IC,NS,NSR,NFR,NB,IBH,NBR,N3DIM,NHFIX,NHF) MAIN0200 CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,1,NZERO,N,N3DIM) 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,NUTM) 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,NUTM,N3DIM) MAIN0213 C IF(NCODE.EQ.1)GOTO50 MAIN0214 C 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,NCODE,NRED1,N3DIM,DLDH) MAIN0218 51 IF(NRED2.EQ.0.OR.NCODE.EQ.1) GOTO 50 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,NUTM,N3DIM) 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,LSTOP) LTIN0237 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,N3DIM,DLDH) 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 101 IF(NPRN.NE.3.OR.ITER.NE.0)GOTO 102 201 DO 202 I=1,N LT JSTART = I LT JEND = N LT WRITE(7,7101)(RN(I,J),J=JSTART,JEND) LT 7101 FORMAT(4D20.13) LT 202 CONTINUE LT 102 CONTINUE LT 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 103 IF(NPRU.NE.3.OR.ITER.NE.0) GOTO 104 208 DO 209 I = 1,N WRITE(7,7001) RU(I) 7001 FORMAT(D20.13) LT 209 CONTINUE 104 CONTINUE NV=NO+NP2 MAIN0266 C STORE DESIGN MATRIX ON PUNCH-FILE LT 105 IF(NPRA.NE.3.OR.NPRW.NE.3.OR.ITER.NE.0) GOTO 106 CALL ASTOR(IOB,NO,A,W,WX,ICA,NP,ICP,SPX,NOR,NR,NP2R, 1 DOBR,NV) LT 106 CONTINUE IF(LSTOP) GOTO 99 LT 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,NUH) MAIN0265 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,N3DIM,IC,ZZ) 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,NUTM) 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,NUTM) 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,NH,NUH) 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,N3DIM,NHFIX,NHF) 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,NUTM,N3DIM) 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 CONTINUE MAIN0313 C CLOSE FILES LT CALL CLOS$A(INTS(INP-4)) LT CALL TRNC$A(INTS(IOUT-4)) LT CALL CLOS$A(INTS(IOUT-4)) LT CALL TRNC$A(INTS(IPUN-4)) LT CALL CLOS$A(INTS(IPUN-4)) LT CALL EXIT LT END LT SUBROUTINE ASTOR(IOB,NO,A,W,WX,ICA,NP,ICP,SPX,NOR,NR,NP2R, LT 1 DOBR,NV) LT LT C STORE DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS ON PUNCH FILE LT LT IMPLICIT REAL*8 (A-H,O-Z) DIMENSION IOB(NOR,4),A(NOR,6),W(NOR),WX(NP2R),ICA(NOR,6),ICP(NR), LT 1 SPX(NP2R,NP2R),DOBR(NOR,4) LT LT NP2 = 2*NP WRITE(7,7201)NO,NP,NV,NP2 LT 7201 FORMAT(4I4) LT LT 1 DO 2 I=1,NO LT WRITE(7,7202)(IOB(I,J),J=1,4) WRITE(7,7203)(A(I,J),J=1,6) WRITE(7,7203)W(I) WRITE(7,7202)(ICA(I,J),J=1,6) WRITE(7,7203)(DOBR(I,J),J=1,4) 7202 FORMAT(I5) 7203 FORMAT(D20.13) 2 CONTINUE LT 7 IF(NP.LE.0) GOTO 8 5 DO 6 I=1,NP2 WRITE(7,7202) ICP(I) LT 6 CONTINUE 3 DO 4 I=1,NP LT WRITE(7,7203)WX(I),(SPX(I,J),J=1,NP) LT 4 CONTINUE LT 8 CONTINUE RETURN LT END LT $$$ 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 DATE(18) ABSTR021 DIMENSION CNAM(NSR),AP(NSR,12),RN(NR,NR),IOB(NOR,4),IC(NSR,3), ABSTR022 @IVEC(50) ABSTR023 DATA UF,UM/' FEET ',' METRES '/ ABSTR024 U=UM ABSTR025 IF(NUNIT.EQ.1)U=UF ABSTR026 C 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 WRITE(6 ,101)CNAM(I),DATE AB 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 WRITE(6 ,102)AP(I,1),U,IDP,IMP,SP AB WRITE(6 ,103)AP(I,2),U,IDL,IML,SL AB CX1=RN(IC(I,1),IC(I,1)) ABSTR038 CX2=RN(IC(I,1),IC(I,2)) ABSTR039 WRITE(6 ,104)AP(I,3),U,AP(I,4),U,CX1,CX2 AB CX1=CX2 ABSTR041 CX2=RN(IC(I,2),IC(I,2)) ABSTR042 WRITE(6 ,105)AP(I,5),AP(I,6),CX1,CX2 AB WRITE(6 ,106)IDC,IMC,SC,AP(I,11) AB WRITE(6 ,107) 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 WRITE(6 ,108)CNAM(I),CNAM(J),IDA,IMA,SA,SIJ,IDT,IMT,ST,S AB 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 WRITE(6 , 101)CNAM(IFR),CNAM(ITO1),CNAM(ITO2),IDEG,IMIN,SEC ,STD,IDGAN @,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 WRITE(6 , 102)CNAM(IFR),CNAM(ITO1),CNAM(ITO2), STD AN 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 WRITE(6 , 101)CNAM(IFR),CNAM(IFR),CNAM(ITO),IDEG,IMIN,SEC,DOBR(I AZ 1,1), @ 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 WRITE(6 , 102)CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(I,1) AZ 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,LSTOP,NS,N3DIM,NH,NUH,NHF) LTEK0002 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 LOGICAL LSTOP 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 WRITE(6 ,101)CPX(J) CH WRITE(6 , 102) GOTO21 CHEK0041 7 WRITE(6 ,103)CPX(I) CH WRITE(6 ,102) GOTO21 CHEK0044 8 WRITE(6 ,104)CNF(I) CH WRITE(6 ,102) 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 NUH = 0 NH = 0 IF(N3DIM.EQ.2) NH = NS IF(N3DIM.NE.0) NUH = NS - NHF IDF=NO+NP*2+NH-N-ND CHEK0 IF(IDF.GE.0)GOTO22 CHEK0053 WRITE(6 ,105)IDF CH WRITE(6 ,106)N1,NZERO,N2,ND,N3,N4,NP2,NN,NS1,NS2,NS3 CH 21 LSTOP = .TRUE. LTEK0056 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,LSTOP) LTKDEM02 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 LOGICAL LSTOP LT 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))GOTO 1 CHKDEM43 3 CONTINUE CHKDEM44 2 IF(NP.EQ.0)GOTO4 CHKDEM45 DO 5 J=1,NP CHKDEM46 IF(I.EQ.IPX(J))GOTO 1 CHKDEM47 5 CONTINUE CHKDEM48 4 IF(NB.EQ.0)GOTO6 CHKDEM49 DO 7 J=1,NB CHKDEM50 IF(I.EQ.IBH(J))GOTO 1 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)WRITE(6 ,101) IF(NSUM.EQ.2)WRITE(6 ,102)CNAM(I) CH IF(NSUM.LT.2)WRITE(6 ,103)CNAM(I) CH 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)WRITE(6 ,101) WRITE(6 ,104)CNAM(I) CH 1 CONTINUE CHKDEM88 GOTO90 CHKDEM89 20 NSTOP=1 CHKDEM90 NPC=NPC+1 CHKDEM91 IF(NPC.EQ.1)WRITE(6 ,101) WRITE(6 ,105) GOTO10 CHKDEM94 21 NSTOP=1 CHKDEM95 NPC=NPC+1 CHKDEM96 IF(NPC.EQ.1)WRITE(6 ,101) WRITE(6 ,106) GOTO10 CHKDEM99 22 NSTOP=1 CHKDE100 NPC=NPC+1 CHKDE101 IF(NPC.EQ.1)WRITE(6 ,101) WRITE(6 ,107) GOTO10 CHKDE104 23 NSTOP=1 CHKDE105 NPC=NPC+1 CHKDE106 IF(NPC.EQ.1)WRITE(6 ,101) WRITE(6 ,108) GOTO10 CHKDE109 30 NPC=NPC+1 CHKDE110 IF(NPC.EQ.1)WRITE(6 ,101) WRITE(6 ,109) GOTO10 CHKDE113 90 IF(NSTOP.EQ.1)LSTOP=.TRUE. LTKDE114 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 WRITE(6 ,101) 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)WRITE(6 ,101)WDISC,U,WANGC CH ICNT=1 CHKMIS33 WRITE(6 ,102)CNAM(IA),CNAM(IA),CNAM(IF),DOB(I,3),W(I),U CH GOTO5 CHKMIS35 2 IF(DABS(W(I)).LE.WANGC)GOTO5 CHKMIS36 IF(ICNT.EQ.0)WRITE(6 ,101)WDISC,U,WANGC CH ICNT=1 CHKMIS38 IDEG=DOB(I,2) CHKMIS39 IMIN=DOB(I,3) CHKMIS40 WRITE(6 ,103)CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,DOB(I,4),W(I) CH GOTO5 CHKMIS42 3 IF(DABS(W(I)).LE.WANGC)GOTO5 CHKMIS43 IF(ICNT.EQ.0)WRITE(6 ,101)WDISC,U,WANGC CH ICNT=1 CHKMIS45 IDEG=DOB(I,2) CHKMIS46 IMIN=DOB(I,3) CHKMIS47 WRITE(6 ,104)CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN,DOB(I,4),W(I) CH GOTO5 CHKMIS49 4 IF(DABS(W(I)).LE.WANGC)GOTO5 CHKMIS50 IF(ICNT.EQ.0)WRITE(6 ,101)WDISC,U,WANGC CH ICNT=1 CHKMIS52 IDEG=DOB(I,2) CHKMIS53 IMIN=DOB(I,3) CHKMIS54 WRITE(6 ,105)CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,DOB(I,4),W(I) CH 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,N3DIM) 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,3) 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 C 3-DIM. ADJ. 31 IF(N3DIM.EQ.0) GOTO 32 ICA(I,5) = IC(IOB(I,2),3) ICA(I,6) = IC(IOB(I,3),3) 32 CONTINUE GOTO20 CODE0029 C ANGLES 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,N3DIM,NHFIX,NHF) 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,3),IBH(NBR),NHFIX(NFR) 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 C 3-DIM. ADJ. 98 IF(N3DIM.EQ.0) GOTO 99 11 DO 12 I=1,NS 13 DO 14 J=1,NHF 8 IF(I.EQ.NHFIX(J)) GOTO 9 14 CONTINUE IC(I,3) = K K = K+1 GOTO 12 9 CONTINUE IC(I,3) = 0 12 CONTINUE 99 CONTINUE 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,N3DIM,NHFIX,NHF) 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,3), 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),NHFIX(NFR) 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,N3DIM,NHFIX,NHF) DELQX051 CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,2,NZERO,NZ,N3DIM) 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,N3DIM,NHFIX,NHF) DELQX142 CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,2,NZERO,N,N3DIM) 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 WRITE(6 , 101)K,CNAM(IFR),CNAM(IFR),CNAM(ITO),IDEG,IMIN,SEC, DI @ 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 WRITE(6 , 102)K,CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(J,1) DI 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,N3DIM,DLDH) 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 @ DLDH(NOR,2) 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 C 3-DIM. ADJ. 11 IF(N3DIM.EQ.0) GOTO 12 A(I,5) = DLDH(I,1) A(I,6) = DLDH(I,2) 12 CONTINUE 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 WRITE(6 , 101)CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(I,3),STD,DOB(I, DI 13), @W(I) DIST0042 101 FORMAT(' ',7X,'DISTANCE',6X,A8,2X,A8,2X,A8,F13.4,F10.4,F13.4, DIST0043 @F13.4,/) DIST0044 GOTO3 DIST0045 2 WRITE(6 , 102)CNAM(IFR),CNAM(IFR),CNAM(ITO),STD DI 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.D0 LT IF(QYY-QXX.EQ.0.D0.AND.QXY.EQ.0.D0)GOTO 1 LT 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,NUTM,N3DIM) 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,3),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 COMMON /STATIS/ NDF1 DATA UF,UM,VKN,VUN,WAS,WASN/'(FEET) ','(METRES)','KNOWN) ',ERREL030 @ 'UNKNOWN)',' WAS ','WAS NOT '/ ERREL031 ALPH=1.D0-ALPHA/100.D0 ERREL027 PI=3.141592653589793D0 ERREL028 RO=3600.D0/PI*180.D0 ERREL029 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)WRITE(6 ,101)UNIT ER IF(NSTAN.NE.2.AND.NELPS.LT.2)WRITE(6 ,102)ALPHA,UNIT ER NSTA=NS-NB ERREL041 IF(NSTAN.EQ.2)GOTO3 ERREL042 IF(NVARF.EQ.0)GOTO1 ERREL043 RALP=SNGL(ALPHA/100.D0) ERREL044 C CALL MDCHI(RALP,2.0,RX,IER) ERREL045 C FAK=DSQRT(DBLE(RX)) ERREL046 DRALP = ALPHA/100.D0 NDF1 = 2 DRX = DICCHI(DRALP) FAK = DSQRT(DRX) 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)WRITE(6 ,103)VKNO,FAK ER 4 IF(NELPS.LT.2.AND.IDF.GT.0.AND.NCODE.EQ.2)WRITE(6 ,104)WMUL,VARF ER IF(NELPS.GT.1)GOTO20 ERREL055 WRITE(6 ,105) 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 WRITE(6 ,106)CNAM(I),AX,BX,IDP,IMP,IP,AR ER 301 IF(N3DIM.EQ.0) GOTO 302 SH = DSQRT(RN(IC(I,3),IC(I,3))) * FAK WRITE(6,112) SH 112 FORMAT(1H+,T100,F12.4) 302 CONTINUE SUMA=SUMA+AR ERREL068 5 CONTINUE ERREL069 WRITE(6 ,107)SUMA ER 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)WRITE(6 ,108)UNIT ER IF(NSTAN.NE.2)WRITE(6 ,109)ALPHA,UNIT ER IF(NSTAN.NE.2)WRITE(6 ,103)VKNO,FAK ER IF(IDF.GT.0.AND.NCODE.EQ.2)WRITE(6 ,104)WMUL,VARF ER WRITE(6 ,110) 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 WRITE(6,111)CNAM(I),CNAM(J),AX,BX,IDP,IMP,IP,SIJ,IPR,STDIS,STDAZ ERREL 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,NUTM,CNHF) 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)WRITE(6 ,201)UNIT ER IF(NSTAN.NE.2)WRITE(6 ,202)ALPHA,UNIT ER IF(NVARF.EQ.0)GOTO31 ERREL129 DNSTA = NSTA RALP=SNGL(1.D0-ALPH/DNSTA) ERREL13 C CALL MDCHI(RALP,2.0,RX,IER) ERREL131 C FAK=DSQRT(DBLE(RX)) ERREL132 DRALP = 1.D0 - ALPH/DNSTA NDF1 = 2 DRX = DICCHI(DRALP) FAK = DSQRT(DRX) GOTO32 ERREL133 31 ALPS=ALPH/NSTA ERREL13 CALL F2DI(ALPS,IDF,XX) ERREL135 FAK=DSQRT(2.D0*XX) ERREL136 32 IF(NCODE.EQ.2)WRITE(6 ,104)WMUL,VARF ER WRITE(6 ,209)VKNO,FAK ER WRITE(6 ,105) 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 WRITE(6 ,106)CNAM(IN),AX,BX,IDP,IMP,IP,AR ER 303 IF(N3DIM.EQ.0) GOTO 304 SH = DSQRT(RN(IC(IN,3),IC(IN,3))) * FAK WRITE(6,112) SH 304 CONTINUE SUMA=SUMA+AR ERREL152 35 CONTINUE ERREL153 WRITE(6 ,107)SUMA ER IF(NSTA.EQ.1)GOTO29 ERREL155 IF(NSTAN.EQ.2)WRITE(6 ,207)UNIT ER IF(NSTAN.NE.2)WRITE(6 ,208)ALPHA,UNIT ER IF(NCODE.EQ.2)WRITE(6 ,104)WMUL,VARF ER WRITE(6 ,209)VKNO,FAK ER WRITE(6 ,205) 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 WRITE(6 ,206)CNAM(IN),CNAM(JN),AX,BX,IDP,IMP,IP,SIJ,IPR ER 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 @ 4X,'STD.DEV.HEIGHTS'/) 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,NUTM) 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 /* CLARKE 1866 FILAP040 BB=6356583.8D0/FAK /* CLARKE 1866 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 IF(NPROJ.EQ.6) GOTO 4 GOTO( 5,10,15,20,25),NPROJ FILAP047 4 CONTINUE ICM = - ( 180 - ( 3 + 6 * (NUTM-1))) CALL DMSRAD(ICM,0,0.D0,RL) XO = 5.D5 RKO = 0.9996D0 GOTO 30 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 CONTINUE YY0 = 4.D6 YY = AP(I,2) IF(NPROJ.EQ.6) YY = AP(I,2) + YY0 CALL TMXYPL(AP(I,1),YY,AA,BB,RKO,XO,RL,PHI,ELAM) 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,3), 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 WRITE(6 ,101) 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=IDF F2DI0022 X=(R/(ALPHA**(2.D0/R))-R)/2.D0 F2DI0023 RETURN F2DI0024 END F2DI0025 $$$ 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 WRITE(6 ,101)(PLOTV(L),L=1,110) LP IF(MAX.EQ.25)WRITE(6 ,113)B LP IF(MAX.EQ.17)WRITE(6 ,113)C LP IF(MAX.EQ.9)WRITE(6 ,113)D LP MAX=MAX-1 LPRNT027 IF(MAX.GT.32.OR.KK.EQ.23)GOTO2 LPRNT028 WRITE(6 ,114)SV(KK) LP 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 WRITE(6 ,101)CERR(J) MA 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 WRITE(6 ,102)CERR(L) MA 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,CNHF,NHF,NHFIX) 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),CNHF(NFR),NHFIX(NFR) NAMC0027 DATA BLNK/' '/ 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 WRITE(6 , 101) 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 WRITE(6 , 201) 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 WRITE(6 , 102) STOP NAMC0069 C ASSIGN SEQUENCE NUMBER TO H-FIXED STATIONS 10 CONTINUE IF(NHF.EQ.0) GOTO 30 25 DO 26 I=1,NHF J = 1 27 IF(CNHF(I).NE.CNAM(J)) GOTO 28 NHFIX(I) = J GOTO 26 28 IF(J.EQ.NS) GOTO 29 J = J + 1 GOTO 27 26 CONTINUE GOTO 30 29 CONTINUE WRITE(6,106) WRITE(1,106) STOP C CHECK THAT OBSERVATION STATION NAMES EXIST IN STATION NAMES READ NAMC0070 30 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 WRITE(6 , 103)I,CIO(I,J) NA 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 WRITE(6 , 104)I,J,CNAM(I) NA STOP NAMC0093 16 CONTINUE NAMC0094 DO 17 I=1,NS NAMC0095 IF(CNAM(I).NE.BLNK)GOTO17 NAMC0096 WRITE(6 , 105)I NA 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 106 FORMAT(' ','*** INPUT ERROR #047 *** STATION NAME REFERENCED AS BNAMC0103 @EING HELD H-FIX WAS NOT FOUND AMONG THOSE INPUT WITH APPROXIMATE',NAMC0104 @/,' ',21X,'COORDINATES') NAMC0105 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,N3DIM,DLDH) 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,3),IB(NR),NORVEC24 @ OX(NPR,2),W(NOR),WX(NP2R),CNAM(NSR),DOBR(NOR,4),FAC(5), NORVEC25 @ DLDH(NOR,2) IF(ITER.GT.0)GOTO8 NORVEC26 IF(NFAC.EQ.1)WRITE(6 ,169)FAC(1),FAC(5),(FAC(I),I=2,4) NO IF(NFAC.EQ.0)WRITE(6 ,107) 107 FORMAT('1') NORVEC29 IF(NCODE.EQ.2)WRITE(6 ,104) IF(NCODE.EQ.1)WRITE(6 ,105) IF(NCODE.EQ.1)WRITE(6 ,106) IF(NCODE.EQ.2)WRITE(6 ,102) 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)) @WRITE(6 , 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,N3DIM,DLDH) 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 C ADD TO NORMAL FOR HEIGHT OBSERVATIONS 7 CONTINUE IF(N3DIM.NE.2) GOTO 99 C CALL HOBS( ) 99 CONTINUE RETURN 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 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,BLNK 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/'.','-','I'/ 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 WRITE(6 ,103) DO 29 JJ=1,50 PLOT0048 DO 28 N=1,WINT PLOT0049 IF(RVEC(N).GE.MAX)GOTO19 PLOT0050 28 CONTINUE PLOT0051 WRITE(6 ,104) 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 WRITE(6 ,101)(PLOTH(L),L=1,110) PL 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 WRITE(6 ,102)(PLOTV(L),L=1,110) PL IF(MAX.EQ.32)WRITE(6 ,113)A PL 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 WRITE(6 ,111) WRITE(6 ,112) IF(WINT.EQ.20)WRITE(6 ,107)(HVEC(L),L=1,20) PL IF(WINT.EQ.10)WRITE(6 ,106)(HVEC(L),L=1,10) PL IF(WINT.EQ.4)WRITE(6 ,108)(HVEC(L),L=1,4) PL IF(WINT.EQ.2)WRITE(6 ,109)(HVEC(L),L=1,2) PL IF(WINT.EQ.9)WRITE(6 ,116)(HVEC(L),L=1,9) PL IF(WINT.EQ.5)WRITE(6 ,114)(HVEC(L),L=1,5) PL IF(WINT.EQ.3)WRITE(6 ,115)(HVEC(L),L=1,3) PL 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('I----'),'I') 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 INTEGER C1 DIMENSION ARRAY(RDIM,CDIM),CNAM(NSR),IOB(NOR,4),IC(NSR,3),ICA(NOR PRAR0037 @,6),RU(NR),W(NOR),WX(NP2R),CPX(NPR),LCC(6) PRAR0038 DATA FB,BL/'FIXED',' '/ PRAR0039 IF(ICODE.EQ.1)WRITE(6 ,10)ITER PR IF(ICODE.EQ.21)WRITE(6 ,11)ITER PR IF(ICODE.EQ.22)WRITE(6 ,14)ITER PR IF(ICODE.EQ.23)WRITE(6 ,15) IF(ICODE.EQ.3)WRITE(6 ,12)ITER PR IF(ICODE.EQ.4)WRITE(6 ,13)ITER PR IF(ICODE.EQ.24)WRITE(6 ,64) IF(ICODE.EQ.25)WRITE(6 ,65) IF(ICODE.EQ.26)WRITE(6 ,118) IF(ICODE.EQ.27)WRITE(6 ,119) 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)WRITE(6 ,25)CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2 PR IF(ID.EQ.1.AND.ICA(ROW,5).NE.0)WRITE(6 ,26) IF(IABS(ID).EQ.2)WRITE(6 ,27)N,CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW , PR @,3)), @ FB2 PRAR0072 IF(ID.EQ.2)N=N+1 PRAR0073 IF(ID.EQ.-2)N=1 PRAR0074 IF(ID.EQ.3)WRITE(6 ,28)CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2 PR @,CNAM @ (IOB(ROW,4)),FB3 PRAR0076 IF(ID.EQ.4)WRITE(6 ,29)CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2 PR 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.1.AND.ICA(I,6).NE.0)ID1=6 IF(IOB(I,1).EQ.3)ID1=6 PRAR0081 WRITE(6 , 30)(ARRAY(ROW,L),L=1,ID1) PR WRITE(6 , 31) 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 WRITE(6 ,23)CNAM(IVC(N+1)),CNAM(IVC(N+2)),CNAM(IVC(N+3)) PR WRITE(6 ,95) DO 210 L=1,6 PRAR0100 210 LCC(L)=NCC+L PRAR0101 WRITE(6 ,110)(LCC(L),L=1,6) PR 42 DO 5 I=J,K PRAR0103 WRITE(6 ,3)I,(ARRAY(I,C1+L),L=1,6) PR 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 WRITE(6 ,2)CNAM(IVC(N+1)),CNAM(IVC(N+2)) PR IF(LL.EQ.1)WRITE(6 ,101) WRITE(6 ,96) DO 211 L=1,4 PRAR0121 211 LCC(L)=NCC+L PRAR0122 WRITE(6 ,111)(LCC(L),L=1,4) PR 46 DO 17 I=J,K PRAR0124 WRITE(6 ,18)I,(ARRAY(I,C1+L),L=1,4) PR IF(LL.EQ.1)WRITE(6 ,98)ARRAY(I,C1+5) PR IF(I.EQ.R)RETURN PRAR0127 17 CONTINUE PRAR0128 J=J+50 PRAR0129 GOTO7 PRAR0130 43 WRITE(6 ,44)CNAM(IVC(N+1)),CNAM(IVC(N+2)) PR IF(LL.EQ.1)WRITE(6 ,101) WRITE(6 ,96) DO 212 L=1,4 PRAR0134 212 LCC(L)=NCC+L PRAR0135 WRITE(6 ,111)(LCC(L),L=1,4) PR FLAG=1 PRAR0137 GOTO46 PRAR0138 9 IF(FLAG.EQ.0)GOTO47 PRAR0139 WRITE(6 ,19)CNAM(IVC(N+1)) PR IF(LL.EQ.1)WRITE(6 ,102) WRITE(6 ,97) DO 213 L=1,2 PRAR0143 213 LCC(L)=NCC+L PRAR0144 WRITE(6 ,112)(LCC(L),L=1,2) PR 49 DO 200 I=J,K PRAR0146 WRITE(6 ,37)I,ARRAY(I,C1+1),ARRAY(I,C1+2) PR IF(LL.EQ.1)WRITE(6 ,99)ARRAY(I,C1+3) PR IF(I.EQ.R)RETURN PRAR0149 200 CONTINUE PRAR0150 J=J+50 PRAR0151 GOTO7 PRAR0152 47 WRITE(6 ,48)CNAM(IVC(N+1)) PR WRITE(6 ,97) DO 214 L=1,2 PRAR0155 214 LCC(L)=NCC+6 PRAR0156 WRITE(6 ,112)(LCC(L),L=1,2) PR FLAG=1 PRAR0158 GOTO49 PRAR0159 104 WRITE(6 ,103) DO 105 I=J,K PRAR0161 WRITE(6 , 106)I,ARRAY(I,C1+1) PR IF(I.EQ.R)RETURN PRAR0163 105 CONTINUE PRAR0164 J=J+50 PRAR0165 GOTO7 PRAR0166 38 WRITE(6 ,39)CNAM(IVC(N+1)),CNAM(IVC(N+2)),CNAM(IVC(N+3)) PR WRITE(6 ,95) DO 215 L=1,6 PRAR0169 215 LCC(L)=L+NCC PRAR0170 WRITE(6 ,110)(LCC(L),L=1,6) PR FLAG=1 PRAR0172 GOTO42 PRAR0173 C PRAR0174 70 IF(ICODE.NE.3)GOTO80 PRAR0175 WRITE(6 ,50) I1=1 PRAR0177 DO 51 I=1,NC PRAR0178 WRITE(6 ,52)I,CNAM(IVC(I)),RU(I1),RU(I1+1) PR I1=I1+2 PRAR0180 51 CONTINUE PRAR0181 RETURN PRAR0182 80 IF(ICODE.NE.4)GOTO90 PRAR0183 I=1 PRAR0184 WRITE(6 ,53) DO 54 J=1,NO PRAR0186 IF(IOB(J,1).EQ.1)WRITE(6 ,55)CNAM(IOB(J,2)),CNAM(IOB(J,2)), PR @CNAM(IOB(J,3)),W(J) PRAR0188 IF(IOB(J,1).EQ.3)WRITE(6 ,56)CNAM(IOB(J,2)),CNAM(IOB(J,3)), PR @ CNAM(IOB(J,4)),W(J) PRAR0190 IF(IOB(J,1).EQ.4)WRITE(6 ,57)CNAM(IOB(J,2)),CNAM(IOB(J,2)), PR @ CNAM(IOB(J,3)),W(J) PRAR0192 IF(IOB(J,1).EQ.2.OR.IOB(J,1).EQ.-2)GOTO58 PRAR0193 GOTO54 PRAR0194 58 WRITE(6 ,59)I,CNAM(IOB(J,2)),CNAM(IOB(J,2)),CNAM(IOB(J,3)),W(J) PR 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 WRITE(6 ,62)CPX(J),WX(I) PR WRITE(6 ,63)WX(I+1) PR 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 WRITE(6 , 71)CPX(N+1),CPX(N+2),CPX(N+3) PR WRITE(6 ,95) DO 216 L=1,6 PRAR0221 216 LCC(L)=L+NCC PRAR0222 WRITE(6 ,110)(LCC(L),L=1,6) PR 72 DO 75 I=J,K PRAR0224 WRITE(6 , 73)I,(ARRAY(I,C1+L),L=1,6) PR 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 WRITE(6 ,78)CPX(N+1),CPX(N+2) PR WRITE(6 ,96) DO 217 L=1,6 PRAR0240 217 LCC(L)=L+NCC PRAR0241 WRITE(6 ,111)(LCC(L),L=1,6) PR 79 DO 81 I=J,K PRAR0243 WRITE(6 ,82)I,(ARRAY(I,C1+L),L=1,4) PR IF(I.EQ.R)RETURN PRAR0245 81 CONTINUE PRAR0246 J=J+50 PRAR0247 GOTO66 PRAR0248 83 WRITE(6 ,84)CPX(N+1),CPX(N+2) PR WRITE(6 ,96) DO 218 L=1,4 PRAR0251 218 LCC(L)=L+NCC PRAR0252 WRITE(6 ,111)(LCC(L),L=1,4) PR FLAG=1 PRAR0254 GOTO79 PRAR0255 77 IF(FLAG.EQ.0)GOTO85 PRAR0256 WRITE(6 ,86)CPX(N+1) PR WRITE(6 ,97) DO219 L=1,2 PRAR0259 219 LCC(L)=L+NCC PRAR0260 WRITE(6 ,112)(LCC(L),L=1,2) PR 87 DO 88 I=J,K PRAR0262 WRITE(6 ,89)I,ARRAY(I,C1+1),ARRAY(I,C1+2) PR IF(I.EQ.R)RETURN PRAR0264 88 CONTINUE PRAR0265 J=J+50 PRAR0266 GOTO66 PRAR0267 85 WRITE(6 ,91)CPX(N+1) PR WRITE(6 ,97) DO 220 L=1,2 PRAR0270 220 LCC(L)=L+NCC PRAR0271 WRITE(6 ,112)(LCC(L),L=1,2) PR FLAG=1 PRAR0273 GOTO87 PRAR0274 69 WRITE(6 ,92)CPX(N+1),CPX(N+2),CPX(N+3) PR WRITE(6 ,95) DO 221 L=1,6 PRAR0277 221 LCC(L)=L+NCC PRAR0278 WRITE(6 ,110)(LCC(L),L=1,6) PR 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 WRITE(6 , 109) WRITE(6 , 104) 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 WRITE(6 , 105)I,CNAM(IFR),CNAM(IFR),CNAM(IT1), DOB(I,3) , STD, PR @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 WRITE(6 ,106)I,J,CNAM(IFR),CNAM(IFR),CNAM(IT1),IDEG,IMIN,SEC, PR @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 WRITE(6 ,107)I,CNAM(IFR),CNAM(IT1),CNAM(IT2),IDEG,IMIN,SEC, PR @ 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 WRITE(6 ,108)I,CNAM(IFR),CNAM(IFR),CNAM(IT1),IDEG,IMIN,SEC, PR @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.4,F10.4,F10.4, PRES0090 @F9.4,F15.4,/) 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,NUTM,N3DIM) 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 C LOGICAL DATE(18),TIME(6) PRIT0023 INTEGER*2 IDAT(3),ITIME(2),IUSER(3) DIMENSION TL(10),CNF(NFR),CPX(NPR),CNAM(NSR),AP(NSR,12), PRIT0024 @ NFIX(NFR),CBH(NBR),IBH(NBR),CENT(4),IPX(NPR) PRIT0025 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(I12.EQ.2)GOTO50 PRIT0026 WRITE(6 ,110) WRITE(6 ,101) WRITE(6 , 102) WRITE(6 , 103)(TL(I),I=1,10) PR WRITE(6 , 102) WRITE(6 , 101) C CALL GDATE(DATE,TIME) PRIT0033 C WRITE(6,701)(DATE(I),I=1,18),(TIME(I),I=1,6) PRIT0034 C PRINT DATE, TIME AND USERNAME CALL TIMREG(IDAT,ITIME,IUSER) WRITE(6,6001)IDAT,ITIME,IUSER 6001 FORMAT(' DATUM: ',A2,'. ',A2,'. ',A2,/' ZEIT : ',I2,'.',I2,/ 1' USER: ',3A2/) WRITE(6 , 153) WRITE(6 , 154) IF(NCODE.EQ.1)WRITE(6 , 155)PRE1,PRE2 PR IF(NCODE.EQ.2)WRITE(6 , 155)ADJ1,ADJ2 PR WRITE(6 ,503) WRITE(6 ,157) MAX=MAX0(NF,NP,NB) PRIT0050 IF(NF.EQ.0)WRITE(6 ,501)RNON,BLNK,BLNK PR IF(NP.EQ.0)WRITE(6 ,501)BLNK,RNON,BLNK PR IF(NB.EQ.0)WRITE(6 ,501)BLNK,BLNK,RNON PR IF(MAX.EQ.0)GOTO208 PRIT0054 DO 502 I=1,MAX PRIT0055 IF(I.LE.NF)WRITE(6 ,501)CNF(I),BLNK,BLNK PR IF(I.LE.NP)WRITE(6 ,501)BLNK,CPX(I),BLNK PR IF(I.LE.NB)WRITE(6 ,501)BLNK,BLNK,CBH(I) PR WRITE(6 ,503) 502 CONTINUE PRIT0060 208 WRITE(6 ,503) IF(NCOV.EQ.1.AND.NP.NE.0)WRITE(6 ,173) IF(NCOV.EQ.0.AND.NP.NE.0)WRITE(6 ,172) IF(NCOVB.EQ.1.AND.NB.NE.0)WRITE(6 ,187) IF(NCOVB.EQ.0.AND.NB.NE.0)WRITE(6 ,188) IF(NPROJ.EQ.5.AND.NCODE.EQ.2)WRITE(6 ,159)Z5 PR IF(NPROJ.EQ.4.AND.NCODE.EQ.2)WRITE(6 ,159)Z4 PR IF(NPROJ.EQ.3.AND.NCODE.EQ.2)WRITE(6 ,156) IF(NPROJ.EQ.2.AND.NCODE.EQ.2)WRITE(6 ,161) IF(NPROJ.EQ.1.AND.NCODE.EQ.2)WRITE(6 ,162) IF(NUNIT.EQ.0)WRITE(6 ,163)UM PR IF(NUNIT.EQ.1)WRITE(6 ,163)UF PR IF(NZERO.EQ.1)WRITE(6 ,170)ANSY PR IF(NTEST.EQ.0.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)XTAU1,XTA PR @U2 IF(NTEST.EQ.1.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)TAU1,TAU2 PR IF(NTEST.EQ.2.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)XNOR1,XNO PR @R2 IF(NTEST.EQ.3.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)RNOR1,RNO PR @R2 IF(NTEST.EQ.4.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)ST1,ST2 PR IF(NTEST.EQ.5.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)XST1,XST2 PR IF(NMULT.EQ.0.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,175)ANSN PR IF(NMULT.EQ.1.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,175)ANSY PR IF(NCODE.EQ.2)WRITE(6 ,176)NITER PR IF(NCODE.EQ.2)WRITE(6 ,179)CONVG PR IF(NRED1.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,180)ANSN PR IF(NRED1.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,180)ANSY PR IF(NRED2.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,181)ANSN PR IF(NRED2.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,181)ANSY PR IF(NRED3.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,184)ANSN PR IF(NRED3.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3.AND.(NRED1.EQ.1.OR. PRIT0089 @NRED2.EQ.1))WRITE(6 ,184)ANSY PR IF(NRED3.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3.AND.NRED1.EQ.0.AND. PRIT0091 @NRED2.EQ.0)WRITE(6 ,184)ANSN PR IF(NCENT.EQ.1)WRITE(6 ,183)(CENT(I),I=1,4) PR IF(N3DIM.NE.0) WRITE(6,191) ANSY IF(N3DIM.EQ.0) WRITE(6,191) ANSN IF(N3DIM.EQ.2) WRITE(6,192) ANSY 191 FORMAT(' ',15X,'3-DIM. ADJUSTMENT',58('.'),1X,A4,/) 192 FORMAT(' ',15X,'COV.-MATRIX OF HEIGHTS READ',48('.'),1X,A4/) IF(NPROJ.NE.3.AND.NCODE.EQ.2)CALL PROINF(NPROJ,AA,BB,RP,RL,XO, PRIT0094 @YO,X1,Y1,Z1,RKO,NUNIT,NUTM) PRIT0095 IF(I12.EQ.1)WRITE(6 ,107) 50 IF(I12.EQ.2)WRITE(6 ,207) WRITE(6 ,111) IF(NPROJ.NE.3)GOTO300 PRIT0099 WRITE(6 ,108) 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 WRITE(6 , 109)CNAM(I),(AP(I,J),J=1,2) PR 3 CONTINUE PRIT0115 IF(NF.EQ.0.AND.NB.EQ.0.AND.NP.EQ.0)GOTO1 PRIT0116 IF(NF.EQ.0)GOTO6 PRIT0117 WRITE(6 ,104) WRITE(6 ,108) DO 2 I=1,NF PRIT0120 WRITE(6 ,109)CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,2) 2 CONTINUE PRIT0122 6 IF(NP.EQ.0)GOTO603 PRIT0123 WRITE(6 ,604) WRITE(6 ,108) DO 605 I=1,NP PRIT0126 WRITE(6 ,109)CNAM(IPX(I)),(AP(IPX(I),J),J=1,2) PR 605 CONTINUE PRIT0128 603 IF(NB.EQ.0)GOTO1 PRIT0129 WRITE(6 ,404) WRITE(6 ,108) DO 405 I=1,NB PRIT0132 WRITE(6 ,109)CNAM(IBH(I)),(AP(IBH(I),J),J=1,2) PR 405 CONTINUE PRIT0134 GOTO1 PRIT0135 300 IF(I12.EQ.1)WRITE(6 ,201) IF(I12.EQ.2)WRITE(6 ,202) 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)WRITE(6 ,209)CNAM(I),(AP(I,J),J=1,6),IDP,IMP,SP,IDL, PR @IML, @ SL,AP(I,11),IDC,IMC,SC PRIT0155 IF(I12.EQ.2)WRITE(6 ,210)CNAM(I),(AP(I,J),J=1,2),IDP,IMP,SP,IDL, PR @IML, @ SL,AP(I,11),IDC,IMC,SC,AP(I,3) PRIT0157 303 CONTINUE PRIT0158 IF(NF.EQ.0.AND.NB.EQ.0.AND.NP.EQ.0)GOTO1 PRIT0159 IF(NF.EQ.0)GOTO10 PRIT0160 WRITE(6 ,104) IF(I12.EQ.1)WRITE(6 ,201) IF(I12.EQ.2)WRITE(6 ,202) 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)WRITE(6 , 209)CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,6),ID PR @P,IMP, @ SP,IDL,IML,SL,AP(NFIX(I),11),IDC,IMC,SC PRIT0169 IF(I12.EQ.2)WRITE(6 ,210)CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,2),IDP , PR @,IMP, @ SP,IDL,IML,SL,AP(NFIX(I),11),IDC,IMC,SC,AP(NFIX(I),3) PRIT0171 302 CONTINUE PRIT0172 10 IF(NP.EQ.0)GOTO608 PRIT0173 WRITE(6 ,604) IF(I12.EQ.1)WRITE(6 ,201) IF(I12.EQ.2)WRITE(6 ,202) 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)WRITE(6 ,209)CNAM(IPX(I)),(AP(IPX(I),J),J=1,6),IDP,I PR @MP, @ SP,IDL,IML,SL,AP(IPX(I),11),IDC,IMC,SC PRIT0182 IF(I12.EQ.2)WRITE(6 ,210)CNAM(IPX(I)),(AP(IPX(I),J),J=1,2),IDP, PR @ IMP,SP,IDL,IML,SL,AP(IPX(I),11),IDC,IMC,SC PRIT0184 609 CONTINUE PRIT0185 608 IF(NB.EQ.0)GOTO1 PRIT0186 WRITE(6 ,404) IF(I12.EQ.1)WRITE(6 ,201) IF(I12.EQ.2)WRITE(6 ,202) 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)WRITE(6 ,209)CNAM(IBH(I)),(AP(IBH(I),J),J=1,6),IDP,I PR @MP, @ SP,IDL,IML,SL,AP(IBH(I),11),IDC,IMC,SC PRIT0195 IF(I12.EQ.2)WRITE(6 ,210)CNAM(IBH(I)),(AP(IBH(I),J),J=1,2),IDP,I PR @MP, @ SP,IDL,IML,SL,AP(IBH(I),11),IDC,IMC,SC PRIT0197 11 CONTINUE PRIT0198 1 IF(I12.EQ.2.AND.NZERO.EQ.1)WRITE(6 ,211) ZER PR 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',6X,'HEIGHT'/) 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 @ 2X,F12.4/) 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,NUTM)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 WRITE(6 ,101) 101 FORMAT('1',42X,'SPECIFICATIONS OF THE MAP PROJECTION',/,' ',42X, PROINF24 @ 36('-'),///) PROINF25 WRITE(6 ,102) 102 FORMAT(' ',21X,'PROJECTION USED :') PROINF27 IF(NPROJ.EQ.6) GOTO 206 IF(NPROJ.EQ.7) GOTO 207 IF(NPROJ.GT.3)GOTO10 PROINF28 IF(NPROJ.EQ.1)WRITE(6 ,103) 103 FORMAT('+',40X,'NEW BRUNSWICK DOUBLE STEREOGRAPHIC',//) PROINF30 IF(NPROJ.EQ.2)WRITE(6 ,104) 104 FORMAT('+',40X,'PRINCE EDWARD ISLAND DOUBLE STEREOGRAPHIC',//) PROINF32 CALL RADMS(RP,IDP,IMP,SP) PROINF33 CALL RADMS(RL,IDL,IML,SL) PROINF34 WRITE(6 ,105)IDP,IMP,SP,IDL,IML,SL,XO,U,YO,U PR 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 WRITE(6 ,106)RKO PR 106 FORMAT(' ',39X,'SCALE AT THE ORIGIN :',F11.7,//) PROINF40 GOTO20 PROINF41 10 NZ=4 PROINF42 IF(NPROJ.EQ.5)NZ=5 PROINF43 WRITE(6 ,107)NZ PR 107 FORMAT('+',40X,'NOVA SCOTIA 3-DEGREE TRANSVERSE MERCATOR (ZONE', PROINF45 @ I2,')',//) PROINF46 CALL RADMS(RL,IDL,IML,SL) PROINF47 WRITE(6 ,108)IDL,IML,SL,XO,U PR 108 FORMAT(' ',32X,'CENTRAL MERIDIAN : LONGITUDE=',I6,I3,F9.5,/,' ', PROINF49 @ 51X,'EASTING (X)=',F12.3,A8,//) PROINF50 WRITE(6 ,109)RKO PR 109 FORMAT(' ',34X,'SCALE AT THE CENTRAL MERIDIAN :',F11.7,//) PROINF52 GOTO 20 206 CONTINUE WRITE(6,111) NUTM 111 FORMAT('+',40X,'UTM - PROJECTION (ZONE',I2,')',//) CALL RADMS(RL,IDL,IML,SL) WRITE(6,108) IDL,IML,SL,XO,U WRITE(6,109) RKO GOTO 20 207 CONTINUE WRITE(6,112) 112 FORMAT('+',40X,'SWISS CYLINDER PROJECTION'//'NOT IMPLEMENTED '//) 20 CONTINUE WRITE(6 ,110)AA,U,BB,U,X1,U,Y1,U,Z1,U PR 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 @NUTM,N3DIM,NHF,CNHF) 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),CNHF(NFR) READ0027 DIMENSION CENT(4) READ0028 DATA FIXD,PXD,BLAHD,CRITR ,BLNK ,FACTD,STATD,OBSERD,SIMUD/ READ0109 @'FIXED ','WEIGHTED','BLAHA ','CRITERIA',' ', READ0110 @'FACTORS ','STATIONS','OBSERVAT','SIMULTAN'/ READ0111 DATA FIXH/'FIXH '/ IF(NRCOD.EQ.2)GOTO240 READ0029 READ(5,109,END=1215)(TL(I),I=1,10) READ0030 WRITE(7,7021)TL LT 7021 FORMAT(10A8) LT READ(5,102,ERR=200)(NC(I),I=1,37) READ0031 GOTO201 READ0032 200 WRITE(6 ,202) 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(I.EQ.5.AND.NC(I).LE.7) GOTO 1 IF(I.EQ.35.AND.NC(I).LE.60) GOTO 1 IF(NC(I).LE.5.AND.NC(I).GE.0)GOTO1 READ0039 WRITE(6 ,103)I RE STOP READ0041 1 CONTINUE READ0042 NCODE=NC(1) READ0043 NF=NC(2) READ0044 WRITE(7,7000) NF LT 7000 FORMAT(I3) LT 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 NUTM=NC(35) N3DIM=NC(36) 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.LT.1.AND.NPRA.GT.3)NPRA=0 READ0100 IF(NPRN.LT.1.AND.NPRN.GT.3)NPRN=0 READ0101 IF(NPRU.LT.1.AND.NPRU.GT.3)NPRU=0 READ0102 IF(NPRCX.NE.1)NPRCX=0 READ0103 IF(NPRW.LT.1.AND.NPRW.GT.3)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(N3DIM.NE.1.AND.N3DIM.NE.2) N3DIM=0 IF(NTEST.LT.0.OR.NTEST.GT.5)NTEST=0 READ0108 IF(NF.EQ.0)GOTO2 READ0112 READ(5,101,END=217)RCODE READ0113 IF(RCODE.EQ.FIXD)GOTO203 READ0114 WRITE(6 ,204)RCODE RE 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 401 IF(N3DIM.NE.1) GOTO 402 READ(5,101,END=217)RCODE 403 IF(RCODE.NE.FIXH) GOTO 404 READ(5,110,END=217) NHF 110 FORMAT(I4) READ(5,101,END=217) (CNHF(I),I=1,NHF) GOTO 402 404 CONTINUE WRITE(6,251)RCODE 251 FORMAT(' ','*** INPUT ERROR: EXPECTING - FIXH - BUT FOUND', @ ,A8,'***'/) STOP 402 CONTINUE IF(NP.EQ.0)GOTO4 READ0122 READ(5,101,END=217)RCODE READ0123 IF(RCODE.EQ.PXD)GOTO205 READ0124 WRITE(6 ,206)RCODE RE 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 WRITE(6 ,209) 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 WRITE(6 ,211)RCODE RE 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 WRITE(6 ,1214) 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 WRITE(6 ,1217) STOP READ0160 213 WRITE(6 ,220) 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 WRITE(6 ,226) STOP READ0188 223 WRITE(6 ,227) 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 WRITE(6 , 108) 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 WRITE(6 ,231)RCODE RE STOP READ0213 232 WRITE(6 ,233) 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 WRITE(7,7001)CNAM(J),XX,YY LT 7001 FORMAT(A8,2F15.4) LT 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 WRITE(7,7002) LT 7002 FORMAT('$$$$') LT 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 WRITE(6 ,235)RCODE RE STOP READ0249 236 WRITE(6 ,237) 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(N3DIM.EQ.2) N = N + NS IF(N3DIM.EQ.1) N = N + NS - NHF 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 WRITE(6 ,248) STOP READ0290 242 WRITE(6 ,249)RCODE RE STOP READ0292 1215 WRITE(6 ,301) STOP READ0294 217 WRITE(6 ,302) STOP READ0296 216 WRITE(6 ,303) STOP READ0298 219 WRITE(6 ,304) STOP READ0300 221 WRITE(6 ,305) 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,DLDH1,DLDH2, REDIS101 @ LRED) 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 LOGICAL LRED 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))WRITE(6 ,101)CNAM(I),CNAM(J) RE 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 1 IF(.NOT.LRED) GOTO 2 DIS2 = DIS*DIS - DH*DH RLO=DSQRT(DIS2/(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 3 GOTO 4 2 CONTINUE RLO = 2.D0 * R * DSIN(DIS/2.D0/R) C6 = DIS - RLO DIS2 = RLO*RLO * (1.D0+HI/R) * (1.D0+HJ/R) C5 = RLO - DSQRT(DIS2 + DH*DH) 4 CONTINUE C DERIVATIVES T1 = DH/DIS2 DLDH1 = DIS * (T1 - 1.D0/(2.D0 * (R + HI))) * 1.D3 DLDH2 = DIS * (-T1 - 1.D0/(2.D0 * (R + HJ))) * 1.D3 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 COMMON /STATIS/ NDF1 NUMREJ=0 RESREJ23 SAVAL=ALPH RESREJ24 IF(ALPH.LT.90.D0)ALPH=95.D0 RESREJ25 WRITE(6 ,101)ALPH RE IF(NTEST.EQ.0)WRITE(6 ,102) IF(NTEST.EQ.1)WRITE(6 ,103) IF(NTEST.EQ.2)WRITE(6 ,104) IF(NTEST.EQ.3)WRITE(6 ,105) IF(NTEST.EQ.4)WRITE(6 ,106) IF(NTEST.EQ.5)WRITE(6 ,107) 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 NDF1 = IDF DRALPH = DBLE(SRALPH) C IF(NTEST.EQ.4.OR.NTEST.EQ.5)CALL MDSTI(SRALPH,SDF,SCR,IER) RESREJ41 IF(NTEST.EQ.4.OR.NTEST.EQ.5) CR = DICSTU(DRALPH) C IF(NTEST.EQ.2.OR.NTEST.EQ.3)CALL MDNRIS(SRALPH,SCR,IER) RESREJ42 IF(NTEST.EQ.2.OR.NTEST.EQ.3) CR = DICNOR(DRALPH) C CR=DBLE(SCR) RESREJ43 1 WRITE(6 ,108)CR RE WRITE(6 ,109) WRITE(6 ,110) 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)WRITE(6 ,111)I,CNAM(IA),CNAM(IA),CNAM(IF) RE IF(IG.EQ.3)WRITE(6 ,112)I,CNAM(IA),CNAM(IF),CNAM(IT) RE IF(IG.EQ.4)WRITE(6 ,113)I,CNAM(IA),CNAM(IA),CNAM(IF) RE WRITE(6 ,114)V(I),DOB(I,1),CRPT RE 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 WRITE(6 ,115)I,J,CNAM(IA),CNAM(IA),CNAM(IF),V(I),DOB(I,1),CRPT RE 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 WRITE(6 ,116)NUMREJ,IPC RE IF(NUMREJ.GT.0)WRITE(6 ,117) 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,3),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,3),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,3),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,3 SINO0028 IF(I.EQ.IC(J,K))GOTO4 SINO0029 3 CONTINUE SINO0030 WRITE(6 ,101)I,I SI WRITE(6 ,102) GOTO5 SINO0033 4 WRITE(6 ,101)I,I IF(K.EQ.1)WRITE(6 ,103)CNAM(J) SI IF(K.EQ.2)WRITE(6 ,104)CNAM(J) SI IF(K.EQ.3)WRITE(6,105) CNAM(J) 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 105 FORMAT('+',24X,'HEIGHT OF STATION',1X,A8,/) 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,NH,NUH) 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 COMMON /STATIS/ NDF1 WRITE(6 ,101) IF(NCODE.EQ.2)WRITE(6 ,102)ITER ST IF(NCODE.EQ.2)WRITE(6 ,103)NITER ST IF(NCODE.EQ.2.AND.ITER.EQ.NITER)WRITE(6 ,104) IF(NCODE.EQ.2.AND.ITER.NE.NITER)WRITE(6 ,112) NP2=NP*2 STATS027 NN=N-NZERO-NUH STATS028 NS1=N1+N2+N3+N4+NP2+NH STATS029 NS2=NZERO+ND+NN+NUH STATS030 WRITE(6 ,105)N1,NZERO,N2,ND,N3,N4,NP2,NN,NH,NUH,NS1,NS2 WRITE(6 ,106)IDF ST IF(IDF.EQ.0.OR.NCODE.EQ.1)GOTO9 STATS033 VARF=S0/IDF STATS034 WRITE(6 ,107)VARF ST WRITE(6 ,108) IF(NVARF.EQ.0)WRITE(6 ,114) IF(NVARF.EQ.1)WRITE(6 ,115) ALP2=(1.D0-ALPH/100.D0)/2.D0 STATS039 SALPH=SNGL(1.D0-ALP2) STATS040 SDF=FLOAT(IDF) STATS041 C CALL MDCHI(SALPH,SDF,X,IER) STATS042 NDF1 = IDF DSALPH = 1.D0 - ALP2 DX = DICCHI(DSALPH) X = SNGL(DX) RLOW=S0/DBLE(X) STATS043 SALPH=SNGL(ALP2) STATS044 C CALL MDCHI(SALPH,SDF,X,IER) STATS045 DSALPH = ALP2 DX = DICCHI(DSALPH) X = SNGL(DX) HIGH=S0/DBLE(X) STATS046 WRITE(6 ,109)RLOW,HIGH ST IF(RLOW.GT.1.D0.OR.HIGH.LT.1.D0)WRITE(6 ,110)ALPH ST IF(RLOW.LE.1.D0.AND.HIGH.GE.1.D0)WRITE(6 ,111)ALPH ST IF(IDF.GT.0)WRITE(6 ,113)NUMREJ ST 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, ATS052 1 NV) IF(N1.GT.0.AND.(N2+N3+N4+N1).GE.9)CALL GODFIT(V,NOR,VCLS,3, @ NO,IOB,NVARF,ALPH,NV) S 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,'I',' NUMBER OF UNKNOWNSTATS062 @S',/,' ',29X,27('-'),'I',24('-'),/,' ',56X,'I',/,' ',29X,'DISTANCESTATS063 @S',I13,5X,'I',' ZERO ERROR',I13,/,' ',29X,'DIRECTIONS',I12,5X,'I',STATS064 @' ORIENTATION',I12,/,' ',29X,'ANGLES',I16,5X,'I',/,' ',29X,'AZIMUTSTATS065 @HS',I14,5X,'I',/,' ',29X,'COORDINATES',I11,5X,'I',' COORDINATES', STATS066 @I12,/,' ',29X,'HEIGHTS',I15,5X,'I',' HEIGHTS',I16/ @ /,' ',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,NCODE,NRED1,N3DIM,DLDH) 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 @ DLDH(NOR,2) LOGICAL LRED LRED = .FALSE. IF(NCODE.NE.1.AND.NRED1.NE.0) LRED = .TRUE. IF(.NOT.LRED.AND.N3DIM.EQ.0) RETURN IF(NCORR.EQ.1)WRITE(6 , 101) IF(.NOT.LRED) WRITE(6,107) 107 FORMAT(1H /25X,'INPUT OF REDUCED DISTANCES: NO REDUCTION'//) IF(NCORR.EQ.1)WRITE(6 , 102) PI=3.141592653589793D0 TOELPS21 RO=3600.D0*180.D0/PI TOELPS22 I=1 TOELPS23 J=1 TOELPS24 1 ID=IOB(I,1) TOELPS25 IF(.NOT.LRED.AND.ID.NE.1) GOTO 49 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,DLDH1,DLDH2, TOELPS31 @ LRED) IF(NCORR.EQ.1)WRITE(6 , 103)CNAM(IA),CNAM(IA),CNAM(IF),DOBR(I,3) TO @,C5, @C6,DOB(I,3),DLDH1,DLDH2 TOELPS33 61 IF(N3DIM.EQ.0) GOTO 62 DLDH(I,1) = DLDH1*1.D-3 DLDH(I,2) = DLDH2*1.D-3 62 CONTINUE 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)WRITE(6 , 104)J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IM TO @IN, @ 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)WRITE(6 , 104)J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IM TO @IN, @ 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)WRITE(6 , 105)CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN TO @, @ 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)WRITE(6 , 106)CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN TO @, @ 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 49 CONTINUE 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',4X,'DERIVATIVE [MM/M]'/ TOELP104 @, ,' ',13X,'AT',7X,'FROM',5X,'TO',9X,'OBSERVETOELP104 @D',4X,'METRIC',1X,'NORMAL ODESIC',2X,'MUTH',1X,'TO CHORD TO EL',2XTOELP105 @,'OBSERVATION',1X,'DL/DHI',3X,'DL/DHJ'/) TOELP106 103 FORMAT(' ','DISTANCE',5X,A8,1X,A8,1X,A8,F11.3,30X,2F8.3,F12.3, TOELP107 @ 1X,2F8.1/) 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)WRITE(6 ,101) IF(NCORR.EQ.1)WRITE(6 ,102) 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)WRITE(6 ,103)CNAM(IA),CNAM(IA),CNAM(IF),SIJ,S,DOB( TO @I,3) 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)WRITE(6 ,104)J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMI TO @N,SEC, @ 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)WRITE(6 ,104)J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMI TO @N,SEC, @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)WRITE(6 ,105)CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN, TO @SEC, @ 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)WRITE(6 ,106)CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN, TO @SEC, @ 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,N3DIM,IC,ZZ) 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),IC(NSR,3), UPDAT019 @ ZZ(NSR) IF(ITER.EQ.0)WRITE(6 ,159) IF(ITER.GT.0.AND.NDELX.EQ.1)GOTO5 UPDAT021 WRITE(6 , 101)ITER UP WRITE(6 , 102) 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))GOTO 31 UPDAT0 1 CONTINUE UPDAT029 8 IF(NB.EQ.0)GOTO2 UPDAT030 DO 7 K=1,NB UPDAT031 IF(I.EQ.IBH(K))GOTO 31 UPDAT0 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 WRITE(6 , 103)CNAM(I),OLDX,OLDY,XX,YY,AP(I,1),AP(I,2) UP 6 J=J+2 UPDAT042 35 GOTO 36 31 CONTINUE WRITE(6,103) CNAM(I) 36 CONTINUE 33 IF(N3DIM.EQ.0) GOTO 34 11 IF(N3DIM.EQ.1.AND.IC(I,3).EQ.0) GOTO 12 AP(I,3) = AP(I,3) - ZZ(I) ZZ(I) = X(IC(I,3)) AP(I,3) = AP(I,3) + ZZ(I) 12 CONTINUE WRITE(6,105) ZZ(I),AP(I,3) 105 FORMAT(1H+,T98,F12.3,2X,F12.3) 34 CONTINUE 3 CONTINUE UPDAT043 IF(NZERO.EQ.0)GOTO4 UPDAT044 ZER=ZER-X(N) UPDAT045 IF(ITER.GT.0.AND.NDELX.EQ.1)GOTO4 UPDAT046 WRITE(6 , 104)ZER UP 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',10X,'DH',10X,'NEW H'/) 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,3),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,NUH) 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,3),ICA(NOR,6),RU(NR),W(NOR),CPX(NPR),WX(NP2R) XSIN0024 CRIT=1.D-16 LT 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 NNH = NN - NUH DO 9 I=1,NNH 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)WRITE(6 ,101)I,I XS 101 FORMAT(' ','*** INPUT ERROR #051 *** SINGULARITY ENCOUNTERED IN TXSIN0100 @HE INPUT MATRIX FOR WEIGHTED STATIONS; POSITION (',I4,' ,',I4, XSIN0101 @' )') XSIN0102 IF(INCQ.EQ.2)WRITE(6 ,102)I,I XS 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 $$$ REAL*8 FUNCTION DCHISQ(X) C DENSITY FUNCTION OF THE CHI-SQUARE PROBABILITY DISTRIBUTION REAL*8 C C, D DGAMMA, X X /* ARGUMENT OF FUNCTION INTEGER*4 N NDF1, /* DEGREES OF FREEDOM N NDF2 /* DEGREES OF FREEDOM COMMON /STATIS/ NDF1 1 IF(X.LE.0.D0) GOTO 2 C = 2.D0**(NDF1/2.D0)* DGAMMA(NDF1) IF(X.GT.3.D4) X = 3.D4 DCHISQ = X**(NDF1/2.D0 - 1.D0) * DEXP(-X/2.D0) / C RETURN 2 CONTINUE DCHISQ = 0.D0 RETURN END REAL*8 FUNCTION DGAMMA(N) C GAMMA FUNCTION FOR BETA = 2 C GAMMA = C(ALFA) = C(N/BETA) = C(N/2) INTEGER*4 N,N2 REAL*8 PI 900 IF(N.LE.0) GOTO 901 PI = 4.D0*DATAN(1.D0) DGAMMA = 1.D0 IF(MOD(N,2).EQ.1) DGAMMA = DSQRT(PI) 11 IF(N.LE.2) GOTO 12 N2 = (N+1)/2 - 1 1 DO 2 I=1,N2 DGAMMA = DGAMMA * (N/2.D0 - I) 2 CONTINUE 12 CONTINUE RETURN C ERROR MESSAGE 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' ***ILLEGAL ARGUMENT N<=0 IN FUNCTION DGAMMA***'/) DGAMMA = 0.D0 RETURN END REAL*8 FUNCTION DNORM(X) REAL*8 X C C WAHRSCHEINLICHKEITSDICHTE DER NORMALVERTEILUNG C REAL *8 ZPI DATA ZPI /2.506628275D0/ DNORM = DEXP(-X*X/2.D0)/ZPI RETURN END REAL*8 FUNCTION DNEWTO(F,F1,F0,X) C NEWTONS ITERATIVE METHOD TO SOLVE THE EQUATION: F(X) = F0 REAL*8 D DF, F F, F F0, F F1, F F1X, X X EXTERNAL F,F1 1 DO 2 I=1,20 F1X = F1(X) IF(DABS(F1X).LT.1.D-24) F1X=1.D-24 DF = F(X) - F0 3 IF(DABS(DF).LT.1.D-4) GOTO 4 X = X - DF/F1X 2 CONTINUE 4 CONTINUE DNEWTO = X RETURN END REAL*8 FUNCTION DCNORM(X) C NORMAL CUMULATIVE PROBABILITY DISTRIBUTION FUNCTION INTEGER*4 K REAL*8 D DNORM, D DSIMPS, X X LOGICAL KONVER EXTERNAL DNORM DCNORM = -ROMINT(DNORM,X,0.D0,1.D-5,K,KONVER) RETURN END REAL*8 FUNCTION DSTUD(X) C DENSITY FUNCTION OF THE T (STUDENT) DISTRIBUTION INTEGER*4 N NDF1, /* DEGREES OF FREEDOM N NDF2 /* DEGREES OF FREEDOM REAL*8 C C, D DGAMMA, /* GAMMA FUNCTION C(N/2) P PI, X X COMMON /STATIS/ NDF1 PI = 4.D0 * DATAN(1.D0) C = DSQRT(NDF1*PI) * DGAMMA(NDF1) 1 * (1.D0 + X*X/NDF1)**((NDF1+1)/2.D0) DSTUD = DGAMMA(NDF1+1) / C RETURN END REAL*8 FUNCTION DCSTUD(X) C CUMULATIVE T (STUDENT) PROBABILITY DISTRIBUTION FUNCTION INTEGER*4 K REAL*8 D DSIMPS, D DSTUD, X X LOGICAL KONVER EXTERNAL DSTUD DCSTUD = - ROMINT(DSTUD,X,0.D0,1.D-5,K,KONVER) RETURN END REAL*8 FUNCTION DICCHI(F) C INVERSE CHI-SQUARED CUMULATIVE PDF (FOR X < 10000.) INTEGER*4 N NDF1, /* DEGREES OF FREEDOM N NDF2 /* DEGREES OF FREEDOM REAL*8 D DF, D DFALSI, D DCCHIS, D DX, F F, X X(3) COMMON /STATIS/ NDF1 EXTERNAL DCCHIS X(1) = 0.D0 IF(F.GE.0.75D0) X(1) = NDF1 DX = 1.D-2 IF(NDF1.GT.50) DX = 0.2D0 IF(NDF1.GT.100) DX = 0.5D0 IF(NDF1.GT.500) DX = 0.7D0 C CHECK INTERVAL OF ARGUMENT IF(F.GE.1.D0) GOTO 901 C APPROX. VALUES X(1),X(2) 1 DO 2 I=1,20 X(2) = X(1) + DX DF = DCCHIS(X(2)) - F 11 IF(DF.GT.0.D0) GOTO 12 X(1) = X(2) DX = 2.D0*DX 2 CONTINUE GOTO 902 12 CONTINUE C REGULA FALSI DICCHI = DFALSI(DCCHIS,F,X) RETURN 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' *** F>= 1. ***'/) RETURN 902 CONTINUE WRITE(1,1902) X(2) 1902 FORMAT(' *** X> ',F8.2,'***'/) RETURN END REAL*8 FUNCTION DFALSI(FCT,F0,X) C SOLVE THE EQUATION FCT(X) = F0 , FOR FCT MONOTON INSCREASING C USING THE REGULA FALSI REAL*8 D DCRIT, D DF, F F(3), F F0, F FCT, X X(3) EXTERNAL FCT DATA DCRIT/5.D-4/ 1 DO 2 I=1,2 F(I) = FCT(X(I)) 2 CONTINUE C CHECK MONOTONITY IF ((F(2)-F(1)).EQ.0.D0) GOTO 901 C ITERATION 3 DO 4 I=1,100 X(3) = X(1) + (X(2)-X(1)) / (F(2)-F(1)) * (F0-F(1)) F(3) = FCT(X(3)) DF = F(3) - F0 C TEST FOR ITERATION TERMINATION IF(DABS(DF).LT.DCRIT) GOTO 12 C NEW APPROX. VALUES X(1), X(2) 13 IF(DF.LT.0.D0) GOTO 14 X(1) = X(3) F(1) = F(3) 15 GOTO 16 14 CONTINUE X(2) = X(3) F(2) = F(3) 16 CONTINUE C WRITE(1,1999) X,F 1999 FORMAT(6D12.3) 4 CONTINUE 12 CONTINUE DFALSI = X(3) RETURN 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' *** FCT NOT MONOTONE INCREASING IN DFALSI **'/) RETURN END REAL*8 FUNCTION ROMINT(FCT,A,B,GRZW,K,KONVER) C ROMBERG INTEGRATION INTEGER*4 J,L,K REAL*8 H H, T T, T TOLD, A A, B B, S SF, M M, K K1, G GRZW DIMENSION T(20,2) LOGICAL KONVER EXTERNAL FCT KONVER = .FALSE. H = B-A T(1,1) = (FCT(A) + FCT(B)) * H / 2.D0 M = H * FCT(A+H/2.D0) J=2 101 DO 102 K=2,20 J=2*J H = H/2.D0 T(1,2) = (T(1,1)+M)/2.D0 SF = 0.D0 103 DO 104 L=1,J,2 104 SF = SF + FCT(A + L*H/2.D0) M = H*SF K1=4.D0 1 IF(K.LT.3)GOTO 2 L = K-1 105 DO 106 I=2,L T(I,2) = (K1*T(I-1,2)-T(I-1,1))/(K1-1.D0) T(I-1,1) = T(I-1,2) 106 K1 = K1 * K1 2 I=K T(I,1) = (K1*T(I-1,2)-T(I-1,1))/(K1-1.D0) C WRITE(1,1097) K,T(K,1) 1097 FORMAT(I4,D16.8) 203 IF(DABS(T(I,1)-TOLD).LT.GRZW) GOTO 204 TOLD=T(K,1) T(I-1,1) = T(I-1,2) 102 CONTINUE 205 GOTO 206 204 KONVER = .TRUE. ROMINT = T(K,1) C WRITE(1,1098) K 1098 FORMAT('K=',I4) RETURN 206 CONTINUE ROMINT = 0.D0 WRITE(1,1099) 1099 FORMAT('*** NO CONVERGENCE IN ROMINT ***'/) RETURN END REAL*8 FUNCTION DCCHIS(X) C CUMULATIVE CHI-SQUARED PROBABILITY DISTRIBUTION FUNCTION INTEGER*4 N NDF1, /* DEGREES OF FREEDOM N NDF2 /* DEGREES OF FREEDOM REAL*8 D DCHISQ, F F01, F F9(15), G GRZW, /* CRIT. VALUE FOR ITERATION TERMINATION R RNDF, R RNDF2, R ROMINT, X X,X1 LOGICAL KONVER,GTNDF,GTNDF2 COMMON /STATIS/ NDF1 EXTERNAL DCHISQ DATA F F01/0.982069D-3/, F F9/2.70554D0,4.60517D0,6.25139D0,7.77944D0,9.23635D0,10.6446D0, F 12.0170D0,13.3616D0,14.6837D0,15.9871D0,17.2750D0,18.5494D0, F 19.8119D0,21.0642D0,22.3072D0/ GRZW = 1.D-5 IF(NDF1.LE.15) GRZW = 1.D-4 RNDF = NDF1 RNDF2 = 2*NDF1 GTNDF = .FALSE. GTNDF2 = .FALSE. DCCHIS = 0.D0 X1 = X IF(X.LT.0.D0) GOTO 902 8 IF(X.EQ.0.D0) GOTO 9 IF(X.GT.RNDF) GTNDF = .TRUE. IF(X.GT.RNDF2) GTNDF2 = .TRUE. IF(NDF1.EQ.1) GOTO 1 IF(NDF1.GE.2) GOTO 2 GOTO 901 C 1 DEGREE OF FREEDOM 1 CONTINUE 101 IF(.NOT.GTNDF) GOTO 102 DCCHIS = -ROMINT(DCHISQ,X,F9(1),GRZW,K,KONVER) + 0.9D0 RETURN 102 CONTINUE DCCHIS = DCCHIS - ROMINT(DCHISQ,X1,F01,GRZW,K,KONVER) + 0.025D0 RETURN C NDF>=2 2 CONTINUE 103 IF(NDF1.GT.15.OR..NOT.GTNDF) GOTO 104 DCCHIS = - ROMINT(DCHISQ,X,F9(NDF1),GRZW,K,KONVER) + 0.9D0 RETURN 104 CONTINUE IF(GTNDF2) DCCHIS = - ROMINT(DCHISQ,X,RNDF2,GRZW,K,KONVER) IF(GTNDF2) X1=RNDF2 DCCHIS = DCCHIS - ROMINT(DCHISQ,X1,0.D0,GRZW,K,KONVER) RETURN 9 CONTINUE DCCHIS = 0.D0 RETURN 901 CONTINUE WRITE(1,1901) 1901 FORMAT(' *** NDF<1 IN DCCHIS ***'/) RETURN 902 CONTINUE WRITE(1,1902) 1902 FORMAT(' *** X<0. IN DCCHIS ***'/) RETURN END REAL*8 FUNCTION DICNOR(F) C INVERSE CUMULATIVE NORMAL PDF REAL*8 D DCNORM, D DNORM, D DNEWTO, F F, X X EXTERNAL DCNORM,DNORM X = 2.D0*F DICNOR = DNEWTO(DCNORM,DNORM,F,X) RETURN END REAL*8 FUNCTION DICSTU(F) C INVERSE CUMULATIVE T (STUDENT) PDF REAL*8 D DNEWTO, D DCSTUD, D DSTUD, F F, X X EXTERNAL DCSTUD,DSTUD X = 2.D0*F DICSTU = DNEWTO(DCSTUD,DSTUD,F,X) RETURN END SUBROUTINE TIMREG(IDAT,ITIME,IUSER) C% ZEIT IN [HR.MIN] , DATUM IN [DY.MT.YR] , INITIALEN DES BENUETZERS C% REGISTRIEREN INTEGER*2 ITIMDA(15),IDAT(3),ITIME(2),IUSER(3) CALL TIMDAT(ITIMDA,INTS(15)) IDAT(1) = ITIMDA(2) IDAT(2) = ITIMDA(1) IDAT(3) = ITIMDA(3) ITIME(1) = ITIMDA(4)/60 ITIME(2) = ITIMDA(4)-ITIME(1)*60 IUSER(1) = ITIMDA(13) IUSER(2) = ITIMDA(14) IUSER(3) = ITIMDA(15) RETURN END $$$ 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 COMMON /STATIS/ NDF1 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 WRITE(6 ,101) IF(JCODE.EQ.1)WRITE(6 ,102) IF(JCODE.EQ.2)WRITE(6 ,103) IF(JCODE.EQ.3)WRITE(6 ,104) WRITE(6 ,105)NUMI GO WRITE(6 ,106)NDF GO WRITE(6 ,107) WRITE(6 ,108) 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=NDIF2/NEXP GODFI140 CHISQ=CHISQ+CONT GODFI141 WRITE(6 ,109)STRT,FIN,NOBS,NEXP,NDIF,NDIF2,CONT GO STRT=FIN GODFI143 37 CONTINUE GODFI144 WRITE(6 ,110)CHISQ GO P=SNGL(ALPH/100.D0) GODFI146 DF=FLOAT(NDF) GODFI147 X=SNGL(0.D0) GODFI148 C CALL MDCHI(P,DF,X,IER) GODFI149 NDF1 = NDF DP = ALPH/100.D0 DX = DICCHI(DP) X = SNGL(DX) WRITE(6 ,111)ALPH,X GO IPASS=0 GODFI151 IF(SNGL(CHISQ).LE.X)IPASS=1 GODFI152 IF(IPASS.EQ.1)WRITE(6 ,112)CHISQ,X GO IF(IPASS.EQ.0)WRITE(6 ,113)CHISQ,X GO WRITE(6 ,114) IF(NUMI.LT.9)WRITE(6 ,119)NUMI GO CALL PLOT(NI,NHVEC) IF(JCODE.EQ.1)WRITE(6 ,115) IF(JCODE.EQ.2)WRITE(6 ,116) IF(JCODE.EQ.3)WRITE(6 ,117) IF(NUMI.LT.9)WRITE(6 ,121) 200 IF(NUMI.GE.9)GOTO210 GODFI162 CALL PLOT(20,HVEC) IF(JCODE.EQ.1)WRITE(6 ,115) IF(JCODE.EQ.2)WRITE(6 ,116) IF(JCODE.EQ.3)WRITE(6 ,117) IF(NDF.LE.0)WRITE(6 ,118)NDF 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 WRITE(6 , 110)I IN 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 WRITE(6 , 112)I IN 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 WRITE(6 , 113)I IN 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 WRITE(6 , 114)I IN 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 $$$ C***********************************************************************MAIN00 (0001) C*********************************************************************** (0002) C* (0003) C* MAIN CONTROLS ALL COMPUTATIONS. MATRIX AND VECTOR DIMENSIONS,WHICH L (0004) C* THE MAXIMUM NETWORK SIZE, ARE SET UP AS DESCRIBED BELOW. MOST VARIA (0005) C* ARE COMMON TO MAIN AND THE VARIOUS SUBROUTINES AND FOR THIS REASON T (0006) C* ARE ONLY DESCRIBED HERE AS FOLLOWS: (0007) C* (0008) C* A -FIRST ORDER DESIGN MATRIX (0009) C* B -IMAGE OF FIRST ORDER DESIGN MATRIX WITH CERTAIN MULTIPLIC (0010) C* TIONS (SEE DELQX) USED IN COMPUTING THE CORRECTION TO THE (0011) C* VARIANCE MATRIX OF PARAMETERS FOR BLAHA STATIONS (0012) C* D -VECTOR USED IN FORWARD SOLUTION OF X-VECTOR (SEE XSIN) (0013) C* N -NUMBER OF UNKNOWNS (SIZE OF NORMAL EQUATIONS) (0014) C* V -VECTOR OF RESIDUALS (AND STANDARDIZED RESIDUALS) (0015) C* W -MISCLOSURE VECTOR FOR DISTANCE, DIRECTION, ANGLE AND AZIM (0016) C* OBSERVATIONS (0017) C* X -SOLUTION VECTOR (0018) C* AA -SEMI-MAJOR AXIS OF REFERENCE ELLIPSOID (0019) C* AP -MATRIX OF APPROXIMATE COORDINATES, HEIGHTS, DEFLECTION CO (0020) C* PONENTS, LATITUDE, LONGITUDE, RADII OF CURVATURE OF REFERE (0021) C* ELLIPSOID, POINT SCALE FACTOR AND MERIDIAN CONVERGENCE. (0022) C* AS -SIMILAR TO B ABOVE (SEE DELQX) (0023) C* BB -SEMI-MINOR AXIS OF REFERENCE ELLIPSOID (0024) C* BH -VECTOR OF ELEMENTS FOR INFORMATION MATRIX FOR BLAHA STATI (0025) C* IB -VARIABLE BANDING CONTROL VECTOR (0026) C* IC -MATRIX OF DESIGN MATRIX COLUMN NUMBERS FOR STATION COORDI (0027) C* ID -RETURN CODE FROM INERR FOR ILLEGAL DATA ENTRY (0028) C* NB -NUMBER OF BLAHA STATIONS (0029) C* ND -NUMBER OF INDEPENDENT DIRECTION BUNDLES (0030) C* NF -NUMBER OF FIXED STATIONS (0031) C* NN -NUMBER OF UNKNOWN COORDINATES (0032) C* NO -TOTAL NUMBER OF DISTANCE, DIRECTION, ANGLE AND AZIMUTH OB (0033) C* VATIONS (0034) C* NP -NUMBER OF WEIGHTED STATIONS (0035) C* NR -DIMENSIONED SIZE OF NORMAL EQUATIONS (0036) C* NS -TOTAL NUMBER OF STATIONS (0037) C* NV -TOTAL NUMBER OF DISTANCE, DIRECTION, ANGLE AND AZIMUTH OB (0038) C* VATIONS PLUS THE NUMBER OF COORDINATES OF WEIGHTED STATION (0039) C* N1 -NUMBER OF DISTANCE OBSERVATIONS (0040) C* N2 -NUMBER OF DIRECTION OBSERVATIONS (0041) C* N3 -NUMBER OF ANGLE OBSERVATIONS (0042) C* N4 -NUMBER OF AZIMUTH OBSERVATIONS (0043) C* OX -MATRIX OF COORDINATES OF WEIGHTED STATIONS (0044) C* PX -VECTOR CONTAINING ELEMENTS OF INFORMATION MATRIX FOR WEIG (0045) C* STATIONS (0046) C* RL -LONGITUDE OF ORIGIN OF PROJECTION IN RADIANS (0047) C* RN -MATRIX OF NORMAL EQUATIONS (0048) C* RP -LATITUDE OF ORIGIN OF PROJECTION IN RADIANS (0049) C* RU -CONSTANT VECTOR (0050) C* R1 -RADIUS OF CONFORMAL SPHERE FOR THE DOUBLE STEREOGRAPHIC (0051) C* PROJECTION (0052) C* S0 -VALUE OF THE QUADRATIC FORM OF WEIGHTED RESIDUALS (0053) C* TL -VECTOR CONTAINING THE INPUT TITLE (READ FROM THE TITLE CA (0054) C* WX -MISCLOSURE VECTOR FOR WEIGHTED STATIONS (0055) C* X0 -FALSE EASTING OF THE MAP PROJECTION (0056) C* X1 -TRANSLATION COMPONENT FROM THE GEOCENTRE TO THE REFERENCE (0057) C* ELLIPSOID (0058) C* Y0 -FALSE NORTHING OF THE MAP PROJECTION (0059) C* Y1 -TRANSLATION COMPONENT FROM THE GEOCENTRE TO THE REFERENCE (0060) C* ELLIPSOID (0061) C* Z1 -TRANSLATION COMPONENT FROM THE GEOCENTRE TO THE REFERENCE (0062) C* ELLIPSOID (0063) C* CBH -VECTOR CONTAINING NAMES OF BLAHA STATIONS (0064) C* CIO -MATRIX OF NAMES OF SIGHTED STATIONS FOR OBSERVATIONS (0065) C* CNF -VECTOR OF NAMES OF FIXED STATIONS (0066) C* CPX -VECTOR OF NAMES OF WEIGHTED STATIONS (0067) C* DOB -MATRIX CONTAINING REDUCED OBSERVATIONS AND THEIR STANDARD (0068) C* VIATIONS (0069) C* FAC -VECTOR OF FACTORS FOR INPUT STANDARD DEVIATIONS OF OBSERV (0070) C* IBH -VECTOR OF SEQUENCE NUMBERS FOR BLAHA STATIONS (0071) C* ICA -MATRIX OF COLUMN CODES FOR THE DESIGN MATRIX (0072) C* ICP -WORKING VECTOR (0073) C* IDF -NUMBER OF DEGREES OF FREEDOM OF ADJUSTMENT (0074) C* IID -RETURN CODE FROM XSIN INDICATING STATUS OF CONVERGENCE (0075) C* IOB -MATRIX OF SEQUENCE NUMBERS FOR STATIONS AND TYPE CODES OF (0076) C* SERVATIONS (0077) C* IPX -VECTOR OF SEQUENCE NUMBERS FOR WEIGHTED STATIONS (0078) C* NBR -DIMENSIONED SIZE OF VECTORS ASSOCIATED WITH BLAHA STATION (0079) C* NB2 -NUMBER OF COORDINATES OF BLAHA STATIONS (0080) C* NB3 -NUMBER OF UPPER DIAGONAL ELEMENTS FOR BLAHA INFORMATION M (0081) C* NSR -DIMENSIONED SIZE OF MATRICES AND VECTORS ASSOCIATED WITH (0082) C* NUMBER OF STATIONS (0083) C* RKO -POINT SCALE FACTOR AT THE ORIGIN OF THE MAP PROJECTION (0084) C* SBH -INFORMATION MATRIX FOR BLAHA STATIONS (0085) C* SPX -INFORMATION MATRIX FOR WEIGHTED STATIONS (0086) C* ZER -ESTIMATED ZERO ERROR FOR DISTANCES (0087) C* ALPH -PERCENTAGE CONFIDENCE LEVEL FOR TESTING AND ELLIPSES (0088) C* CENT -VECTOR OF CENTERING ERRORS FOR DISTANCES (CENT(1)), DIREC (0089) C* (CENT(2)), ANGLES(CENT(3)), AND AZIMUTHS(CENT(4)) (0090) C* CERR -VECTOR OF STATION NAMES IN A SET FOR SIMULTANEOUS ELLIPSE (0091) C* CNAM -VECTOR OF STATION NAMES FOR ALL STATIONS (0092) C* DOBR -MATRIX CONTAINING OBSERVED VALUES OF OBSERVATIONS (0093) C* ICER -VECTOR OF SEQUENCE NUMBERS FOR A SET OF STATIONS FOR SIMU (0094) C* TANEOUS ELLIPSES (0095) C* ITER -ITERATION COUNTER (0096) C* NBHR -DIMENSIONED SIZE OF VECTOR CONTAINING ELEMENTS OF BLAHA (0097) C* INFORMATION MATRIX (0098) C* NB2R -DIMENSIONED SIZE OF BLAHA INFORMATION MATRIX (0099) C* NCOV -CODE FOR TYPE OF MATRIX INPUT FOR WEIGHTED STATIONS (=0 F (0100) C* COVARIANCE MATRIX AND =1 FOR WEIGHT MATRIX) (0101) C* NFAC -CODE FOR WHETHER FAC IS OTHER THAN ONES (0=UNITY,1=FACTOR (0102) C* READ) (0103) C* NFIX -VECTOR OF SEQUENCE NUMBERS FOR FIXED STATIONS (0104) C* NINC -COUNTER FOR DIVERGENCE MONITORING (0105) C* NPRA -CODE FOR PRINTING THE DESIGN MATRIX A (0106) C* NPRN -CODE FOR PRINTING THE NORMAL EQUATIONS (0107) C* NPRU -CODE FOR PRINTING THE CONSTANT VECTOR (0108) C* NPRW -CODE FOR PRINTING THE MISCLOSURE VECTOR (0109) C* NPXR -DIMENSIONED SIZE OF VECTOR FOR UPPER DIAGONAL ELEMENTS OF (0110) C* INFORMATION MATRIX FOR WEIGHTED STATIONS (0111) C* NP2R -DIMENSIONED SIZE OF INFORMATION MATRIX FOR WEIGHTED STATI (0112) C* VARF -ESTIMATED VARIANCE FACTOR (0113) C* VCLS -VECTOR CONTAINING ORDERED RESIDUALS (0114) C* CONVG -CONVERGENCE CRITERION (0115) C* NABST -CODE FOR PRINTING STATION ABSTRACTS (0116) C* NCENT -CODE FOR CENTERING ERRORS (0117) C* NCODE -CODE FOR PREANALYSIS OR ADJUSTMENT (0118) C* NCORR -CODE FOR PRINTING REDUCTION CORRECTIONS FOR OBSERVATIONS (0119) C* NCOVD -CODE FOR TYPE OF INFORMATION MATRIX READ FOR BLAHA STATIO (0120) C* (=0 COVARIANCE MATRIX; =1 WEIGHT MATRIX) (0121) C* NCRIT -CODE FOR CONVERGENCE CRITERION (0122) C* NDELX -CODE FOR PRINTING ITERATIVE CORRECTIONS TO INITIAL COORDI (0123) C* NELPS -CODE FOR ERROR ELLIPSES (NON-SIMULTANEOUS) (0124) C* NITER -CODE FOR MAXIMUM NUMBER OF ITERATIONS TO BE ALLOWED (0125) C* NMULT -CODE FOR MULTIPLICATION OF THE INVERSE OF THE NORMAL EQUA (0126) C* BY THE ESTIMATED VARIANCE FACTOR (0127) C* NPRCX -CODE FOR PRINTING COVARIANCE MATRIX OF PARAMETERS (0128) C* NPROJ -CODE FOR MAP PROJECTION (0129) C* NRED1 -CODE FOR REDUCTIONS OF OBSERVATIONS FROM TERRAIN TO ELLIP (0130) C* NRED2 -CODE FOR REDUCTIONS OF OBSERVATIONS FROM ELLIPSOID TO PLA (0131) C* NRED3 -CODE FOR REDUCTION OF AZIMUTHS FROM TERRAIN TO PLANE (0132) C* NSIMU -CODE FOR SIMULTANEOUS ELLIPSES (0133) C* NSQRT -CODE FOR PRINTING CHOLESKI SQUARE ROOT (0134) C* NSRES -CODE FOR STANDARD DEVIATIONS OF RESIDUALS (0135) C* NSTAN -CODE FOR CONFIDENCE LEVEL OF TESTING AND ELLIPSES (0136) C* NTEST -CODE FOR TEST USED FOR REJECTION OF RESIDUALS (0137) C* NUNIT -CODE FOR LINEAR UNITS (0138) C* NVARF -CODE FOR KNOWLEDGE OF VARIANCE FACTOR (0139) C* NZERO -CODE FOR ESTIMATION OF ZERO ERROR (0140) C* WANGC -ANGULAR MISCLOSURE CRITERION (0141) C* WDISC -LINEAR MISCLOSURE CRITERION (0142) C* NUMREJ -NUMBER OF RESIDUALS FLAGGED FOR REJECTION (0143) C* (0144) C*********************************************************************** (0145) IMPLICIT REAL*8(A-H,O-Z) (0146) LOGICAL OPEN,LSTOP (0147) (0148) C DIMENSIONES FOR 1000 OBS. 30 FIXED, 60 UNKNOWN STAT. (0149) (0150) C CHANGE NR BELOW (WHEN CHANGING THE FOLLOWING DIMENSION STATEMENT) (0151) DIMENSION RN(121,121),RU(121),X(121),D(121),ICP(121),IB(121) (0152) @,CERR(121) (0153) C CHANGE NFR BELOW (0154) DIMENSION NFIX(30),CNF(30),NHFIX(30),CNHF(30) (0155) C CHANGE NOR BELOW (0156) DIMENSION A(1000,6),ICA(1000,6),IOB(1000,4),DOB(1000,4),W(1000), (0157) @ CIO(1000,3),DOBR(1000,4),AS(1000,6),B(1000,6),VCLS(1000), (0158) @ DLDH(1000,2) (0159) C CHANGE NSR BELOW (0160) DIMENSION AP(60,12),IC(60,3),CNAM(60),ICER(60),ZZ(60) (0161) C CHANGE NPR BELOW (0162) DIMENSION IPX(30),OX(30,2),CPX(30) (0163) C CHANGE NP2R BELOW (0164) DIMENSION SPX(60,60),WX(60) (0165) C CHANGE NBR BELOW (0166) DIMENSION IBH(30),CBH(30) (0167) C CHANGE NB2R BELOW (0168) DIMENSION SBH(60,60) (0169) C THE FOLLOWING DIMENSION MUST BE NB2R*(NB2R+1)/2 (=NBHR BELOW) (0170) DIMENSION BH(1830) (0171) C THE FOLLOWING DIMENSION MUST BE NP2R*(NP2R+1)/2 (=NPXR BELOW) (0172) DIMENSION PX(1830) (0173) C THE FOLLOWING DIMENSION MUST BE NOR+NP2R (0174) DIMENSION V(1060) (0175) C THE FOLLOWING DIMENSIONS MUST NOT BE CHANGED (0176) DIMENSION FAC(5),TL(10),CENT(4) (0177) INTEGER*2 IFELDI(16),IFELDO(16),IFELDP(16) (0178) COMMON /BIG/ A,DOB,W,CIO,DOBR,AS,B,VCLS,DLDH (0179) COMMON /LT/RN,SPX,SBH,BH,PX (0180) COMMON /STATIS/ NDF1 (0181) C A$KEYS, APPLIB, ELS, 08/21/80 (0181) C Insert file for mnemonic APPLIB keys (FTN) (0181) C Copyright 1977, PR1ME COMPUTER, INC., Framingham, MA. (0181) NOLIST (0182) (0183) LSTOP = .FALSE. (0184) INP = 5 (0185) IOUT = 6 (0186) IPUN = 7 (0187) 802 OPEN=OPNP$A('INPUTFILE',INTS(9),A$READ+A$SAMF,IFELDI,INTS(32), (0188) 1INTS(INP-4)) (0189) IF(.NOT.OPEN)GOTO 802 (0190) 803 OPEN=OPNP$A('OUTPUTFILE',INTS(10),A$WRIT+A$SAMF,IFELDO,INTS(32), (0191) 1INTS(IOUT-4)) (0192) IF(.NOT.OPEN)GOTO 803 (0193) 804 OPEN=OPNP$A('PUNCHFILE',INTS(9),A$WRIT+A$SAMF,IFELDP,INTS(32), (0194) 1INTS(IPUN-4)) (0195) IF(.NOT.OPEN)GOTO 804 (0196) CALL GEND$A(INTS(IPUN-4)) (0197) (0198) C PRINTER CONTROLE RECORD (0199) WRITE(6,9902) (0200) 9902 FORMAT('F+'/) (0201) (0202) C INITIALIZE VARIABLES FOR DIMENSIONED SIZES (0203) NR=121 (0204) NFR=30 (0205) NOR=1000 (0206) NSR=60 (0207) NPR=30 (0208) NP2R=60 (0209) NPXR=1830 (0210) NBR=30 (0211) NB2R=60 (0212) NBHR=1830 (0213) C READ AND STORE INPUT DATA (0214) CALL READ(TL,NP2R,NCODE,NF,NP,NSTAN,NPROJ,NUNIT,NELPS,NDELX, (0215) @ NFAC,NITER,NZERO,NTEST,NMULT,NCOV,CNF,NFR,NP2,NP3,CPX,NPR, (0216) @ PX,NPXR,ALPH ,FAC,CNAM,NSR,AP,NS,X,D,NR,IOB,NOR,DOB,CIO,NO,ND,N, (0217) @ NCORR,CONVG,CENT,NCENT,NCRIT,NRED1,NRED2,NRED3,NB,CBH,BH, (0218) @ NBR,NBHR,NCOVB,N1,N2,N3,N4,CERR,NSIMU,NSRES,NPRA,NPRN,NPRW, (0219) @ NPRU,NPRCX,NSQRT,NB2,NB3,NVARF,NDISK,1,WANGC,WDISC,NABST,NUTM, (0220) @ N3DIM,NHF,CNHF) (0221) C IF(N3DIM.EQ.2) CALL CHREAD( ) (0222) C GENERATE SEQUENCE NUMBERS (0223) CALL NAMC(NSR,NOR,NO,NS,NP,NFIX,IPX,CIO,CNAM,CNF,CPX,IOB,NF,NPR, (0224) @ NFR,IBH,CBH,NBR,NB,CNHF,NHF,NHFIX) (0225) ID=0 (0226) C CHECKS ON INPUT DATA (0227) CALL INERR(NO,IOB,DOB,ID,NS,NCODE,NOR) (0228) IF(ID.EQ.1)GOTO99 (0229) CALL CHEK(N,NP,NB,NF,CNF,NFR,CPX,NPR,CBH,NBR,NO,N1,N2,N3,N4, (0230) @ NZERO,ND,IDF,LSTOP,NS,N3DIM,NH,NUH,NHF) (0231) WRITE(7,7121) NO,NP,N,ND,IDF,NZERO,NH,NUH (0232) 7121 FORMAT(8I4) (0233) C GENERATE DESIGN MATRIX AND NORMAL EQUATION COLUMN CODES (0234) CALL COL(NFIX,NF,IC,NS,NSR,NFR,NB,IBH,NBR,N3DIM,NHFIX,NHF) (0235) CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,1,NZERO,N,N3DIM) (0236) C COMPUTE STANDARD DEVIATIONS OF OBSERVATIONS AND INFORMATION FOR EACH (0237) C STATION (0238) CALL FILDOR(IOB,DOB,DOBR,NO,NOR,NCENT,AP,NSR,CENT) (0239) IF(NPROJ.EQ.3)GOTO50 (0240) CALL FILAP(AP,NSR,NPROJ,NUNIT,AA,BB,NS,RP,RL,XO,YO,X1,Y1,Z1,R1, (0241) @ RKO,NUTM) (0242) C PRINT TITLE PAGE AND INITIAL COORDINATES (0243) CALL PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSR,NFIX, (0244) @ NPROJ,NUNIT,NELPS,NSTAN,ALPH,NFAC,NZERO,NTEST,NCOV, (0245) @ NCORR,NMULT,NITER,NDELX,NCRIT,CONVG,NRED1,NRED2,NCENT,CENT, (0246) @ NRED3,1,NB,CBH,NBR,ZER,NCOVB,IBH,IPX,AA,BB,RP,RL,XO,YO,X1,Y1,Z1, (0247) @ RKO,IDF,NUTM,N3DIM) (0248) C IF(NCODE.EQ.1)GOTO50 (0249) C IF(NRED1.EQ.0)GOTO51 (0250) C MAKE OBSERVATION REDUCTIONS FROM TERRAIN TO ELLIPSOID (0251) CALL TOELPS(IOB,DOB,DOBR,NOR,AA,BB,X1,Y1,Z1,AP,NSR,NCORR,NO,CNAM, (0252) @ NRED3,NCODE,NRED1,N3DIM,DLDH) (0253) 51 IF(NRED2.EQ.0.OR.NCODE.EQ.1) GOTO 50 (0254) C MAKE OBSERVATION REDUCTIONS FROM ELLIPSOID TO PLANE (0255) CALL TOPLAN(IOB,DOB,NOR,XO,YO,RKO,AP,NSR,NCORR,NO,CNAM, (0256) @ NRED3,NPROJ,AA,BB,R1,DOBR,NRED1) (0257) 50 CONTINUE (0258) IF(NPROJ.NE.3)GOTO53 (0259) CALL PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSR,NFIX, (0260) @ NPROJ,NUNIT,NELPS,NSTAN,ALPH,NFAC,NZERO,NTEST,NCOV, (0261) @ NCORR,NMULT,NITER,NDELX,NCRIT,CONVG,NRED1,NRED2,NCENT,CENT, (0262) @ NRED3,1,NB,CBH,NBR,ZER,NCOVB,IBH,IPX,AA,BB,RP,RL,XO,YO,X1,Y1,Z1, (0263) @ RKO,IDF,NUTM,N3DIM) (0264) C FORM INFORMATION MATRIX FOR WEIGHTED AND/OR BLAHA STATIONS (0265) 53 IF(NB.NE.0)CALL FORMPX(OX,AP,NBR,NSR,NB,NB2,SBH,NB2R,BH,NBHR,NCOVB (0266) @,IB,NR,RU,D,IBH,X,CONVG,CNAM,NS,IOB,NOR,IC,ICA,W,CBH,WX,NO,2) (0267) IF(NP.NE.0)CALL FORMPX(OX,AP,NPR,NSR,NP,NP2,SPX,NP2R,PX,NPXR,NCOV, (0268) @ IB,NR,RU,D,IPX,X,CONVG,CNAM,NS,IOB,NOR,IC,ICA,W,CPX,WX,NO,1) (0269) C CHECK DETERMINATION OF NETWORK (0270) CALL CHKDEM(NS,NF,NFIX,NFR,NP,IPX,NPR,NB,IBH,NBR,NO,IOB,NOR,CNAM,N (0271) @SR,N1,N4,LSTOP) (0272) C INITIALIZE SOME VARIABLES (0273) ZER=0.0D0 (0274) NN=N-NZERO (0275) ITER=-1 (0276) 21 ITER=ITER+1 (0277) CALL ZERON(RN,RU,IB,N,NR) (0278) C FORM NORMAL EQUATIONS AND CONSTANT VECTOR, PRINTING INTERMEDIATE RE- (0279) C SULTS IF REQUESTED (0280) CALL NORVEC(IOB,DOB,N,SPX,NP,IPX,ICP,RN,RU,A,ICA,AP,IC,IB,NO,NS, (0281) @ NCODE,OX,NZERO,W,WX,NPR,NOR,NP2R,NR,NSR,ITER,ZER,CNAM,DOBR, (0282) @NFAC,FAC,N3DIM,DLDH) (0283) IF(ITER.EQ.0.AND.NCODE.EQ.2)CALL CHKMIS(W,NOR,NO,WANGC,WDISC,IOB, (0284) @DOB,CNAM,NSR,NUNIT) (0285) IF(NPRA.NE.0.AND.((NPRA.EQ.1.AND.ITER.EQ.0).OR.(NPRA.EQ.2))) (0286) @ CALL PRAR(A,NOR,6,NO,6,1,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, (0287) @ CPX,NP,WX,NR,NP2R,NPR,NO) (0288) IF(NPRN.NE.0.AND.((NPRN.EQ.1.AND.ITER.EQ.0).OR.(NPRN.EQ.2))) (0289) @ CALL PRAR(RN,NR,NR,N,N,21,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, (0290) @ CPX,NP,WX,NR,NP2R,NPR,NO) (0291) 101 IF(NPRN.NE.3.OR.ITER.NE.0)GOTO 102 (0292) 201 DO 202 I=1,N (0293) JSTART = I (0294) JEND = N (0295) WRITE(7,7101)(RN(I,J),J=JSTART,JEND) (0296) 7101 FORMAT(4D20.13) (0297) 202 CONTINUE (0298) 102 CONTINUE (0299) (0300) IF(NPRW.NE.0.AND.((NPRW.EQ.1.AND.ITER.EQ.0).OR.(NPRW.EQ.2))) (0301) @ CALL PRAR(W,NOR,1,NO,1,4,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, (0302) @ CPX,NP,WX,NR,NP2R,NPR,NO) (0303) IF(NPRU.NE.0.AND.((NPRU.EQ.1.AND.ITER.EQ.0).OR.(NPRU.EQ.2))) (0304) @CALL PRAR(RU,NR,1,N,1,3,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, (0305) @ CPX,NP,WX,NR,NP2R,NPR,NO) (0306) 103 IF(NPRU.NE.3.OR.ITER.NE.0) GOTO 104 (0307) 208 DO 209 I = 1,N (0308) WRITE(7,7001) RU(I) (0309) 7001 FORMAT(D20.13) (0310) 209 CONTINUE (0311) 104 CONTINUE (0312) NV=NO+NP2 (0313) C STORE DESIGN MATRIX ON PUNCH-FILE (0314) 105 IF(NPRA.NE.3.OR.NPRW.NE.3.OR.ITER.NE.0) GOTO 106 (0315) CALL ASTOR(IOB,NO,A,W,WX,ICA,NP,ICP,SPX,NOR,NR,NP2R, (0316) 1 DOBR,NV) (0317) 106 CONTINUE (0318) IF(LSTOP) GOTO 99 (0319) C SOLVE SYSTEM VIA THE CHOLESKI METHOD (0320) CALL XSIN(RN,N,NCODE,NN,RU,D,IID,IB,X,NR,CONVG,NSQRT,ITER,CNAM, (0321) @ NS,IOB,NOR,IC,NSR,ICA,RU,W,CPX,NB,WX,NP2R,NPR,NO,1,NITER,0,NUH) (0322) IF(NCODE.EQ.1)GOTO24 (0323) C UPDATE COORDINATES (0324) CALL UPDAT(NS,ITER,NF,NFIX,AP,X,NZERO,ZER,N,NSR,CNAM,NFR,NDELX, (0325) @NB,IBH,NBR,N3DIM,IC,ZZ) (0326) C CHECK FOR DIVERGENCE OR CONVERGENCE (0327) CALL CHKDIV(ITER,X,NINC,CERR,NSR,NR,NB,NF,NS,CONVG) (0328) IF(ITER.LT.NITER.AND.IID.EQ.1)GOTO21 (0329) IF(NPROJ.EQ.3)GOTO52 (0330) C COMPUTE ADJUSTED INFORMATION FOR STATIONS (0331) CALL FILAP(AP,NSR,NPROJ,NUNIT,AA,BB,NS,RP,RL,XO,YO,X1,Y1,Z1,R1, (0332) @ RKO,NUTM) (0333) C PRINT ADJUSTED COORDINATES (0334) 52 CALL PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSR,NFIX, (0335) @ NPROJ,NUNIT,NELPS,NSTAN,ALPH,NFAC,NZERO,NTEST,NCOV, (0336) @ NCORR,NMULT,NITER,NDELX,NCRIT,CONVG,NRED1,NRED2,NCENT,CENT, (0337) @ NRED3,2,NB,CBH,NBR,ZER,NCOVB,IBH,IPX,AA,BB,RP,RL,XO,YO,X1,Y1,Z1, (0338) @ RKO,IDF,NUTM) (0339) IF(IDF.EQ.0)GOTO24 (0340) C COMPUTE RESIDUALS... (0341) CALL RESID(IOB,NO,A,X,W,WX,ICA,N,V,NV,ND,NP,ICP,SPX,NOR,NR, (0342) @ NP2R,CNAM,NSR,ZER,DOBR,IDF,S0) (0343) C ...PRINT THEM AND THEN STANDARDIZE THEM (0344) CALL PRES(IDF,S0,NO,IOB,DOB,ZER,V,NV,CNAM,NSR,DOBR,NOR,NSRES) (0345) C CHECK RESIDUALS AGAINST REJECTION CRITERION (0346) CALL RESREJ(V,NV,DOB,IOB,NOR,NO,NTEST,ALPH,IDF,CNAM,NSR,NUMREJ) (0347) 24 CONTINUE (0348) C COMPUTE AND PRINT SOME STATISTICS OF THE ADJUSTMENT (0349) CALL STATS(ITER,NITER,N1,N2,N3,N4,NP,NB,NZERO,ND,N,IDF,S0,NVARF, (0350) @ NUMREJ,NCODE,V,NV,DOB,NOR,NO,IOB,ALPH,VCLS,VARF,NH,NUH) (0351) IF(NB.NE.0)CALL DELQX(RN,NR,SBH,NB2R,A,ICA,NOR,NZERO,NB,N,IC,OX (0352) @,IOB,DOB,IBH,NBR,NO,RU,ICP,AP,NSR,IB,WX,CNAM,DOBR,NS,W,CBH,NPR, (0353) @ NP2R,NFR,FAC,NFIX,NF,B,N3DIM,NHFIX,NHF) (0354) C MULTIPLY INVERSE OF NORMAL EQUATIONS BY ESTIMATED VARIANCE FACTOR IF (0355) C REQUESTED (0356) IF(NMULT.EQ.1.AND.NCODE.EQ.2)CALL MULCX(VARF,RN,NR,N) (0357) C COMPUTE ERROR ELLIPSES AND PRINT THEM (0358) CALL ERREL(RN,NR,N,IC,NS,NELPS,NSIMU,NVARF,AP,NSR,A,NOR,CERR, (0359) @ALPH,IDF,NF,NB,CNAM,VARF,NMULT,NCODE,NSTAN,NUNIT,ICER,TL,CNF, (0360) @NFR,CPX,NPR,PX,NPXR,FAC,X,D,IOB,DOB,CIO,NO,CENT,CBH,NBR,BH,NBHR, (0361) @NPRCX,NABST,NUTM,N3DIM) (0362) C PRINT COVARIANCE MATRIX IF REQUESTED (0363) IF(NPRCX.EQ.1)CALL PRAR(RN,NR,NR,N,N,23,CNAM,NS,ITER,IOB,NOR,IC, (0364) @ NSR,ICA,RU,W,CPX,NP,WX,NR,NP2R,NPR,NO) (0365) C PRINT STATION ABSTRACTS IF REQUESTED (0366) IF(NABST.EQ.1.AND.NPROJ.NE.3.AND.NCODE.EQ.2)CALL ABSTR(CNAM,NSR, (0367) @AP,RN,NR,IOB,NOR,NO,IC,NB,NS,NUNIT,NPROJ,RKO,AA,BB,XO,YO,R1) (0368) 99 CONTINUE (0369) C CLOSE FILES (0370) CALL CLOS$A(INTS(INP-4)) (0371) CALL TRNC$A(INTS(IOUT-4)) (0372) CALL CLOS$A(INTS(IOUT-4)) (0373) CALL TRNC$A(INTS(IPUN-4)) (0374) CALL CLOS$A(INTS(IPUN-4)) (0375) CALL EXIT (0376) END PROGRAM SIZE: PROCEDURE - 005010 LINKAGE - 076660 STACK - 000050 A D /BIG/ 000000 000000 0156S 0178S 0280A 0285A 0315A 0341A 0351A 0358A A$READ I PARAMETER 0181S 0187 A$SAMF I PARAMETER 0181S 0187 0190 0193 A$WRIT I PARAMETER 0181S 0190 0193 AA D LINKAGE 077040 0240A 0243A 0251A 0255A 0259A 0331A 0334A 0366A ABSTR D EXTERNAL 000000 0366 ALPH D LINKAGE 076660 0214A 0243A 0259A 0334A 0346A 0349A 0358A AP D LINKAGE 000432 0160S 0214A 0238A 0240A 0243A 0251A 0255A 0259A 0265A 0267A 0280A 0324A 0331A 0334A 0351A 0358A 0366A ASTOR D EXTERNAL 000000 0315 B D /BIG/ 000001 073400 0156S 0178S 0351A BB D LINKAGE 077044 0240A 0243A 0251A 0255A 0259A 0331A 0334A 0366A BH D /LT/ 000001 052504 0170S 0179S 0214A 0265A 0358A CBH D LINKAGE 006132 0166S 0214A 0223A 0229A 0243A 0259A 0265A 0334A 0351A 0358A CENT D LINKAGE 006322 0176S 0214A 0238A 0243A 0259A 0334A 0358A CERR D LINKAGE 006342 0151S 0214A 0327A 0358A CHEK D EXTERNAL 000000 0229 CHKDEM D EXTERNAL 000000 0270 CHKDIV D EXTERNAL 000000 0327 CHKMIS D EXTERNAL 000000 0283 CIO D /BIG/ 000000 125740 0156S 0178S 0214A 0223A 0358A CLOS$A L EXTERNAL 000000 0181S 0370 0372 0374 CNAM D LINKAGE 007306 0160S 0214A 0223A 0243A 0251A 0255A 0259A 0265A 0267A 0270A 0280A 0283A 0285A 0288A 0300A 0303A 0320A 0324A 0334A 0341A 0344A 0346A 0351A 0358A 0363A 0366A CNF D LINKAGE 007666 0154S 0214A 0223A 0229A 0243A 0259A 0334A 0358A CNHF D LINKAGE 010056 0154S 0214A 0223A CODE D EXTERNAL 000000 0235 COL D EXTERNAL 000000 0234 CONVG D LINKAGE 076702 0214A 0243A 0259A 0265A 0267A 0320A 0327A 0334A CPX D LINKAGE 010246 0162S 0214A 0223A 0229A 0243A 0259A 0267A 0285A 0288A 0300A 0303A 0320A 0334A 0358A 0363A D D LINKAGE 010436 0151S 0214A 0265A 0267A 0320A 0358A DELQX D EXTERNAL 000000 0351 DLDH D /BIG/ 000001 162140 0156S 0178S 0251A 0280A DOB D /BIG/ 000000 056700 0156S 0178S 0214A 0227A 0235A 0238A 0251A 0255A 0280A 0283A 0344A 0346A 0349A 0351A 0358A DOBR D /BIG/ 000000 155300 0156S 0178S 0238A 0251A 0255A 0280A 0315A 0341A 0344A 0351A ERREL D EXTERNAL 000000 0358 EXIT D EXTERNAL 000000 0375 FAC D LINKAGE 011402 0176S 0214A 0235A 0280A 0351A 0358A FILAP D EXTERNAL 000000 0240 0331 FILDOR D EXTERNAL 000000 0238 FORMPX D EXTERNAL 000000 0265 0267 GEND$A L EXTERNAL 000000 0181S 0196 I J LINKAGE 077162 0292M 0293 0295 0307M 0308 IB J LINKAGE 011426 0151S 0265A 0267A 0277A 0280A 0320A 0351A IBH J LINKAGE 012010 0166S 0223A 0234A 0243A 0259A 0265A 0270A 0324A 0334A 0351A IC J LINKAGE 012104 0160S 0234A 0235A 0265A 0267A 0280A 0285A 0288A 0300A 0303A 0320A 0324A 0351A 0358A 0363A 0366A ICA J LINKAGE 012654 0156S 0235A 0265A 0267A 0280A 0285A 0288A 0300A 0303A 0315A 0320A 0341A 0351A 0363A ICER J LINKAGE 042214 0160S 0358A ICP J LINKAGE 042404 0151S 0280A 0315A 0341A 0351A ID J LINKAGE 077010 0225M 0227A 0228 IDF J LINKAGE 077016 0229A 0231 0243A 0259A 0334A 0339 0341A 0344A 0346A 0349A 0358A IFELDI I LINKAGE 042766 0177S 0187A IFELDO I LINKAGE 043006 0177S 0190A IFELDP I LINKAGE 043026 0177S 0193A IID J LINKAGE 077204 0320A 0328 INERR J EXTERNAL 000000 0227 INP J LINKAGE 076552 0184M 0187 0370 INTS J EXTERNAL 000000 0187 0190 0193 0196 0370 0371 0372 0373 0374 IOB J LINKAGE 043046 0156S 0214A 0223A 0227A 0235A 0238A 0251A 0255A 0265A 0267A 0270A 0280A 0283A 0285A 0288A 0300A 0303A 0315A 0320A 0341A 0344A 0346A 0349A 0351A 0358A 0363A 0366A IOUT J LINKAGE 076554 0185M 0190 0371 0372 IPUN J LINKAGE 076556 0186M 0193 0196 0373 0374 IPX J LINKAGE 062546 0162S 0223A 0243A 0259A 0267A 0270A 0280A 0334A ITER J LINKAGE 077144 0275M 0276M 0280A 0283 0285A 0288A 0291 0300A 0303A 0306 0314 0320A 0324A 0327A 0328 0349A 0363A J J LINKAGE 077172 0295M JEND J LINKAGE 077166 0294M 0295 JSTART J LINKAGE 077164 0293M 0295 LSTOP L LINKAGE 000400 0146S 0183M 0229A 0270A 0318 MULCX J EXTERNAL 000000 0356 N J LINKAGE 076676 0214A 0229A 0231 0235A 0274 0277A 0280A 0288A 0292 0294 0303A 0307 0320A 0324A 0341A 0349A 0351A 0356A 0358A 0363A N1 J LINKAGE 076726 0214A 0229A 0270A 0349A N2 J LINKAGE 076730 0214A 0229A 0349A N3 J LINKAGE 076732 0214A 0229A 0349A N3DIM J LINKAGE 077002 0214A 0229A 0234A 0235A 0243A 0251A 0259A 0280A 0324A 0351A 0358A N4 J LINKAGE 076734 0214A 0229A 0270A 0349A NABST J LINKAGE 076776 0214A 0358A 0366 NAMC J EXTERNAL 000000 0223 NB J LINKAGE 076720 0214A 0223A 0229A 0234A 0243A 0259A 0265A 0270A 0320A 0324A 0327A 0334A 0349A 0351A 0358A 0366A NB2 J LINKAGE 076756 0214A 0265A NB2R J LINKAGE 076610 0211M 0265A 0351A NB3 J LINKAGE 076760 0214A NBHR J LINKAGE 076612 0212M 0214A 0265A 0358A NBR J LINKAGE 076606 0210M 0214A 0223A 0229A 0234A 0243A 0259A 0265A 0270A 0324A 0334A 0351A 0358A NCENT J LINKAGE 076706 0214A 0238A 0243A 0259A 0334A NCODE J LINKAGE 076616 0214A 0227A 0243A 0251A 0253 0259A 0280A 0283 0320A 0322 0334A 0349A 0356 0358A 0366 NCORR J LINKAGE 076700 0214A 0243A 0251A 0255A 0259A 0334A NCOV J LINKAGE 076650 0214A 0243A 0259A 0267A 0334A NCOVB J LINKAGE 076724 0214A 0243A 0259A 0265A 0334A NCRIT J LINKAGE 076710 0214A 0243A 0259A 0334A ND J LINKAGE 076674 0214A 0229A 0231 0341A 0349A NDELX J LINKAGE 076634 0214A 0243A 0259A 0324A 0334A NDISK J LINKAGE 076764 0214A NELPS J LINKAGE 076632 0214A 0243A 0259A 0334A 0358A NF J LINKAGE 076620 0214A 0223A 0229A 0234A 0243A 0259A 0270A 0324A 0327A 0334A 0351A 0358A NFAC J LINKAGE 076636 0214A 0243A 0259A 0280A 0334A NFIX J LINKAGE 062642 0154S 0223A 0234A 0243A 0259A 0270A 0324A 0334A 0351A NFR J LINKAGE 076572 0204M 0214A 0223A 0229A 0234A 0243A 0259A 0270A 0324A 0334A 0351A 0358A NH J LINKAGE 077020 0229A 0231 0349A NHF J LINKAGE 077004 0214A 0223A 0229A 0234A 0351A NHFIX J LINKAGE 062736 0154S 0223A 0234A 0351A NINC J LINKAGE 077212 0327A NITER J LINKAGE 076640 0214A 0243A 0259A 0320A 0328 0334A 0349A NMULT J LINKAGE 076646 0214A 0243A 0259A 0334A 0356 0358A NN J LINKAGE 077142 0274M 0320A NO J LINKAGE 076672 0214A 0223A 0227A 0229A 0231 0235A 0238A 0251A 0255A 0265A 0267A 0270A 0280A 0283A 0285A 0288A 0300A 0303A 0312 0315A 0320A 0341A 0344A 0346A 0349A 0351A 0358A 0363A 0366A NOR J LINKAGE 076574 0205M 0214A 0223A 0227A 0235A 0238A 0251A 0255A 0265A 0267A 0270A 0280A 0283A 0285A 0288A 0300A 0303A 0315A 0320A 0341A 0344A 0346A 0349A 0351A 0358A 0363A 0366A NORVEC J EXTERNAL 000000 0280 NP J LINKAGE 076622 0214A 0223A 0229A 0231 0243A 0259A 0267A 0270A 0280A 0285A 0288A 0300A 0303A 0315A 0334A 0341A 0349A 0363A NP2 J LINKAGE 076652 0214A 0267A 0312 NP2R J LINKAGE 076602 0208M 0214A 0243A 0259A 0267A 0280A 0285A 0288A 0300A 0303A 0315A 0320A 0334A 0341A 0351A 0363A NP3 J LINKAGE 076654 0214A NPR J LINKAGE 076600 0207M 0214A 0223A 0229A 0243A 0259A 0267A 0270A 0280A 0285A 0288A 0300A 0303A 0320A 0334A 0351A 0358A 0363A NPRA J LINKAGE 076742 0214A 0285 0314 NPRCX J LINKAGE 076752 0214A 0358A 0363 NPRN J LINKAGE 076744 0214A 0288 0291 NPROJ J LINKAGE 076626 0214A 0239 0240A 0243A 0255A 0258 0259A 0329 0331A 0334A 0366A NPRU J LINKAGE 076750 0214A 0303 0306 NPRW J LINKAGE 076746 0214A 0300 0314 NPXR J LINKAGE 076604 0209M 0214A 0267A 0358A NR J LINKAGE 076570 0203M 0214A 0265A 0267A 0277A 0280A 0285A 0288A 0300A 0303A 0315A 0320A 0327A 0341A 0351A 0356A 0358A 0363A 0366A NRED1 J LINKAGE 076712 0214A 0243A 0251A 0255A 0259A 0334A NRED2 J LINKAGE 076714 0214A 0243A 0253 0259A 0334A NRED3 J LINKAGE 076716 0214A 0243A 0251A 0255A 0259A 0334A NS J LINKAGE 076664 0214A 0223A 0227A 0229A 0234A 0240A 0243A 0259A 0265A 0267A 0270A 0280A 0285A 0288A 0300A 0303A 0320A 0324A 0327A 0331A 0334A 0351A 0358A 0363A 0366A NSIMU J LINKAGE 076736 0214A 0358A NSQRT J LINKAGE 076754 0214A 0320A NSR J LINKAGE 076576 0206M 0214A 0223A 0234A 0235A 0238A 0240A 0243A 0251A 0255A 0259A 0265A 0267A 0270A 0280A 0283A 0285A 0288A 0300A 0303A 0320A 0324A 0327A 0331A 0334A 0341A 0344A 0346A 0351A 0358A 0363A 0366A NSRES J LINKAGE 076740 0214A 0344A NSTAN J LINKAGE 076624 0214A 0243A 0259A 0334A 0358A NTEST J LINKAGE 076644 0214A 0243A 0259A 0334A 0346A NUH J LINKAGE 077022 0229A 0231 0320A 0349A NUMREJ J LINKAGE 077226 0346A 0349A NUNIT J LINKAGE 076630 0214A 0240A 0243A 0259A 0283A 0331A 0334A 0358A 0366A NUTM J LINKAGE 077000 0214A 0240A 0243A 0259A 0331A 0334A 0358A NV J LINKAGE 077176 0312M 0315A 0341A 0344A 0346A 0349A NVARF J LINKAGE 076762 0214A 0349A 0358A NZERO J LINKAGE 076642 0214A 0229A 0231 0235A 0243A 0259A 0274 0280A 0324A 0334A 0349A 0351A OPEN L LINKAGE 000404 0146S 0187M 0189 0190M 0192 0193M 0195 OPNP$A L EXTERNAL 000000 0181S 0187 0190 0193 OX D LINKAGE 063032 0162S 0265A 0267A 0280A 0351A PRAR D EXTERNAL 000000 0285 0288 0300 0303 0363 PRES D EXTERNAL 000000 0344 PRIT D EXTERNAL 000000 0243 0259 0334 PX D /LT/ 000001 070734 0172S 0179S 0214A 0267A 0358A R1 D LINKAGE 077104 0240A 0255A 0331A 0366A READ D EXTERNAL 000000 0214 RESID D EXTERNAL 000000 0341 RESREJ D EXTERNAL 000000 0346 RKO D LINKAGE 077110 0240A 0243A 0255A 0259A 0331A 0334A 0366A RL D LINKAGE 077054 0240A 0243A 0259A 0331A 0334A RN D /LT/ 000000 000000 0151S 0179S 0277A 0280A 0288A 0295 0320A 0351A 0356A 0358A 0363A 0366A RP D LINKAGE 077050 0240A 0243A 0259A 0331A 0334A RU D LINKAGE 063412 0151S 0265A 0267A 0277A 0280A 0285A 0288A 0300A 0303A 0308 0320A 0351A 0363A S0 D LINKAGE 077216 0341A 0344A 0349A SBH D /LT/ 000001 016404 0168S 0179S 0265A 0351A SPX D /LT/ 000000 162304 0164S 0179S 0267A 0280A 0315A 0341A STATS D EXTERNAL 000000 0349 TL D LINKAGE 064356 0176S 0214A 0243A 0259A 0334A 0358A TOELPS D EXTERNAL 000000 0251 TOPLAN D EXTERNAL 000000 0255 TRNC$A L EXTERNAL 000000 0181S 0371 0373 UPDAT D EXTERNAL 000000 0324 V D LINKAGE 064426 0174S 0341A 0344A 0346A 0349A VARF D LINKAGE 077234 0349A 0356A 0358A VCLS D /BIG/ 000001 152300 0156S 0178S 0349A W D /BIG/ 000000 116100 0156S 0178S 0265A 0267A 0280A 0283A 0285A 0288A 0300A 0303A 0315A 0320A 0341A 0351A 0363A WANGC D LINKAGE 076766 0214A 0283A WDISC D LINKAGE 076772 0214A 0283A WX D LINKAGE 074646 0164S 0265A 0267A 0280A 0285A 0288A 0300A 0303A 0315A 0320A 0341A 0351A 0363A X D LINKAGE 075226 0151S 0214A 0265A 0267A 0320A 0324A 0327A 0341A 0358A X1 D LINKAGE 077070 0240A 0243A 0251A 0259A 0331A 0334A XO D LINKAGE 077060 0240A 0243A 0255A 0259A 0331A 0334A 0366A XSIN D EXTERNAL 000000 0320 Y1 D LINKAGE 077074 0240A 0243A 0251A 0259A 0331A 0334A YO D LINKAGE 077064 0240A 0243A 0255A 0259A 0331A 0334A 0366A Z1 D LINKAGE 077100 0240A 0243A 0251A 0259A 0331A 0334A ZER D LINKAGE 077116 0243A 0259A 0273M 0280A 0324A 0334A 0341A 0344A ZERON D EXTERNAL 000000 0277 ZZ D LINKAGE 076172 0160S 0324A $101 002544 0291D $102 002657 0291 0298D $103 003101 0306D $104 003164 0306 0311D $105 003172 0314D $106 003255 0314 0317D $201 002561 0292D $202 002646 0292 0297D $208 003116 0307D $209 003153 0307 0310D $21 002133 0276D 0328 $24 004106 0322 0339 0347D $50 001460 0239 0253 0257D $51 001375 0253D $52 003556 0329 0334D $53 001647 0258 0265D $7001 003146 0308 0309D $7101 002640 0295 0296D $7121 000757 0231 0232D $802 000016 0187D 0189 $803 000053 0190D 0192 $804 000110 0193D 0195 $99 004674 0228 0318 0368D $9902 000161 0199 0200D 0000 ERRORS [<.MAIN.>FTN-REV18.2] SUBROUTINE ASTOR(IOB,NO,A,W,WX,ICA,NP,ICP,SPX,NOR,NR,NP2R, LT (0377) SUBROUTINE ASTOR(IOB,NO,A,W,WX,ICA,NP,ICP,SPX,NOR,NR,NP2R, (0378) 1 DOBR,NV) (0379) (0380) C STORE DESIGN MATRIX, MISCLOSURE VECTORS AND WEIGHTS ON PUNCH FILE (0381) (0382) IMPLICIT REAL*8 (A-H,O-Z) (0383) DIMENSION IOB(NOR,4),A(NOR,6),W(NOR),WX(NP2R),ICA(NOR,6),ICP(NR), (0384) 1 SPX(NP2R,NP2R),DOBR(NOR,4) (0385) (0386) NP2 = 2*NP (0387) WRITE(7,7201)NO,NP,NV,NP2 (0388) 7201 FORMAT(4I4) (0389) (0390) 1 DO 2 I=1,NO (0391) WRITE(7,7202)(IOB(I,J),J=1,4) (0392) WRITE(7,7203)(A(I,J),J=1,6) (0393) WRITE(7,7203)W(I) (0394) WRITE(7,7202)(ICA(I,J),J=1,6) (0395) WRITE(7,7203)(DOBR(I,J),J=1,4) (0396) 7202 FORMAT(I5) (0397) 7203 FORMAT(D20.13) (0398) 2 CONTINUE (0399) 7 IF(NP.LE.0) GOTO 8 (0400) 5 DO 6 I=1,NP2 (0401) WRITE(7,7202) ICP(I) (0402) 6 CONTINUE (0403) 3 DO 4 I=1,NP (0404) WRITE(7,7203)WX(I),(SPX(I,J),J=1,NP) (0405) 4 CONTINUE (0406) 8 CONTINUE (0407) RETURN (0408) END PROGRAM SIZE: PROCEDURE - 000562 LINKAGE - 000042 STACK - 000116 A D ARGUMENT 000050 0377S 0383S 0392 DOBR D ARGUMENT 000106 0377S 0383S 0395 I J LINKAGE 000434 0390M 0391 0392 0393 0394 0395 0400M 0401 0403M 0404 ICA J ARGUMENT 000061 0377S 0383S 0394 ICP J ARGUMENT 000067 0377S 0383S 0401 IOB J ARGUMENT 000042 0377S 0383S 0391 J J LINKAGE 000436 0391M 0392M 0394M 0395M 0404M NO J ARGUMENT 000045 0377S 0387 0390 NP J ARGUMENT 000064 0377S 0386 0387 0399 0403 0404 NP2 J LINKAGE 000424 0386M 0387 0400 NV J ARGUMENT 000111 0377S 0387 SPX D ARGUMENT 000072 0377S 0383S 0404 W D ARGUMENT 000053 0377S 0383S 0393 WX D ARGUMENT 000056 0377S 0383S 0404 $1 000052 0390D $2 000361 0390 0398D $3 000442 0403D $4 000536 0403 0405D $5 000376 0400D $6 000431 0400 0402D $7 000372 0399D $7201 000046 0387 0388D $7202 000351 0391 0394 0396D 0401 $7203 000354 0392 0393 0395 0397D 0404 $8 000547 0399 0406D 0000 ERRORS [FTN-REV18.2] (0409) $$$ SUBROUTINE ABSTR(CNAM,NSR,AP,RN,NR,IOB,NOR,NO,IC,NB,NS,NUNIT,NPROJABSTR0 (0001) SUBROUTINE ABSTR(CNAM,NSR,AP,RN,NR,IOB,NOR,NO,IC,NB,NS,NUNIT,NPROJ (0002) @,RKO,AA,BB,XO,YO,R1) (0003) C*********************************************************************** (0004) C* (0005) C* ABSTR PRINTS ABSTRACTS OF EACH FREE STATION UPON REQUEST IF A MAP PR (0006) C* JECTION IS BEING USED IN THE ADJUSTMENT. (0007) C* (0008) C* (0009) C* INPUT: (0010) C* -ALL DESCRIBED IN MAIN (0011) C* (0012) C* OUTPUT: (0013) C* PRINTED ABSTRACTS (SEE MANUAL FOR DESCRIPTION) (0014) C* (0015) C* (0016) C* WRITTEN BY: (0017) C* R.R. STEEVES, AUG., 1978 (0018) C* (0019) C*********************************************************************** (0020) IMPLICIT REAL*8(A-H,O-Z) (0021) LOGICAL DATE(18) (0022) DIMENSION CNAM(NSR),AP(NSR,12),RN(NR,NR),IOB(NOR,4),IC(NSR,3), (0023) @IVEC(50) (0024) DATA UF,UM/' FEET ',' METRES '/ (0025) U=UM (0026) IF(NUNIT.EQ.1)U=UF (0027) C CALL GDATE(DATE) (0028) NSTA=NS-NB (0029) PI=3.141592653589793D0 (0030) DO 1 I=1,NSTA (0031) IF(IC(I,1).EQ.0)GOTO1 (0032) WRITE(6 ,101)CNAM(I),DATE (0033) CALL RADMS(AP(I,9),IDP,IMP,SP) (0034) CALL RADMS(AP(I,10),IDL,IML,SL) (0035) CALL RADMS(AP(I,12),IDC,IMC,SC) (0036) WRITE(6 ,102)AP(I,1),U,IDP,IMP,SP (0037) WRITE(6 ,103)AP(I,2),U,IDL,IML,SL (0038) CX1=RN(IC(I,1),IC(I,1)) (0039) CX2=RN(IC(I,1),IC(I,2)) (0040) WRITE(6 ,104)AP(I,3),U,AP(I,4),U,CX1,CX2 (0041) CX1=CX2 (0042) CX2=RN(IC(I,2),IC(I,2)) (0043) WRITE(6 ,105)AP(I,5),AP(I,6),CX1,CX2 (0044) WRITE(6 ,106)IDC,IMC,SC,AP(I,11) (0045) WRITE(6 ,107) (0046) CALL SIGST(IOB,I,IVEC,NSS,NOR,NO) (0047) DO 2 JJ=1,NSS (0048) J=IVEC(JJ) (0049) GAZ=DATAN2(AP(J,1)-AP(I,1),AP(J,2)-AP(I,2)) (0050) IF(GAZ.LT.0)GAZ=GAZ+2.D0*PI (0051) CALL RADMS(GAZ,IDA,IMA,SA) (0052) SIJ=DSQRT((AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2) (0053) IF(NPROJ.LT.3)CALL TKSTER(I,J,AP,NSR,R1,XO,YO,RKO,TT,S) (0054) IF(NPROJ.GT.3)CALL TKTM(I,J,AP,NSR,RKO,AA,BB,XO,TT,S) (0055) CALL RADMS(TT,IDT,IMT,ST) (0056) WRITE(6 ,108)CNAM(I),CNAM(J),IDA,IMA,SA,SIJ,IDT,IMT,ST,S (0057) 2 CONTINUE (0058) 1 CONTINUE (0059) 101 FORMAT('1',8X,'ABSTRACT FOR STATION:',5X,A8,2X,'(AS DETERMINED BY (0060) @PROGRAM GEOPAN ON ',18A1,')',/,' ',8X,91('-'),//) (0061) 102 FORMAT(' ','EASTING (X) :',F14.3,A8,6X,'LATITUDE :',I5,I4,F10.5, (0062) @ 4X,'|',/,' ',76X,'|') (0063) 103 FORMAT(' ','NORTHING (Y) :',F14.3,A8,6X,'LONGITUDE :',I5,I4,F10.5, (0064) @ 4X,'|',8X,'COVARIANCE MATRIX',/,' ',76X,'|',6X,'--X--',11X,'--Y-- (0065) @') (0066) 104 FORMAT(' ','ORTHOMETRIC HEIGHT :',F13.3,A8,';GEOIDAL HEIGHT :', (0067) @ F10.3,A8,'|',1X,D15.8,1X,D15.8,/,' ',76X,'|') (0068) 105 FORMAT(' ','DEFLECTION COMPONENTS :',F8.1,' SECONDS (NORTH);',F8.1 (0069) @,' SECONDS (EAST)',5X,'|',1X,D15.8,1X,D15.8,/,' ',76X,'|') (0070) 106 FORMAT(' ','MERIDIAN CONVERGENCE :',I5,I4,F7.2,' ; POINT SCALE F (0071) @ACTOR :',F11.7,2X,'|',//) (0072) 107 FORMAT(' ',13X,'FROM',6X,'TO',11X,'GRID AZIMUTH',5X,'GRID DISTANCE (0073) @',4X,'ARC TO CHORD',4X,'LINE SCALE',/) (0074) 108 FORMAT(' ',13X,2(A8,2X),I5,I4,F7.2,2X,F12.3,5X,I3,I4,F7.2,F14.7,/) (0075) RETURN (0076) END PROGRAM SIZE: PROCEDURE - 002316 LINKAGE - 000372 STACK - 000154 AA D ARGUMENT 000114 0001S 0054A AP D ARGUMENT 000050 0001S 0022S 0033A 0034A 0035A 0036 0037 0040 0043 0044 0049 0052 0053A 0054A BB D ARGUMENT 000117 0001S 0054A CNAM D ARGUMENT 000042 0001S 0022S 0032 0056 CX1 D LINKAGE 000702 0038M 0040 0041M 0043 CX2 D LINKAGE 000706 0039M 0040 0041 0042M 0043 DATAN2 D EXTERNAL 000000 0049 DATE L LINKAGE 000434 0021S 0032 DSQR$X D EXTERNAL 000000 0056 DSQRT D EXTERNAL 000000 0052 GAZ D LINKAGE 000724 0049M 0050M 0051A I J LINKAGE 000634 0030M 0031 0032 0033 0034 0035 0036 0037 0038 0039 0040 0042 0043 0044 0046A 0049 0052 0053A 0054A 0056 IC J ARGUMENT 000072 0001S 0022S 0031 0038 0039 0042 IDA J LINKAGE 000730 0051A 0056 IDC J LINKAGE 000670 0035A 0044 IDL J LINKAGE 000660 0034A 0037 IDP J LINKAGE 000650 0033A 0036 IDT J LINKAGE 000762 0055A 0056 IMA J LINKAGE 000732 0051A 0056 IMC J LINKAGE 000672 0035A 0044 IML J LINKAGE 000662 0034A 0037 IMP J LINKAGE 000652 0033A 0036 IMT J LINKAGE 000764 0055A 0056 IOB J ARGUMENT 000061 0001S 0022S 0046A IVEC J LINKAGE 000456 0022S 0046A 0048 J J LINKAGE 000720 0048M 0049 0052 0053A 0054A 0056 JJ J LINKAGE 000716 0047M 0048 NB J ARGUMENT 000075 0001S 0028 NO J ARGUMENT 000067 0001S 0046A NOR J ARGUMENT 000064 0001S 0022S 0046A NPROJ J ARGUMENT 000106 0001S 0053 0054 NS J ARGUMENT 000100 0001S 0028 NSR J ARGUMENT 000045 0001S 0022S 0053A 0054A NSS J LINKAGE 000714 0046A 0047 NSTA J LINKAGE 000626 0028M 0030 NUNIT J ARGUMENT 000103 0001S 0026 PI D LINKAGE 000630 0029M 0050 R1 D ARGUMENT 000130 0001S 0053A RADMS D EXTERNAL 000000 0033 0034 0035 0051 0055 RKO D ARGUMENT 000111 0001S 0053A 0054A RN D ARGUMENT 000053 0001S 0022S 0038 0039 0042 S D LINKAGE 000754 0053A 0054A 0056 SA D LINKAGE 000734 0051A 0056 SC D LINKAGE 000674 0035A 0044 SIGST D EXTERNAL 000000 0046 SIJ D LINKAGE 000742 0052M 0056 SL D LINKAGE 000664 0034A 0037 SP D LINKAGE 000654 0033A 0036 ST D LINKAGE 000766 0055A 0056 TKSTER D EXTERNAL 000000 0053 TKTM D EXTERNAL 000000 0054 TT D LINKAGE 000750 0053A 0054A 0055A U D LINKAGE 000622 0025M 0026M 0036 0037 0040 UF D LINKAGE 000424 0024I 0026 UM D LINKAGE 000430 0024I 0025 XO D ARGUMENT 000122 0001S 0053A 0054A YO D ARGUMENT 000125 0001S 0053A $1 001434 0030 0031 0058D $101 001445 0032 0059D $102 001535 0036 0061D $103 001607 0037 0063D $104 001710 0040 0066D $105 001774 0043 0068D $106 002070 0044 0070D $107 002144 0045 0072D $108 002226 0056 0074D $2 001423 0047 0057D 0000 ERRORS [FTN-REV18.2] SUBROUTINE ANGL(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, ANGL00 (0077) SUBROUTINE ANGL(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, (0078) @ ITER,W,NOR,NSR,NR,CNAM,DOBR) (0079) C*********************************************************************** (0080) C* (0081) C* ANGL COMPUTES OBSERVATION EQUATION COEFFICIENTS FOR AN ANGLE OB- (0082) C* SERVATION. IT ALSO ADDS CONTRIBUTIONS OF ANGLE OBSERVATION TO NORMAL (0083) C* EQUATIONS AND CONSTANT VECTOR. - PRINTS ANGLE MISCLOSURES ON ZEROTH (0084) C* ITERATION. (0085) C* (0086) C* (0087) C* INPUT: (0088) C* - ALL DESCRIBED IN MAIN (0089) C* (0090) C* OUTPUT: (0091) C* - ALL DESCRIBED IN MAIN. (0092) C* (0093) C* (0094) C* WRITTEN BY: (0095) C* R.R. STEEVES, MAY, 1976 (0096) C* (0097) C*********************************************************************** (0098) IMPLICIT REAL*8(A-H,O-Z) (0099) DIMENSION IOB(NOR,4),DOB(NOR,4), A(NOR,6),RU(N),ICA(NOR, (0100) @6),IB(N),RN(NR,NR) ,W(NO),CNAM(NSR),AP(NSR,12),DOBR(NOR,4) (0101) DIST(XI,YI,XJ,YJ)=DSQRT((XJ-XI)**2+(YJ-YI)**2) (0102) PI=3.141592653589793D0 (0103) RO=3600.D0*180.D0/PI (0104) IFR=IOB(I,2) (0105) ITO1=IOB(I,3) (0106) ITO2=IOB(I,4) (0107) SIJ=DIST(AP(IFR,1),AP(IFR,2),AP(ITO1,1),AP(ITO1,2)) (0108) SIK=DIST(AP(IFR,1),AP(IFR,2),AP(ITO2,1),AP(ITO2,2)) (0109) C COMPUTE DESIGN MATRIX ELEMENTS (0110) A(I,3)=(AP(IFR,2)-AP(ITO1,2))/SIJ**2*RO (0111) A(I,4)=(AP(ITO1,1)-AP(IFR,1))/SIJ**2*RO (0112) A(I,5)=(AP(ITO2,2)-AP(IFR,2))/SIK**2*RO (0113) A(I,6)=(AP(IFR,1)-AP(ITO2,1))/SIK**2*RO (0114) A(I,1)=-A(I,3)-A(I,5) (0115) A(I,2)=-A(I,4)-A(I,6) (0116) C COMPUTE WEIGHT (0117) P=1.D0/DOBR(I,1)**2 (0118) C ADD CONTRIBUTION TO NORMAL EQUATIONS (0119) CALL NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) (0120) IF(NCODE.EQ.1)GOTO2 (0121) C COMPUTE MISCLOSURE IF ADJUSTMENT REQUESTED (0122) AL=DATAN2(AP(ITO2,1)-AP(IFR,1),AP(ITO2,2)-AP(IFR,2)) (0123) IF(AL.LT.0.0D0)AL=AL+2.0D0*PI (0124) AL1=DATAN2(AP(ITO1,1)-AP(IFR,1),AP(ITO1,2)-AP(IFR,2)) (0125) IF(AL1.LT.0.0D0)AL1=AL1+2.0D0*PI (0126) AL=AL-AL1 (0127) DOB1=(DOB(I,2)+DOB(I,3)/60.D0+DOB(I,4)/3600.D0)*PI/180.D0 (0128) IF(AL.GE.0.0D0)GOTO1 (0129) AL=AL+2.0D0*PI (0130) IF((AL-DOB1).GT.DOB1)AL=AL-2.0D0*PI (0131) 1 W(I)=(AL-DOB1)*RO (0132) C ADD CONTRIBUTION TO CONSTANT VECTOR (0133) CALL WVEC(ICA,A,RU,W(I),P,N,NO,I,NOR) (0134) C PRINT OBSERVATION INFORMATION AND MISCLOSURE IF ADJUSTMENT REQUESTED (0135) 2 IF(ITER.GT.0)GOTO4 (0136) STD=DOBR(I,1) (0137) IF(NCODE.EQ.1)GOTO3 (0138) IDG=DOB(I,2) (0139) IMN=DOB(I,3) (0140) IDEG=DOBR(I,2) (0141) IMIN=DOBR(I,3) (0142) SEC=DOBR(I,4) (0143) WRITE(6 , 101)CNAM(IFR),CNAM(ITO1),CNAM(ITO2),IDEG,IMIN,SEC ,S (0144) @,IMN,DOB(I,4) ,W(I) (0145) 101 FORMAT(' ',7X,'ANGLE',9X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2,I6,I3, (0146) @F6.2 ,F12.2,/) (0147) GOTO4 (0148) 3 WRITE(6 , 102)CNAM(IFR),CNAM(ITO1),CNAM(ITO2), STD (0149) 102 FORMAT(' ',27X,'ANGLE',10X,A8,3X,A8,3X,A8,F9.2,/) (0150) 4 I=I+1 (0151) RETURN (0152) END PROGRAM SIZE: PROCEDURE - 002070 LINKAGE - 000136 STACK - 000212 A D ARGUMENT 000063 0077S 0099S 0110M 0111M 0112M 0113M 0114M 0115M 0119A 0133A AL D LINKAGE 000464 0122M 0123M 0126M 0128 0129M 0130M 0131 AL1 D LINKAGE 000470 0124M 0125M 0126 AP D ARGUMENT 000060 0077S 0099S 0107A 0108A 0110 0111 0112 0113 0122 0124 CNAM D ARGUMENT 000132 0077S 0099S 0143 0148 DATAN2 D EXTERNAL 000000 0122 0124 DIST D 000000 0101S 0107 0108 DOB D ARGUMENT 000055 0077S 0099S 0127 0138 0139 0143 DOB1 D LINKAGE 000474 0127M 0130 0131 DOBR D ARGUMENT 000135 0077S 0099S 0117 0136 0140 0141 0142 DSQR$X D EXTERNAL 000000 0101 DSQRT D EXTERNAL 000000 0101 I J ARGUMENT 000047 0077S 0104 0105 0106 0110 0111 0112 0113 0114 0115 0117 0119A 0127 0131 0133A 0136 0138 0139 0140 0141 0142 0143 0150M IB J ARGUMENT 000074 0077S 0099S 0119A ICA J ARGUMENT 000071 0077S 0099S 0119A 0133A IDEG J LINKAGE 000512 0140M 0143 IDG J LINKAGE 000506 0138M IFR J LINKAGE 000436 0104M 0107 0108 0110 0111 0112 0113 0122 0124 0143 0148 IMIN J LINKAGE 000514 0141M 0143 IMN J LINKAGE 000510 0139M 0143 IOB J ARGUMENT 000052 0077S 0099S 0104 0105 0106 ITER J ARGUMENT 000113 0077S 0135 ITO1 J LINKAGE 000440 0105M 0107 0110 0111 0124 0143 0148 ITO2 J LINKAGE 000442 0106M 0108 0112 0113 0122 0143 0148 N J ARGUMENT 000102 0077S 0099S 0119A 0133A NCODE J ARGUMENT 000044 0077S 0120 0137 NO J ARGUMENT 000105 0077S 0099S 0119A 0133A NOR J ARGUMENT 000121 0077S 0099S 0119A 0133A NORM J EXTERNAL 000000 0119 NR J ARGUMENT 000127 0077S 0099S 0119A P D LINKAGE 000454 0117M 0119A 0133A PI D LINKAGE 000426 0102M 0103 0123 0125 0127 0129 0130 RN D ARGUMENT 000077 0077S 0099S 0119A RO D LINKAGE 000432 0103M 0110 0111 0112 0113 0131 RU D ARGUMENT 000066 0077S 0099S 0133A S D LINKAGE 000530 0143 SEC D LINKAGE 000516 0142M 0143 SIJ D LINKAGE 000444 0107M 0110 0111 SIK D LINKAGE 000450 0108M 0112 0113 STD D LINKAGE 000502 0136M 0148 W D ARGUMENT 000116 0077S 0099S 0131M 0133A 0143 WVEC D EXTERNAL 000000 0133 XI D 000000 0101 XJ D 000000 0101 YI D 000000 0101 YJ D 000000 0101 $1 001224 0128 0131D $101 001623 0143 0145D $102 001763 0148 0149D $2 001271 0120 0135D $3 001670 0137 0148D $4 002012 0135 0147 0150D 0000 ERRORS [FTN-REV18.2] SUBROUTINE ASAZ(AP,I,J,GAZ,NSR) ASAZ00 (0153) SUBROUTINE ASAZ(AP,I,J,GAZ,NSR) (0154) C*********************************************************************** (0155) C* (0156) C* ASAZ COMPUTES THE APPROXIMATE GEODETIC AZIMUTH OF LINE I TO J FOR US (0157) C* REDUCTION OF OBSERVATIONS TO ELLIPSOID (0158) C* (0159) C* (0160) C* INPUT: (0161) C* AP - DESCRIBED IN MAIN (0162) C* I - SEQUENCE NUMBER OF FIRST STATION (0163) C* J - SEQUENCE NUMBER OF SECOND STATION (0164) C* NSR - DESCRIBED IN MAIN (0165) C* (0166) C* OUTPUT: (0167) C* GAZ - COMPUTED APPROXIMATE GEODETIC AZIMUTH OF LINE I TO J (RA (0168) C* (0169) C* (0170) C* WRITTEN BY: (0171) C* R.R. STEEVES, JUNE, 1978 (0172) C* (0173) C*********************************************************************** (0174) IMPLICIT REAL*8(A-H,O-Z) (0175) DIMENSION AP(NSR,12) (0176) GAZ=DATAN2(AP(J,1)-AP(I,1),AP(J,2)-AP(I,2)) (0177) PI=3.141592653589793D0 (0178) IF(GAZ.LT.0.D0)GAZ=GAZ+2.D0*PI (0179) RO=3600.D0*180.D0/PI (0180) GAZ=GAZ+AP(I,12) (0181) IF(GAZ.LT.0.D0)GAZ=GAZ+2.D0*PI (0182) RETURN (0183) END PROGRAM SIZE: PROCEDURE - 000202 LINKAGE - 000032 STACK - 000102 AP D ARGUMENT 000042 0153S 0175S 0176 0180 DATAN2 D EXTERNAL 000000 0176 GAZ D ARGUMENT 000053 0153S 0176M 0178M 0180M 0181M I J ARGUMENT 000045 0153S 0176 0180 J J ARGUMENT 000050 0153S 0176 PI D LINKAGE 000422 0177M 0178 0179 0181 RO D LINKAGE 000426 0179M 0000 ERRORS [FTN-REV18.2] SUBROUTINE AZIM(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, AZIM00 (0184) SUBROUTINE AZIM(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, (0185) @ITER,W,NOR,NSR,NR,CNAM,DOBR) (0186) C*********************************************************************** (0187) C* (0188) C* AZIM COMPUTES THE CONTRIBUTION OF AZIMUTH OBSERVATIONS TO THE NORMAL (0189) C* EQUATIONS AND CONSTANT VECTOR. (0190) C* (0191) C* (0192) C* INPUT: (0193) C* -ALL DESCRIBED IN MAIN (0194) C* (0195) C* (0196) C* WRITTEN BY: (0197) C* R.R. STEEVES, JUNE, 1976 (0198) C* (0199) C*********************************************************************** (0200) IMPLICIT REAL*8(A-H,O-Z) (0201) DIMENSION IOB(NOR,4),DOB(NOR,4),AP(NSR,12),A(NOR,6),RU(N), (0202) @ ICA(NOR,6),IB(N),RN(NR,NR) ,W(NO),CNAM(NSR),DOBR(NOR,4) (0203) DIST(XI,YI,XJ,YJ)=DSQRT((XJ-XI)**2+(YJ-YI)**2) (0204) PI=3.141592653589793D0 (0205) RO=3600.0D0*180.D0/PI (0206) IFR=IOB(I,2) (0207) ITO=IOB(I,3) (0208) SIJ=DIST(AP(IFR,1),AP(IFR,2),AP(ITO,1),AP(ITO,2)) (0209) A(I,1)=(AP(IFR,2)-AP(ITO,2))/SIJ**2*RO (0210) A(I,2)=(AP(ITO,1)-AP(IFR,1))/SIJ**2*RO (0211) A(I,3)=-A(I,1) (0212) A(I,4)=-A(I,2) (0213) A(I,5)=0.D0 (0214) A(I,6)=0.D0 (0215) P=1.D0/DOBR(I,1)**2 (0216) CALL NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) (0217) IF(NCODE.EQ.1.AND.ITER.EQ.1)GOTO2 (0218) IF(NCODE.EQ.1)GOTO1 (0219) AL=DATAN2(AP(ITO,1)-AP(IFR,1),AP(ITO,2)-AP(IFR,2)) (0220) IF(AL.LT.0.D0)AL=AL+2.D0*PI (0221) W(I)=AL-(DOB(I,2)+DOB(I,3)/60.D0+DOB(I,4)/3600.D0)*PI/180.D0 (0222) W(I)=W(I)*RO (0223) CALL WVEC(ICA,A,RU,W(I),P,N,NO,I,NOR) (0224) IF(ITER.GT.0)GOTO2 (0225) IF(NCODE.EQ.1)GOTO1 (0226) IDG=DOB(I,2) (0227) IMN=DOB(I,3) (0228) IDEG=DOBR(I,2) (0229) IMIN=DOBR(I,3) (0230) SEC=DOBR(I,4) (0231) WRITE(6 , 101)CNAM(IFR),CNAM(IFR),CNAM(ITO),IDEG,IMIN,SEC,DOBR(I (0232) 1,1), (0233) @ IDG ,IMN , DOB(I,4) ,W(I) (0234) 101 FORMAT(' ',7X,'AZIMUTH',7X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2,I6,I3, (0235) @ F6.2 ,F12.2,/) (0236) GOTO2 (0237) 1 WRITE(6 , 102)CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(I,1) (0238) 102 FORMAT(' ',27X,'AZIMUTH',8X,A8,3X,A8,3X,A8,F9.2,/) (0239) 2 I=I+1 (0240) RETURN (0241) END PROGRAM SIZE: PROCEDURE - 001556 LINKAGE - 000110 STACK - 000212 A D ARGUMENT 000065 0184S 0201S 0209M 0210M 0211M 0212M 0213M 0214M 0216A 0223A AL D LINKAGE 000456 0219M 0220M 0221 AP D ARGUMENT 000062 0184S 0201S 0208A 0209 0210 0219 CNAM D ARGUMENT 000134 0184S 0201S 0231 0237 DATAN2 D EXTERNAL 000000 0219 DIST D 000000 0203S 0208 DOB D ARGUMENT 000057 0184S 0201S 0221 0226 0227 0231 DOBR D ARGUMENT 000137 0184S 0201S 0215 0228 0229 0230 0231 0237 DSQR$X D EXTERNAL 000000 0203 DSQRT D EXTERNAL 000000 0203 I J ARGUMENT 000051 0184S 0206 0207 0209 0210 0211 0212 0213 0214 0215 0216A 0221 0222 0223A 0226 0227 0228 0229 0230 0231 0237 0239M IB J ARGUMENT 000076 0184S 0201S 0216A ICA J ARGUMENT 000073 0184S 0201S 0216A 0223A IDEG J LINKAGE 000470 0228M 0231 IDG J LINKAGE 000464 0226M 0231 IFR J LINKAGE 000436 0206M 0208 0209 0210 0219 0231 0237 IMIN J LINKAGE 000472 0229M 0231 IMN J LINKAGE 000466 0227M 0231 IOB J ARGUMENT 000054 0184S 0201S 0206 0207 ITER J ARGUMENT 000115 0184S 0217 0224 ITO J LINKAGE 000440 0207M 0208 0209 0210 0219 0231 0237 N J ARGUMENT 000104 0184S 0201S 0216A 0223A NCODE J ARGUMENT 000046 0184S 0217 0218 0225 NO J ARGUMENT 000107 0184S 0201S 0216A 0223A NOR J ARGUMENT 000123 0184S 0201S 0216A 0223A NORM J EXTERNAL 000000 0216 NR J ARGUMENT 000131 0184S 0201S 0216A P D LINKAGE 000446 0215M 0216A 0223A PI D LINKAGE 000426 0204M 0205 0220 0221 RN D ARGUMENT 000101 0184S 0201S 0216A RO D LINKAGE 000432 0205M 0209 0210 0222 RU D ARGUMENT 000070 0184S 0201S 0223A SEC D LINKAGE 000474 0230M 0231 SIJ D LINKAGE 000442 0208M 0209 0210 W D ARGUMENT 000120 0184S 0201S 0221M 0222M 0223A 0231 WVEC D EXTERNAL 000000 0223 XI D 000000 0203 XJ D 000000 0203 YI D 000000 0203 YJ D 000000 0203 $1 001342 0218 0225 0237D $101 001274 0231 0234D $102 001446 0237 0238D $2 001475 0217 0224 0236 0239D 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE CENERR(IOB,DOBR,NOR,AP,NSR,CENT,NO) CENERR (0001) SUBROUTINE CENERR(IOB,DOBR,NOR,AP,NSR,CENT,NO) (0002) C*********************************************************************** (0003) C* (0004) C* CENERR ADDS CONTRIBUTION OF CENTERING ERRORS (IF SPECIFIED) TO STAND (0005) C* DEVIATIONS OF OBSERVATIONS. (0006) C* (0007) C* (0008) C* INPUT: (0009) C* -ALL DESCRIBED IN MAIN (0010) C* (0011) C* OUTPUT: (0012) C* -ALL DESCRIBED IN MAIN (0013) C* (0014) C* (0015) C* WRITTEN BY: (0016) C* R.R. STEEVES, AUG., 1978 (0017) C* (0018) C*********************************************************************** (0019) IMPLICIT REAL*8(A-H,O-Z) (0020) DIMENSION AP(NSR,12),IOB(NOR,4),DOBR(NOR,4),CENT(4) (0021) RO=3600.D0*180.D0/3.141592653589793D0 (0022) DO 4 I=1,NO (0023) IA=IOB(I,2) (0024) IF=IOB(I,3) (0025) IT=IOB(I,4) (0026) SIJ=DSQRT((AP(IF,1)-AP(IA,1))**2+(AP(IF,2)-AP(IA,2))**2) (0027) IG=IABS(IOB(I,1)) (0028) GOTO(1,2,3,2),IG (0029) 1 DOBR(I,1)=DSQRT(DOBR(I,1)**2+2.D0*CENT(1)**2) (0030) GOTO4 (0031) 2 DOBR(I,1)=DSQRT(DOBR(I,1)**2+2.D0*(RO*CENT(IG)/SIJ)**2) (0032) GOTO4 (0033) 3 SIK=DSQRT((AP(IT,1)-AP(IA,1))**2+(AP(IT,2)-AP(IA,2))**2) (0034) DOBR(I,1)=DSQRT(DOBR(I,1)**2+2.D0*(RO*CENT(3)/SIJ)**2+ (0035) @ 2.D0*(RO*CENT(3)/SIK)**2) (0036) 4 CONTINUE (0037) RETURN (0038) END PROGRAM SIZE: PROCEDURE - 000576 LINKAGE - 000050 STACK - 000110 AP D ARGUMENT 000053 0001S 0020S 0026 0033 CENT D ARGUMENT 000061 0001S 0020S 0029 0031 0034 DOBR D ARGUMENT 000045 0001S 0020S 0029M 0031M 0034M DSQR$X D EXTERNAL 000000 0029 0031 0033 0036 DSQRT D EXTERNAL 000000 0026 0029 0031 0033 0034 I J LINKAGE 000424 0022M 0023 0024 0025 0027 0029 0031 0034 IA J LINKAGE 000426 0023M 0026 0033 IABS J EXTERNAL 000000 0027 IF J LINKAGE 000430 0024M 0026 IG J LINKAGE 000442 0027M 0028 0031 IOB J ARGUMENT 000042 0001S 0020S 0023 0024 0025 0027 IT J LINKAGE 000432 0025M 0033 NO J ARGUMENT 000064 0001S 0022 RO D LINKAGE 000420 0021M 0031 0034 SIJ D LINKAGE 000436 0026M 0031 0034 SIK D LINKAGE 000444 0033M 0034 $1 000225 0028 0029D $2 000265 0028 0031D $3 000344 0028 0033D $4 000543 0022 0030 0032 0036D 0000 ERRORS [FTN-REV18.2] SUBROUTINE CHEK(N,NP,NB,NF,CNF,NFR,CPX,NPR,CBH,NBR,NO,N1,N2,N3,N4,CHEK00 (0039) SUBROUTINE CHEK(N,NP,NB,NF,CNF,NFR,CPX,NPR,CBH,NBR,NO,N1,N2,N3,N4, (0040) @ NZERO,ND,IDF,LSTOP,NS,N3DIM,NH,NUH,NHF) (0041) C*********************************************************************** (0042) C* (0043) C* CHEK CHECKS THAT ANY STATION WHICH IS FIXED, WEIGHTED OR HAS BLAHA (0044) C* INFORMATION HAS ONLY ONE OF THESE OPTIONS. ALSO CHECKS FOR NEGATIVE (0045) C* DEGREES OF FREEDOM. (0046) C* (0047) C* (0048) C* INPUT: (0049) C* -ALL DESCRIBED IN MAIN (0050) C* (0051) C* OUTPUT: (0052) C* -ALL DESCRIBED IN MAIN (0053) C* (0054) C* (0055) C* WRITTEN BY: (0056) C* R.R. STEEVES, JULY, 1978 (0057) C* (0058) C*********************************************************************** (0059) IMPLICIT REAL*8(A-H,O-Z) (0060) LOGICAL LSTOP (0061) DIMENSION CNF(NFR),CPX(NPR),CBH(NBR) (0062) IF(NP.EQ.0.OR.NF.EQ.0)GOTO3 (0063) DO 1 I=1,NF (0064) DO 1 J=1,NP (0065) IF(CNF(I).EQ.CPX(J))GOTO6 (0066) 1 CONTINUE (0067) 3 IF(NB.EQ.0.OR.NP.EQ.0)GOTO4 (0068) DO 2 I=1,NP (0069) DO 2 J=1,NB (0070) IF(CPX(I).EQ.CBH(J))GOTO7 (0071) 2 CONTINUE (0072) 4 IF(NF.EQ.0.OR.NB.EQ.0)GOTO20 (0073) DO 5 I=1,NF (0074) DO 5 J=1,NB (0075) IF(CNF(I).EQ.CBH(J))GOTO8 (0076) 5 CONTINUE (0077) GOTO20 (0078) 6 WRITE(6 ,101)CPX(J) (0079) WRITE(6 , 102) (0080) GOTO21 (0081) 7 WRITE(6 ,103)CPX(I) (0082) WRITE(6 ,102) (0083) GOTO21 (0084) 8 WRITE(6 ,104)CNF(I) (0085) WRITE(6 ,102) (0086) 20 NP2=NP*2 (0087) NN=N-NZERO (0088) NS1=N1+N2+N3+N4+NP2 (0089) NS2=NZERO+ND+NN (0090) NS3=NS1-NS2 (0091) NUH = 0 (0092) NH = 0 (0093) IF(N3DIM.EQ.2) NH = NS (0094) IF(N3DIM.NE.0) NUH = NS - NHF (0095) IDF=NO+NP*2+NH-N-ND (0096) IF(IDF.GE.0)GOTO22 (0097) WRITE(6 ,105)IDF (0098) WRITE(6 ,106)N1,NZERO,N2,ND,N3,N4,NP2,NN,NS1,NS2,NS3 (0099) 21 LSTOP = .TRUE. (0100) 101 FORMAT(' ','*** INPUT ERROR #011 *** STATION ',A8,'IS BOTH FIXED A (0101) @ND WEIGHTED...') (0102) 102 FORMAT(' ','ONLY ONE OF THESE OPTIONS MAY BE CHOSEN FOR ANY ONE ST (0103) @ATION') (0104) 103 FORMAT(' ','*** INPUT ERROR #012 *** STATION ',A8,' IS BOTH WEIGHT (0105) @ED AND BLAHA HELD...') (0106) 104 FORMAT(' ','*** INPUT ERROR #013 *** STATION ',A8,' IS BOTH FIXED (0107) @AND BLAHA HELD...') (0108) 105 FORMAT(' ','*** INPUT ERROR #014 *** THE NUMBER OF DEGREES OF FREE (0109) @DOM IS ',I5,';MUST BE NON-NEGATIVE.') (0110) 106 FORMAT(' ',//,' ',3X,42('*'),/,' ',6X,'OBSERVATIONS',4X,'*',8X,'UN (0111) @KNOWNS',/,' ',3X,42('*'),/,' ',3X,'DISTANCES',I8,' * ZERO ERROR (0112) @',I9,/,' ',22X,'*',/,' ',3X,'DIRECTIONS',I7,' * ORIENTATION',I8 (0113) @,/,' ',22X,'*',/,' ',3X,'ANGLES',I11,' *',/,' ',22X,'*',/,' ',3X, (0114) @'AZIMUTHS',I9,' *',/,' ',22X,'*',/,' ',3X,'COORDINATES',I6,' * (0115) @ COORDINATES',I8,///,' ',3X,'TOTALS',I11,I25,3X,'-->',I10, (0116) @ 2X,'DEGREES OF FREEDOM',///) (0117) 22 RETURN (0118) END PROGRAM SIZE: PROCEDURE - 001542 LINKAGE - 000052 STACK - 000160 CBH D ARGUMENT 000074 0039S 0061S 0070 0075 CNF D ARGUMENT 000060 0039S 0061S 0065 0075 0084 CPX D ARGUMENT 000066 0039S 0061S 0065 0070 0078 0081 I J LINKAGE 000424 0063M 0065 0068M 0070 0073M 0075 0081 0084 IDF J ARGUMENT 000127 0039S 0095M 0096 0097 J J LINKAGE 000426 0064M 0065 0069M 0070 0074M 0075 0078 LSTOP L ARGUMENT 000132 0039S 0060S 0099M N J ARGUMENT 000044 0039S 0087 0095 N1 J ARGUMENT 000105 0039S 0088 0098 N2 J ARGUMENT 000110 0039S 0088 0098 N3 J ARGUMENT 000113 0039S 0088 0098 N3DIM J ARGUMENT 000140 0039S 0093 0094 N4 J ARGUMENT 000116 0039S 0088 0098 NB J ARGUMENT 000052 0039S 0067 0069 0072 0074 ND J ARGUMENT 000124 0039S 0089 0095 0098 NF J ARGUMENT 000055 0039S 0062 0063 0072 0073 NH J ARGUMENT 000143 0039S 0092M 0093M 0095 NHF J ARGUMENT 000151 0039S 0094 NN J LINKAGE 000440 0087M 0089 0098 NO J ARGUMENT 000102 0039S 0095 NP J ARGUMENT 000047 0039S 0062 0064 0067 0068 0086 0095 NP2 J LINKAGE 000436 0086M 0088 0098 NS J ARGUMENT 000135 0039S 0093 0094 NS1 J LINKAGE 000442 0088M 0090 0098 NS2 J LINKAGE 000444 0089M 0090 0098 NS3 J LINKAGE 000446 0090M 0098 NUH J ARGUMENT 000146 0039S 0091M 0094M NZERO J ARGUMENT 000121 0039S 0087 0089 0098 $1 000054 0063 0064 0066D $101 000700 0078 0100D $102 000747 0079 0082 0085 0102D $103 001012 0081 0104D $104 001064 0084 0106D $105 001135 0097 0108D $106 001217 0098 0110D $2 000151 0068 0069 0071D $20 000427 0072 0077 0086D $21 000675 0080 0083 0099D $22 001535 0096 0117D $3 000076 0062 0067D $4 000173 0067 0072D $5 000246 0073 0074 0076D $6 000270 0065 0078D $7 000330 0070 0081D $8 000370 0075 0084D 0000 ERRORS [FTN-REV18.2] SUBROUTINE CHKDEM(NS,NF,NFIX,NFR,NP,IPX,NPR,NB,IBH,NBR,NO,IOB,NOR,CHKDEM (0119) SUBROUTINE CHKDEM(NS,NF,NFIX,NFR,NP,IPX,NPR,NB,IBH,NBR,NO,IOB,NOR, (0120) @CNAM,NSR,N1,N4,LSTOP) (0121) C*********************************************************************** (0122) C* (0123) C* CHKDEM CHECKS THAT EACH FREE STATION IS AT LEAST UNIQUELY DETERMINED (0124) C* IF NOT PROGRAM EXECUTION IS TERMINATED. A WARNING IS GIVEN IF A STA (0125) C* IS DISCOVERED WHICH IS ONLY UNIQUELY DETERMINED. ALSO A CHECK IS MA (0126) C* TO ASSURE THAT FIXED, WEIGHTED OR BLAHA STATIONS ARE TIED TO THE NET (0127) C* WORK. (0128) C* (0129) C* (0130) C* INPUT: (0131) C* -ALL DESCRIBED IN MAIN (0132) C* (0133) C* OUTPUT: (0134) C* -ALL DESCRIBED IN MAIN (0135) C* (0136) C* (0137) C* WRITTEN BY: (0138) C* R.R. STEEVES, AUG., 1978 (0139) C* (0140) C*********************************************************************** (0141) IMPLICIT REAL*8(A-H,O-Z) (0142) LOGICAL LSTOP (0143) DIMENSION NFIX(NFR),IPX(NPR),IBH(NBR),IOB(NOR,4),CNAM(NSR) (0144) NPC=0 (0145) NSTOP=0 (0146) NSUM=(NF+NP+NB)*2 (0147) IF(NSUM.EQ.0)GOTO20 (0148) IF(NSUM.GT.4)GOTO30 (0149) IF(NSUM.EQ.2.AND.N1.GT.0.AND.N4.GT.0)GOTO10 (0150) IF(NSUM.GE.4)GOTO10 (0151) IF(NSUM.EQ.2.AND.N1.EQ.0.AND.N4.EQ.0)GOTO21 (0152) IF(NSUM.EQ.2.AND.N1.EQ.0)GOTO22 (0153) IF(NSUM.EQ.2.AND.N4.EQ.0)GOTO23 (0154) 10 DO 1 I=1,NS (0155) NDIR=0 (0156) NDIRT=0 (0157) NDIST=0 (0158) NAZM=0 (0159) NANG=0 (0160) IF(NF.EQ.0)GOTO2 (0161) DO 3 J=1,NF (0162) IF(I.EQ.NFIX(J))GOTO 1 (0163) 3 CONTINUE (0164) 2 IF(NP.EQ.0)GOTO4 (0165) DO 5 J=1,NP (0166) IF(I.EQ.IPX(J))GOTO 1 (0167) 5 CONTINUE (0168) 4 IF(NB.EQ.0)GOTO6 (0169) DO 7 J=1,NB (0170) IF(I.EQ.IBH(J))GOTO 1 (0171) 7 CONTINUE (0172) 6 DO 8 J=1,NO (0173) IG=IABS(IOB(J,1)) (0174) IA=IOB(J,2) (0175) IF=IOB(J,3) (0176) IT=IOB(J,4) (0177) GOTO(11,12,13,14),IG (0178) 11 IF(IA.EQ.I.OR.IF.EQ.I)NDIST=NDIST+1 (0179) GOTO9 (0180) 12 IF(IA.EQ.I)NDIR=NDIR+1 (0181) IF(IF.EQ.I)NDIRT=NDIRT+1 (0182) GOTO9 (0183) 13 IF(IA.EQ.I.OR.IF.EQ.I.OR.IT.EQ.I)NANG=NANG+1 (0184) GOTO9 (0185) 14 IF(IA.EQ.I.OR.IF.EQ.I)NAZM=NAZM+1 (0186) 9 NSUM=MAX0(NDIR-1,0)+NDIRT+NDIST+NAZM+NANG (0187) IF(NSUM.GT.2)GOTO1 (0188) 8 CONTINUE (0189) NPC=NPC+1 (0190) IF(NPC.EQ.1)WRITE(6 ,101) (0191) IF(NSUM.EQ.2)WRITE(6 ,102)CNAM(I) (0192) IF(NSUM.LT.2)WRITE(6 ,103)CNAM(I) (0193) IF(NSUM.LT.2)NSTOP=1 (0194) GOTO1 (0195) 24 NSUM=0 (0196) DO 25 J=1,NO (0197) IA=IOB(J,2) (0198) IF=IOB(J,3) (0199) IT=IOB(J,4) (0200) IF(I.EQ.IA.OR.I.EQ.IF.OR.I.EQ.IT)NSUM=NSUM+1 (0201) IF(NSUM.GE.1)GOTO1 (0202) 25 CONTINUE (0203) NSTOP=1 (0204) NPC=NPC+1 (0205) IF(NPC.EQ.1)WRITE(6 ,101) (0206) WRITE(6 ,104)CNAM(I) (0207) 1 CONTINUE (0208) GOTO90 (0209) 20 NSTOP=1 (0210) NPC=NPC+1 (0211) IF(NPC.EQ.1)WRITE(6 ,101) (0212) WRITE(6 ,105) (0213) GOTO10 (0214) 21 NSTOP=1 (0215) NPC=NPC+1 (0216) IF(NPC.EQ.1)WRITE(6 ,101) (0217) WRITE(6 ,106) (0218) GOTO10 (0219) 22 NSTOP=1 (0220) NPC=NPC+1 (0221) IF(NPC.EQ.1)WRITE(6 ,101) (0222) WRITE(6 ,107) (0223) GOTO10 (0224) 23 NSTOP=1 (0225) NPC=NPC+1 (0226) IF(NPC.EQ.1)WRITE(6 ,101) (0227) WRITE(6 ,108) (0228) GOTO10 (0229) 30 NPC=NPC+1 (0230) IF(NPC.EQ.1)WRITE(6 ,101) (0231) WRITE(6 ,109) (0232) GOTO10 (0233) 90 IF(NSTOP.EQ.1)LSTOP=.TRUE. (0234) 101 FORMAT('1') (0235) 102 FORMAT(' ','*** WARNING *** STATION ',A8,' IS ONLY UNIQUELY DETERM (0236) @INED.',/) (0237) 103 FORMAT(' ','*** INPUT ERROR #031 *** STATION ',A8,' IS NOT DETERM (0238) @INED; MORE OBSERVATIONS REQUIRED.') (0239) 104 FORMAT(' ','*** INPUT ERROR #032 FIXED WEIGHTED OR BLAHA STATION (0240) @',A8,' IS NOT PROPERLY TIED TO NETWORK:',/,' ',10X, (0241) @' MORE OBSERVATIONS ARE REQUIRED',/) (0242) 105 FORMAT(' ','*** INPUT ERROR #033 THERE IS NO POSITION CONSTRAINT: (0243) @ MUST BE AT LEAST 1 FIXED,WEIGHTED OR BLAHA STATION',/) (0244) 106 FORMAT(' ','*** INPUT ERROR #034 THERE ARE NO ORIENTATION OR SCAL (0245) @E CONSTRAINTS: ',/,' ','WITH ONLY 1 FIXED,WEIGHTED OR BLAHA STATIO (0246) @N BOTH A DISTANCE AND AN AZIMUTH OBSERVATION MUST BE GIVEN',/) (0247) 107 FORMAT(' ','*** INPUT ERROR #035 *** THERE IS NO SCALE CONSTRAINT: (0248) @',/,' ','WITH ONLY 1 FIXED,WEIGHTED OR BLAHA STATION, AT LEAST 1 D (0249) @ISTANCE OBSERVATION MUST BE GIVEN',/) (0250) 108 FORMAT(' ','*** INPUT ERROR #036 *** THERE IS NO ORIENTATION CONST (0251) @RAINT',/,' ','WITH ONLY 1 FIXED,WEIGHTED OR BLAHA STATION, AT LEAS (0252) @T ONE AZIMUTH OBSERVATION MUST BE GIVEN',/) (0253) 109 FORMAT(' ','*** WARNING *** MORE STATION CONSTRAINTS THAN THE MINI (0254) @MUM NECESSARY ARE BEING USED',/) (0255) RETURN (0256) END **** LINE 0256 [ END ] WARNING - $24 - NO PATH TO STMT PROGRAM SIZE: PROCEDURE - 002454 LINKAGE - 000066 STACK - 000136 CNAM D ARGUMENT 000115 0119S 0143S 0191 0192 0206 I J LINKAGE 000430 0154M 0162 0166 0170 0178 0180 0181 0183 0185 0191 0192 0200 0206 IA J LINKAGE 000450 0174M 0178 0180 0183 0185 0197M 0200 IABS J EXTERNAL 000000 0173 IBH J ARGUMENT 000076 0119S 0143S 0170 IF J LINKAGE 000452 0175M 0178 0181 0183 0185 0198M 0200 IG J LINKAGE 000446 0173M 0177 IOB J ARGUMENT 000107 0119S 0143S 0173 0174 0175 0176 0197 0198 0199 IPX J ARGUMENT 000065 0119S 0143S 0166 IT J LINKAGE 000454 0176M 0183 0199M 0200 J J LINKAGE 000444 0161M 0162 0165M 0166 0169M 0170 0172M 0173 0174 0175 0176 0196M 0197 0198 0199 LSTOP L ARGUMENT 000131 0119S 0142S 0233M MAX0 J EXTERNAL 000000 0186 N1 J ARGUMENT 000123 0119S 0149 0151 0152 N4 J ARGUMENT 000126 0119S 0149 0151 0153 NANG J LINKAGE 000442 0159M 0183M 0186 NAZM J LINKAGE 000440 0158M 0185M 0186 NB J ARGUMENT 000073 0119S 0146 0168 0169 NDIR J LINKAGE 000432 0155M 0180M 0186 NDIRT J LINKAGE 000434 0156M 0181M 0186 NDIST J LINKAGE 000436 0157M 0178M 0186 NF J ARGUMENT 000051 0119S 0146 0160 0161 NFIX J ARGUMENT 000054 0119S 0143S 0162 NO J ARGUMENT 000104 0119S 0172 0196 NP J ARGUMENT 000062 0119S 0146 0164 0165 NPC J LINKAGE 000422 0144M 0189M 0190 0204M 0205 0210M 0211 0215M 0216 0220M 0221 0225M 0226 0229M 0230 NS J ARGUMENT 000046 0119S 0154 NSTOP J LINKAGE 000424 0145M 0193M 0203M 0209M 0214M 0219M 0224M 0233 NSUM J LINKAGE 000426 0146M 0147 0148 0149 0150 0151 0152 0153 0186M 0187 0191 0192 0193 0195M 0200M 0201 $1 001140 0154 0162 0166 0170 0187 0194 0201 0207D $10 000101 0149 0150 0154D 0213 0218 0223 0228 0232 $101 001407 0190 0205 0211 0216 0221 0226 0230 0234D $102 001413 0191 0235D $103 001457 0192 0237D $104 001540 0206 0239D $105 001653 0212 0242D $106 001746 0217 0244D $107 002105 0222 0247D $108 002230 0227 0250D $109 002356 0231 0253D $11 000370 0177 0178D $12 000416 0177 0180D $13 000451 0177 0183D $14 000507 0177 0185D $2 000156 0160 0164D $20 001151 0147 0209D $21 001207 0151 0214D $22 001245 0152 0219D $23 001303 0153 0224D $24 000724 0195D $25 001053 0196 0202D $3 000145 0161 0163D $30 001341 0148 0229D $4 000214 0164 0168D $5 000203 0165 0167D $6 000252 0168 0172D $7 000241 0169 0171D $8 000562 0172 0188D $9 000534 0179 0182 0184 0186D $90 001375 0208 0233D 0000 ERRORS [FTN-REV18.2] 1 WARNING SUBROUTINE CHKDIV(ITER,X,NINC,CERR,NSR,NR,NB,NF,NS,CONVG) CHKDIV (0257) SUBROUTINE CHKDIV(ITER,X,NINC,CERR,NSR,NR,NB,NF,NS,CONVG) (0258) C*********************************************************************** (0259) C* (0260) C* CHKDIV CHECKS FOR SOLUTION DIVERGENCE BY DETERMINING IF THE ITERATIV (0261) C* CORRECTIONS INCREASE IN ABSOLUTE VALUE MORE THAN ONCE. THE PROGRAM (0262) C* TERMINATED IF DIVERGENCE IS DETECTED. (0263) C* (0264) C* (0265) C* INPUT: (0266) C* -ALL DESCRIBED IN MAIN (0267) C* (0268) C* OUTPUT: (0269) C* -ALL DESCRIBED IN MAIN (0270) C* (0271) C* (0272) C* WRITTEN BY: (0273) C* R.R. STEEVES, AUG., 1978 (0274) C* (0275) C*********************************************************************** (0276) IMPLICIT REAL*8(A-H,O-Z) (0277) DIMENSION CERR(NR),X(NR) (0278) NC=(NS-NB-NF)*2 (0279) IF(ITER.EQ.0)NINC=0 (0280) IF(ITER.GT.0)GOTO1 (0281) DO 2 I=1,NC (0282) 2 CERR(I)=DABS(X(I)) (0283) RETURN (0284) 1 DO 3 I=1,NC (0285) IF(CERR(I).LT.DABS(X(I)).AND.DABS(X(I)).GT.CONVG)GOTO4 (0286) 3 CONTINUE (0287) GOTO5 (0288) 4 NINC=NINC+1 (0289) IF(NINC.EQ.2)GOTO6 (0290) 5 DO 7 I=1,NC (0291) 7 CERR(I)=DABS(X(I)) (0292) RETURN (0293) 6 WRITE(6 ,101) (0294) 101 FORMAT(//,' ','*** ERROR #044 *** PROGRAM TERMINATED DUE TO SOLUT (0295) @ION DIVERGENCE ; CHECK INPUT DATA',/) (0296) STOP (0297) END PROGRAM SIZE: PROCEDURE - 000336 LINKAGE - 000036 STACK - 000106 CERR D ARGUMENT 000055 0257S 0277S 0282M 0285 0291M CONVG D ARGUMENT 000077 0257S 0285 DABS D EXTERNAL 000000 0282 0285 0291 I J LINKAGE 000424 0281M 0282 0284M 0285 0290M 0291 ITER J ARGUMENT 000044 0257S 0279 0280 NB J ARGUMENT 000066 0257S 0278 NC J LINKAGE 000422 0278M 0281 0284 0290 NF J ARGUMENT 000071 0257S 0278 NINC J ARGUMENT 000052 0257S 0279M 0288M 0289 NS J ARGUMENT 000074 0257S 0278 X D ARGUMENT 000047 0257S 0277S 0282A 0285A 0291A $1 000072 0280 0284D $101 000237 0293 0294D $2 000031 0281 0282D $3 000137 0284 0286D $4 000150 0285 0288D $5 000162 0287 0290D $6 000227 0289 0293D $7 000166 0290 0291D 0000 ERRORS [FTN-REV18.2] SUBROUTINE CHKMIS(W,NOR,NO,WANGC,WDISC,IOB,DOB,CNAM,NSR,NUNIT) CHKMIS (0298) SUBROUTINE CHKMIS(W,NOR,NO,WANGC,WDISC,IOB,DOB,CNAM,NSR,NUNIT) (0299) C*********************************************************************** (0300) C* (0301) C* CHKMIS CHECKS FOR LARGE MISCLOSURES ON ZEROTH ITERATION; IF ANY ARE (0302) C* TECTED THIS INFORMATION IS PRINTED AND THE PROGRAM IS TERMINATED. (0303) C* (0304) C* (0305) C* INPUT: (0306) C* -ALL DESCRIBED IN MAIN (0307) C* (0308) C* OUTPUT: (0309) C* -ALL DESCRIBED IN MAIN (0310) C* (0311) C* (0312) C* WRITTEN BY: (0313) C* R.R. STEEVES, AUG, 1978 (0314) C* (0315) C*********************************************************************** (0316) IMPLICIT REAL*8(A-H,O-Z) (0317) DIMENSION W(NOR),IOB(NOR,4),DOB(NOR,4),CNAM(NSR) (0318) DATA UM,UF/' METRES ',' FEET '/ (0319) U=UM (0320) IF(NUNIT.EQ.1)U=UF (0321) ICNT=0 (0322) DO 5 I=1,NO (0323) IG=IABS(IOB(I,1)) (0324) IA=IOB(I,2) (0325) IF=IOB(I,3) (0326) IT=IOB(I,4) (0327) GOTO(1,2,3,4),IG (0328) 1 IF(DABS(W(I)).LE.WDISC)GOTO5 (0329) IF(ICNT.EQ.0)WRITE(6 ,101)WDISC,U,WANGC (0330) ICNT=1 (0331) WRITE(6 ,102)CNAM(IA),CNAM(IA),CNAM(IF),DOB(I,3),W(I),U (0332) GOTO5 (0333) 2 IF(DABS(W(I)).LE.WANGC)GOTO5 (0334) IF(ICNT.EQ.0)WRITE(6 ,101)WDISC,U,WANGC (0335) ICNT=1 (0336) IDEG=DOB(I,2) (0337) IMIN=DOB(I,3) (0338) WRITE(6 ,103)CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,DOB(I,4),W(I) (0339) GOTO5 (0340) 3 IF(DABS(W(I)).LE.WANGC)GOTO5 (0341) IF(ICNT.EQ.0)WRITE(6 ,101)WDISC,U,WANGC (0342) ICNT=1 (0343) IDEG=DOB(I,2) (0344) IMIN=DOB(I,3) (0345) WRITE(6 ,104)CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN,DOB(I,4),W(I) (0346) GOTO5 (0347) 4 IF(DABS(W(I)).LE.WANGC)GOTO5 (0348) IF(ICNT.EQ.0)WRITE(6 ,101)WDISC,U,WANGC (0349) ICNT=1 (0350) IDEG=DOB(I,2) (0351) IMIN=DOB(I,3) (0352) WRITE(6 ,105)CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN,DOB(I,4),W(I) (0353) 5 CONTINUE (0354) IF(ICNT.EQ.1)STOP (0355) 101 FORMAT('1',16X,'PROGRAM EXECUTION WAS TERMINATED DUE TO THE FOLLOW (0356) @ING UNACCEPTABLE MISCLOSURES',/,' ',16X,78('-'),/,' ',17X,'(CRITER (0357) @IA: DISTANCE ->',F10.3,A8,'; ANGULAR ->',F10.1,' SECONDS)',//, (0358) @' ',20X,12X,'AT',8X,'FROM',6X,'TO',9X,'OBSERVATION',5X,'MISCLOSURE (0359) @',/) (0360) 102 FORMAT(' ',20X,'DISTANCE',4X,3(A8,2X),F11.3,4X,F11.3,A8,/) (0361) 103 FORMAT(' ',20X,'DIRECTION',3X,3(A8,2X),I4,I3,F5.1,2X,F11.1,2X,'SEC (0362) @ONDS',/) (0363) 104 FORMAT(' ',20X,'ANGLE',7X,3(A8,2X),I4,I3,F5.1,2X,F11.1,2X,'SECONDS (0364) @',/) (0365) 105 FORMAT(' ',20X,'AZIMUTH',5X,3(A8,2X),I4,I3,F5.1,2X,F11.1,2X,'SECON (0366) @DS',/) (0367) RETURN (0368) END PROGRAM SIZE: PROCEDURE - 002102 LINKAGE - 000074 STACK - 000102 CNAM D ARGUMENT 000067 0298S 0317S 0331 0338 0345 0352 DABS D EXTERNAL 000000 0328 0333 0340 0347 DOB D ARGUMENT 000064 0298S 0317S 0331 0336 0337 0338 0343 0344 0345 0350 0351 0352 I J LINKAGE 000442 0322M 0323 0324 0325 0326 0328 0331 0333 0336 0337 0338 0340 0343 0344 0345 0347 0350 0351 0352 IA J LINKAGE 000446 0324M 0331 0338 0345 0352 IABS J EXTERNAL 000000 0323 ICNT J LINKAGE 000440 0321M 0329 0330M 0334 0335M 0341 0342M 0348 0349M 0354 IDEG J LINKAGE 000464 0336M 0338 0343M 0345 0350M 0352 IF J LINKAGE 000450 0325M 0331 0338 0345 0352 IG J LINKAGE 000444 0323M 0327 IMIN J LINKAGE 000466 0337M 0338 0344M 0345 0351M 0352 IOB J ARGUMENT 000061 0298S 0317S 0323 0324 0325 0326 IT J LINKAGE 000452 0326M 0345 NO J ARGUMENT 000050 0298S 0322 NUNIT J ARGUMENT 000075 0298S 0320 U D LINKAGE 000434 0319M 0320M 0329 0331 0334 0341 0348 UF D LINKAGE 000430 0318I 0320 UM D LINKAGE 000424 0318I 0319 W D ARGUMENT 000042 0298S 0317S 0328A 0331 0333A 0338 0340A 0345 0347A 0352 WANGC D ARGUMENT 000053 0298S 0329 0333 0334 0340 0341 0347 0348 WDISC D ARGUMENT 000056 0298S 0328 0329 0334 0341 0348 $1 000141 0327 0328D $101 001465 0329 0334 0341 0348 0355D $102 001670 0331 0360D $103 001723 0338 0361D $104 001766 0345 0363D $105 002027 0352 0365D $2 000362 0327 0333D $3 000654 0327 0340D $4 001146 0327 0347D $5 001437 0322 0328 0332 0333 0339 0340 0346 0347 0353D 0000 ERRORS [FTN-REV18.2] SUBROUTINE CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,IM,NZERO,NZ,N3DIM) CODE00 (0369) SUBROUTINE CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,IM,NZERO,NZ,N3DIM) (0370) C*********************************************************************** (0371) C* (0372) C* CODE COMPUTES COLUMN CODES FOR THE DESIGN MATRIX A. (0373) C* (0374) C* (0375) C* INPUT: (0376) C* -ALL DESCRIBED IN MAIN (0377) C* (0378) C* (0379) C* WRITTEN BY: (0380) C* R.R. STEEVES, JUNE, 1978 (0381) C* (0382) C*********************************************************************** (0383) IMPLICIT REAL*8(A-H,O-Z) (0384) DIMENSION DOB(NOR,4),IOB(NOR,4),FAC(5),ICA(NOR,6),IC(NSR,3) (0385) DO 20 I=1,NO (0386) IF(IM.EQ.2)GOTO18 (0387) DOB(I,1)=DOB(I,1)*FAC(IABS(IOB(I,1))) (0388) IF(IOB(I,1).EQ.1) DOB(I,2)=DOB(I,2)*FAC(5) (0389) 18 ICA(I,1)=IC(IOB(I,2),1) (0390) ICA(I,2)=IC(IOB(I,2),2) (0391) ICA(I,3)=IC(IOB(I,3),1) (0392) ICA(I,4)=IC(IOB(I,3),2) (0393) IF(IOB(I,1).EQ.3)GOTO19 (0394) ICA(I,5)=0 (0395) IF(IOB(I,1).EQ.1.AND.NZERO.EQ.1)ICA(I,5)=NZ (0396) ICA(I,6)=0 (0397) C 3-DIM. ADJ. (0398) 31 IF(N3DIM.EQ.0) GOTO 32 (0399) ICA(I,5) = IC(IOB(I,2),3) (0400) ICA(I,6) = IC(IOB(I,3),3) (0401) 32 CONTINUE (0402) GOTO20 (0403) C ANGLES (0404) 19 ICA(I,5)=IC(IOB(I,4),1) (0405) ICA(I,6)=IC(IOB(I,4),2) (0406) 20 CONTINUE (0407) RETURN (0408) END PROGRAM SIZE: PROCEDURE - 000676 LINKAGE - 000022 STACK - 000122 DOB D ARGUMENT 000047 0369S 0384S 0387M 0388M FAC D ARGUMENT 000055 0369S 0384S 0387 0388 I J LINKAGE 000420 0385M 0387 0388 0389 0390 0391 0392 0393 0394 0395 0396 0399 0400 0404 0405 IABS J EXTERNAL 000000 0387 IC J ARGUMENT 000063 0369S 0384S 0389 0390 0391 0392 0399 0400 0404 0405 ICA J ARGUMENT 000060 0369S 0384S 0389M 0390M 0391M 0392M 0394M 0395M 0396M 0399M 0400M 0404M 0405M IM J ARGUMENT 000074 0369S 0386 IOB J ARGUMENT 000052 0369S 0384S 0387 0388 0389 0390 0391 0392 0393 0395 0399 0400 0404 0405 N3DIM J ARGUMENT 000105 0369S 0398 NO J ARGUMENT 000044 0369S 0385 NZ J ARGUMENT 000102 0369S 0395 NZERO J ARGUMENT 000077 0369S 0395 $18 000114 0386 0389D $19 000541 0393 0404D $20 000645 0385 0402 0406D $31 000412 0398D $32 000540 0398 0401D 0000 ERRORS [FTN-REV18.2] SUBROUTINE COL(NFIX,NF,IC,NS,NSR,NFR,NB,IBH,NBR,N3DIM,NHFIX,NHF) COL000 (0409) SUBROUTINE COL(NFIX,NF,IC,NS,NSR,NFR,NB,IBH,NBR,N3DIM,NHFIX,NHF) (0410) C*********************************************************************** (0411) C* (0412) C* COL COMPUTES COLUMN CODES FOR THE NORMAL EQUATIONS. (0413) C* (0414) C* (0415) C* INPUT: (0416) C* -ALL DESCRIBED IN MAIN (0417) C* (0418) C* (0419) C* WRITTEN BY: (0420) C* R.R. STEEVES, MAY, 1976 (0421) C* (0422) C*********************************************************************** (0423) DIMENSION NFIX(NFR),IC(NSR,3),IBH(NBR),NHFIX(NFR) (0424) K=1 (0425) DO 1 I=1,NS (0426) IF(NB.EQ.0)GOTO5 (0427) DO 6 J=1,NB (0428) IF(I.EQ.IBH(J))GOTO4 (0429) 6 CONTINUE (0430) 5 IF(NF.EQ.0)GOTO2 (0431) DO 3 J=1,NF (0432) IF(I.EQ.NFIX(J))GOTO4 (0433) 3 CONTINUE (0434) 2 IC(I,1)=K (0435) IC(I,2)=K+1 (0436) K=K+2 (0437) GOTO1 (0438) 4 IC(I,1)=0 (0439) IC(I,2)=0 (0440) 1 CONTINUE (0441) C 3-DIM. ADJ. (0442) 98 IF(N3DIM.EQ.0) GOTO 99 (0443) 11 DO 12 I=1,NS (0444) 13 DO 14 J=1,NHF (0445) 8 IF(I.EQ.NHFIX(J)) GOTO 9 (0446) 14 CONTINUE (0447) IC(I,3) = K (0448) K = K+1 (0449) GOTO 12 (0450) 9 CONTINUE (0451) IC(I,3) = 0 (0452) 12 CONTINUE (0453) 99 CONTINUE (0454) RETURN (0455) END PROGRAM SIZE: PROCEDURE - 000344 LINKAGE - 000026 STACK - 000110 I J LINKAGE 000422 0425M 0428 0432 0434 0435 0438 0439 0443M 0445 0447 0451 IBH J ARGUMENT 000067 0409S 0423S 0428 IC J ARGUMENT 000050 0409S 0423S 0434M 0435M 0438M 0439M 0447M 0451M J J LINKAGE 000424 0427M 0428 0431M 0432 0444M 0445 K J LINKAGE 000420 0424M 0434 0435 0436M 0447 0448M N3DIM J ARGUMENT 000075 0409S 0442 NB J ARGUMENT 000064 0409S 0426 0427 NF J ARGUMENT 000045 0409S 0430 0431 NFIX J ARGUMENT 000042 0409S 0423S 0432 NHF J ARGUMENT 000103 0409S 0444 NHFIX J ARGUMENT 000100 0409S 0423S 0445 NS J ARGUMENT 000053 0409S 0425 0443 $1 000202 0425 0437 0440D $11 000217 0443D $12 000323 0443 0449 0452D $13 000223 0444D $14 000246 0444 0446D $2 000103 0430 0434D $3 000072 0431 0433D $4 000150 0428 0432 0438D $5 000045 0426 0430D $6 000034 0427 0429D $8 000227 0445D $9 000304 0445 0450D $98 000213 0442D $99 000334 0442 0453D 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE DELQX(RN,NR,SBH,NB2R,A,ICA,NOR,NZERO,NB,N,IC,OX,IOB, DELQX0 (0001) SUBROUTINE DELQX(RN,NR,SBH,NB2R,A,ICA,NOR,NZERO,NB,N,IC,OX,IOB, (0002) @ DOB,IBH,NBR,NO,RU,ICP,AP,NSR,IB,WX,CNAM,DOBR,NS,W,CBH,NPR,NP2R, (0003) @ NFR,FAC,NFIX,NF,B,N3DIM,NHFIX,NHF) (0004) C*********************************************************************** (0005) C* (0006) C* DELQX COMPUTES AND ADDS CONTRIBUTION TO INVERSE OF NORMAL EQUATIONS (0007) C* FOR THE CASE WITH BLAHA STATIONS. (0008) C* (0009) C* (0010) C* INPUT: (0011) C* -ALL DESCRIBED IN MAIN (0012) C* (0013) C* (0014) C* WRITTEN BY: (0015) C* R.R. STEEVES, JULY, 1978 (0016) C* (0017) C*********************************************************************** (0018) IMPLICIT REAL*8(A-H,O-Z) (0019) INTEGER*4 R1,S1 (0020) DIMENSION RN(NR,NR),SBH(NB2R,NB2R),A(NOR,6),ICA(NOR,6),IC(NSR,3), (0021) @ IOB(NOR,4),DOB(NOR,4),IBH(NBR),RU(NR),ICP(NR),AP(NSR,12), (0022) @ CBH(NBR),W(NOR), AA(20,6),P(20),NFIX(NFR),FAC(5), (0023) @ OX(NPR,2),IB(NR),WX(NP2R),CNAM(NSR),DOBR(NOR,4),U(20,20), (0024) @ B(NOR,6),NHFIX(NFR) (0025) NB2=NB*2 (0026) C PUT ZERO ERROR AT END (0027) NN=N+NB2-1 (0028) NZ=NN+1 (0029) NM=N (0030) N1=N-NZERO (0031) IF(NZERO.EQ.0)GOTO4 (0032) DO 1 I=1,N1 (0033) RN(I,NZ)=RN(I,NM) (0034) RN(I,NM)=0.D0 (0035) 1 CONTINUE (0036) RN(NZ,NZ)=RN(NM,NM) (0037) RN(NM,NM)=0.D0 (0038) DO 2 I=NM,NN (0039) RN(I,NZ)=0.D0 (0040) 2 CONTINUE (0041) C CLEAR NEW COLUMNS (0042) 4 IF(NZERO.EQ.0)NM=NM+1 (0043) IF(NZERO.EQ.0)NN=NN+1 (0044) NSZ=NN+NZERO (0045) DO 5 I=1,NN (0046) DO 5 J=NM,NN (0047) IF(J.LT.I)GOTO5 (0048) RN(I,J)=0.D0 (0049) 5 CONTINUE (0050) C UPDATE IC AND ICA (0051) CALL COL(NFIX,NF,IC,NS,NSR,NFR,0,IBH,NBR,N3DIM,NHFIX,NHF) (0052) CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,2,NZERO,NZ,N3DIM) (0053) C ADD SBH TO RN (0054) DO 6 I=1,NSZ (0055) 6 IB(I)=1 (0056) CALL XOBS(1,RN,RU,NN,SBH,NB,IBH,ICP,AP,OX,IB,NS,IC,WX,NR,NP2R, (0057) @ NB2R,NSR,CNAM,NPR,NBR) (0058) C REPLACE A BY PA IN B (0059) MAX=NM-1 (0060) I=1 (0061) 10 IF(IOB(I,1).EQ.2)GOTO20 (0062) DO 11 J=1,6 (0063) B(I,J)=A(I,J)/DOBR(I,1)**2 (0064) 11 CONTINUE (0065) GOTO40 (0066) 20 II=I+20 (0067) DO 21 J=I,II (0068) M=J (0069) IF(IOB(J,1).EQ.-2)GOTO22 (0070) 21 CONTINUE (0071) 22 NUM=M-I+1 (0072) DO 25 J=I,M (0073) K=J-I+1 (0074) 25 P(K)=1.D0/DOBR(J,1)**2 (0075) SUM=0.D0 (0076) DO 26 J=1,NUM (0077) 26 SUM=SUM+P(J) (0078) DO 27 J=1,NUM (0079) DO 27 K=1,NUM (0080) U(J,K)=-P(J)*P(K)/SUM (0081) IF(J.EQ.K)U(J,K)=U(J,K)+P(K) (0082) 27 CONTINUE (0083) DO 28 L1=1,NUM (0084) DO 28 L2=1,6 (0085) SUM=0.D0 (0086) DO 29 K=1,NUM (0087) KK=K+I-1 (0088) SUM=SUM+A(KK,L2)*U(L1,K) (0089) 29 CONTINUE (0090) AA(L1,L2)=SUM (0091) 28 CONTINUE (0092) DO 30 L1=1,NUM (0093) II=L1+I-1 (0094) DO 30 L2=1,6 (0095) B(II,L2)=AA(L1,L2) (0096) 30 CONTINUE (0097) I=I+NUM-1 (0098) 40 I=I+1 (0099) IF(I.LE.NO)GOTO10 (0100) DO 45 I=2,NB2 (0101) K=I-1 (0102) DO 45 J=2,K (0103) SBH(I,J)=SBH(J,I) (0104) 45 CONTINUE (0105) C COMPUTE AND ADD DQX TO RN (0106) DO 90 I=1,N1 (0107) DO 90 J=I,N1 (0108) C I,J OF DQX (0109) SUMDQ=0.D0 (0110) DO 80 J1=1,NO (0111) C I,J1 OF MBTD (0112) SUMBD=0.D0 (0113) DO 41 K=1,NO (0114) C K,I OF BM (0115) CALL ELEBM(K,I,SBM,ICA,B,NOR,RN,NR) (0116) C K,J1 OF D (0117) CALL ELEMD(K,J1,SD,ICA,A,NOR,SBH,NB2R,MAX,NZ) (0118) SUMBD=SUMBD+SBM*SD (0119) 41 CONTINUE (0120) C J1,J OF BM (0121) CALL ELEBM(J1,J,SBM,ICA,B,NOR,RN,NR) (0122) SUMDQ=SUMDQ+SUMBD*SBM (0123) 80 CONTINUE (0124) IF(I.EQ.J)GOTO81 (0125) RN(J,I)=SUMDQ (0126) GOTO90 (0127) 81 RU(I)=SUMDQ (0128) 90 CONTINUE (0129) DO 100 I=1,N1 (0130) DO 100 J=I,N1 (0131) IF(I.EQ.J)GOTO101 (0132) RN(I,J)=RN(I,J)+RN(J,I) (0133) RN(J,I)=RN(I,J) (0134) GOTO100 (0135) 101 RN(I,I)=RN(I,I)+RU(I) (0136) 100 CONTINUE (0137) IF(NZERO.EQ.0)GOTO110 (0138) DO 120 I=1,N1 (0139) RN(NM,I)=RN(I,NZ) (0140) 120 RN(I,NM)=RN(I,NZ) (0141) RN(NM,NM)=RN(NZ,NZ) (0142) 110 CALL COL(NFIX,NF,IC,NS,NSR,NFR,NB,IBH,NBR,N3DIM,NHFIX,NHF) (0143) CALL CODE(NO,DOB,IOB,FAC,ICA,IC,NOR,NSR,2,NZERO,N,N3DIM) (0144) RETURN (0145) END PROGRAM SIZE: PROCEDURE - 002434 LINKAGE - 004300 STACK - 000236 A D ARGUMENT 000056 0001S 0020S 0063 0088 0117A AA D LINKAGE 000420 0020S 0090M 0095 AP D ARGUMENT 000133 0001S 0020S 0056A B D ARGUMENT 000210 0001S 0020S 0063M 0095M 0115A 0121A CNAM D ARGUMENT 000147 0001S 0020S 0056A CODE D EXTERNAL 000000 0052 0143 COL D EXTERNAL 000000 0051 0142 DOB D ARGUMENT 000111 0001S 0020S 0052A 0143A DOBR D ARGUMENT 000152 0001S 0020S 0063 0074 ELEBM D EXTERNAL 000000 0115 0121 ELEMD D EXTERNAL 000000 0117 FAC D ARGUMENT 000177 0001S 0020S 0052A 0143A I J LINKAGE 004612 0032M 0033 0034 0038M 0039 0045M 0047 0048 0054M 0055 0060M 0061 0063 0066 0067 0071 0072 0073 0087 0093 0097M 0098M 0099 0100M 0101 0103 0106M 0107 0115A 0124 0125 0127 0129M 0130 0131 0132 0133 0135 0138M 0139 0140 IB J ARGUMENT 000141 0001S 0020S 0055M 0056A IBH J ARGUMENT 000114 0001S 0020S 0051A 0056A 0142A IC J ARGUMENT 000100 0001S 0020S 0051A 0052A 0056A 0142A 0143A ICA J ARGUMENT 000061 0001S 0020S 0052A 0115A 0117A 0121A 0143A ICP J ARGUMENT 000130 0001S 0020S 0056A II J LINKAGE 004630 0066M 0067 0093M 0095 IOB J ARGUMENT 000106 0001S 0020S 0052A 0061 0069 0143A J J LINKAGE 004616 0046M 0047 0048 0062M 0063 0067M 0068 0069 0072M 0073 0074 0076M 0077 0078M 0080 0081 0102M 0103 0107M 0121A 0124 0125 0130M 0131 0132 0133 J1 J LINKAGE 004656 0110M 0117A 0121A K J LINKAGE 004636 0073M 0074 0079M 0080 0081 0086M 0087 0088 0101M 0102 0113M 0115A 0117A KK J LINKAGE 004650 0087M 0088 L1 J LINKAGE 004644 0083M 0088 0090 0092M 0093 0095 L2 J LINKAGE 004646 0084M 0088 0090 0094M 0095 M J LINKAGE 004632 0068M 0071 0072 MAX J LINKAGE 004626 0059M 0117A N J ARGUMENT 000075 0001S 0027 0029 0030 0143A N1 J LINKAGE 004610 0030M 0032 0106 0107 0129 0130 0138 N3DIM J ARGUMENT 000213 0001S 0051A 0052A 0142A 0143A NB J ARGUMENT 000072 0001S 0025 0056A 0142A NB2 J LINKAGE 004600 0025M 0027 0100 NB2R J ARGUMENT 000053 0001S 0020S 0056A 0117A NBR J ARGUMENT 000117 0001S 0020S 0051A 0056A 0142A NF J ARGUMENT 000205 0001S 0051A 0142A NFIX J ARGUMENT 000202 0001S 0020S 0051A 0142A NFR J ARGUMENT 000174 0001S 0020S 0051A 0142A NHF J ARGUMENT 000221 0001S 0051A 0142A NHFIX J ARGUMENT 000216 0001S 0020S 0051A 0142A NM J LINKAGE 004606 0029M 0033 0034 0036 0037 0038 0042M 0046 0059 0139 0140 0141 NN J LINKAGE 004602 0027M 0028 0038 0043M 0044 0045 0046 0056A NO J ARGUMENT 000122 0001S 0052A 0099 0110 0113 0143A NOR J ARGUMENT 000064 0001S 0020S 0052A 0115A 0117A 0121A 0143A NP2R J ARGUMENT 000171 0001S 0020S 0056A NPR J ARGUMENT 000166 0001S 0020S 0056A NR J ARGUMENT 000045 0001S 0020S 0056A 0115A 0121A NS J ARGUMENT 000155 0001S 0051A 0056A 0142A NSR J ARGUMENT 000136 0001S 0020S 0051A 0052A 0056A 0142A 0143A NSZ J LINKAGE 004614 0044M 0054 NUM J LINKAGE 004634 0071M 0076 0078 0079 0083 0086 0092 0097 NZ J LINKAGE 004604 0028M 0033 0036 0039 0052A 0117A 0139 0140 0141 NZERO J ARGUMENT 000067 0001S 0030 0031 0042 0043 0044 0052A 0137 0143A OX D ARGUMENT 000103 0001S 0020S 0056A P D LINKAGE 001360 0020S 0074M 0077 0080 0081 RN D ARGUMENT 000042 0001S 0020S 0033M 0034M 0036M 0037M 0039M 0048M 0056A 0115A 0121A 0125M 0132M 0133M 0135M 0139M 0140M 0141M RU D ARGUMENT 000125 0001S 0020S 0056A 0127M 0135 SBH D ARGUMENT 000050 0001S 0020S 0056A 0103M 0117A SBM D LINKAGE 004666 0115A 0118 0121A 0122 SD D LINKAGE 004674 0117A 0118 SUM D LINKAGE 004640 0075M 0077M 0080 0085M 0088M 0090 SUMBD D LINKAGE 004660 0112M 0118M 0122 SUMDQ D LINKAGE 004652 0109M 0122M 0125 0127 U D LINKAGE 001500 0020S 0080M 0081M 0088 WX D ARGUMENT 000144 0001S 0020S 0056A XOBS D EXTERNAL 000000 0056 $1 000110 0032 0035D $10 000547 0061D 0099 $100 002104 0129 0130 0134 0136D $101 002045 0131 0135D $11 000645 0062 0064D $110 002321 0137 0142D $120 002200 0138 0140D $2 000221 0038 0040D $20 000656 0061 0066D $21 000707 0067 0070D $22 000720 0069 0071D $25 000742 0072 0074D $26 001012 0076 0077D $27 001113 0078 0079 0082D $28 001252 0083 0084 0091D $29 001224 0086 0089D $30 001345 0092 0094 0096D $4 000232 0031 0042D $40 001377 0065 0098D $41 001620 0113 0119D $45 001470 0100 0102 0104D $5 000323 0045 0046 0047 0049D $6 000435 0054 0055D $80 001663 0110 0123D $81 001725 0124 0127D $90 001742 0106 0107 0126 0128D 0000 ERRORS [FTN-REV18.2] SUBROUTINE DIRN(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, DIRN00 (0146) SUBROUTINE DIRN(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, (0147) @ ITER,W,NOR,NSR,NR,CNAM,DOBR) (0148) C*********************************************************************** (0149) C* (0150) C* DIRN COMPUTES THE CONTRIBUTION OF DIRECTION OBSERVATIONS TO THE NORM (0151) C* EQUATIONS AND CONSTANT VECTOR. ORIENTATION UNKNOWNS ARE ELIMINATED. (0152) C* (0153) C* (0154) C* INPUT: (0155) C* -ALL DESCRIBED IN MAIN (0156) C* (0157) C* (0158) C* WRITTEN BY: (0159) C* R.R. STEEVES, JUNE, 1978 (0160) C* (0161) C*********************************************************************** (0162) IMPLICIT REAL*8(A-H,O-Z) (0163) DIMENSION IOB(NOR,4),DOB(NOR,4),AP(NSR,12),A(NOR,6),RU(N), (0164) @ ICA(NOR,6),IB(N),RN(NR,NR) ,P(20),W(NO),U(20,20),CNAM(NSR) (0165) @ ,DOBR(NOR,4) (0166) DIST(XI,YI,XJ,YJ)=DSQRT((XJ-XI)**2+(YJ-YI)**2) (0167) II=I+20 (0168) DO 1 J=I,II (0169) M=J (0170) IF(IOB(J,1).EQ.-2.OR.IABS(IOB(J,1)).NE.2)GOTO2 (0171) 1 CONTINUE (0172) 2 NUM=M-I+1 (0173) IF(IABS(IOB(M,1)).NE.2)NUM=NUM-1 (0174) IF(IABS(IOB(M,1)).NE.2)IOB(M-1,1)=-2 (0175) PI=3.141592653589793D0 (0176) RO=3600.D0*180.D0/PI (0177) DO 5 J=I,M (0178) IFR=IOB(J,2) (0179) ITO=IOB(J,3) (0180) SIJ=DIST(AP(IFR,1),AP(IFR,2),AP(ITO,1),AP(ITO,2)) (0181) A(J,1)=(AP(IFR,2)-AP(ITO,2))/SIJ**2*RO (0182) A(J,2)=(AP(ITO,1)-AP(IFR,1))/SIJ**2*RO (0183) A(J,3)=-A(J,1) (0184) A(J,4)=-A(J,2) (0185) A(J,5)=0.D0 (0186) A(J,6)=0.D0 (0187) K=J-I+1 (0188) P(K)=1.D0/DOBR(J,1)**2 (0189) IF(NCODE.EQ.1.AND.ITER.EQ.1)GOTO5 (0190) IF(NCODE.EQ.1)GOTO4 (0191) IF(J.GT.I)GOTO3 (0192) D1=(DOB(J,2)+DOB(J,3)/60.D0+DOB(J,4)/3600.D0)*PI/180.D0 (0193) Z=DATAN2(AP(ITO,1)-AP(IFR,1),AP(ITO,2)-AP(IFR,2)) (0194) IF(Z.LT.0.D0)Z=Z+2.D0*PI (0195) 3 AL=DATAN2(AP(ITO,1)-AP(IFR,1),AP(ITO,2)-AP(IFR,2)) (0196) IF(AL.LT.0.D0)AL=AL+2.D0*PI (0197) IF(AL.LT.Z)AL=AL+2.D0*PI (0198) W(J)=AL-Z-(DOB(J,2)+DOB(J,3)/6D1+DOB(J,4)/36D2)*PI/18D1+D1 (0199) W(J)=W(J)*RO (0200) IF(ITER.GT.0)GOTO5 (0201) IF(NCODE.EQ.1)GOTO4 (0202) IDG=DOB(J,2) (0203) IMN=DOB(J,3) (0204) IDEG=DOBR(J,2) (0205) IMIN=DOBR(J,3) (0206) SEC=DOBR(J,4) (0207) WRITE(6 , 101)K,CNAM(IFR),CNAM(IFR),CNAM(ITO),IDEG,IMIN,SEC, (0208) @ DOBR(J,1),IDG,IMN,DOB(J,4),W(J) (0209) 101 FORMAT(' ',7X,'DIRECTION',I3,2X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2, (0210) @ I6,I3,F6.2, F12.2,/) (0211) GOTO5 (0212) 4 WRITE(6 , 102)K,CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(J,1) (0213) 102 FORMAT(' ',27X,'DIRECTION',I3,3X,A8,3X,A8,3X,A8,F9.2,/) (0214) 5 CONTINUE (0215) SUM=0.D0 (0216) DO 6 J=1,NUM (0217) 6 SUM=SUM+P(J) (0218) DO 7 J=1,NUM (0219) DO 7 K=1,NUM (0220) U(J,K)=-P(J)*P(K)/SUM (0221) IF(J.EQ.K)U(J,K)=U(J,K)+P(K) (0222) 7 CONTINUE (0223) DO 8 J=I,M (0224) DO 8 K=I,M (0225) DO 8 L1=1,4 (0226) DO 8 L2=1,4 (0227) IF(ICA(J,L1).GT.ICA(K,L2))GOTO8 (0228) IF(ICA(J,L1).EQ.0.OR.ICA(K,L2).EQ.0)GOTO8 (0229) RN(ICA(J,L1),ICA(K,L2))=RN(ICA(J,L1),ICA(K,L2))+A(J,L1)*A(K,L2)* (0230) @ U(J-I+1,K-I+1) (0231) IF(ICA(J,L1).LT.IB(ICA(K,L2)))IB(ICA(K,L2))=ICA(J,L1) (0232) 8 CONTINUE (0233) IF(NCODE.EQ.1)GOTO10 (0234) DO 9 J=I,M (0235) DO 9 K=1,NUM (0236) DO 9 L=1,4 (0237) IF(ICA(J,L).EQ.0)GOTO9 (0238) RU(ICA(J,L))=RU(ICA(J,L))+A(J,L)*U(J-I+1,K)*W(K+I-1) (0239) 9 CONTINUE (0240) 10 I=I+NUM (0241) RETURN (0242) END PROGRAM SIZE: PROCEDURE - 002746 LINKAGE - 003354 STACK - 000212 A D ARGUMENT 000065 0146S 0163S 0181M 0182M 0183M 0184M 0185M 0186M 0229 0238 AL D LINKAGE 003712 0195M 0196M 0197M 0198 AP D ARGUMENT 000062 0146S 0163S 0180A 0181 0182 0193 0195 CNAM D ARGUMENT 000134 0146S 0163S 0207 0212 D1 D LINKAGE 003700 0192M 0198 DATAN2 D EXTERNAL 000000 0193 0195 DIST D 000000 0166S 0180 DOB D ARGUMENT 000057 0146S 0163S 0192 0198 0202 0203 0207 DOBR D ARGUMENT 000137 0146S 0163S 0188 0204 0205 0206 0207 0212 DSQR$X D EXTERNAL 000000 0166 DSQRT D EXTERNAL 000000 0166 I J ARGUMENT 000051 0146S 0167 0168 0172 0177 0187 0191 0223 0224 0229 0234 0238 0240M IABS J EXTERNAL 000000 0170 0173 0174 IB J ARGUMENT 000076 0146S 0163S 0231M ICA J ARGUMENT 000073 0146S 0163S 0227 0228 0229 0231 0237 0238 IDEG J LINKAGE 003722 0204M 0207 IDG J LINKAGE 003716 0202M 0207 IFR J LINKAGE 003666 0178M 0180 0181 0182 0193 0195 0207 0212 II J LINKAGE 003646 0167M 0168 IMIN J LINKAGE 003724 0205M 0207 IMN J LINKAGE 003720 0203M 0207 IOB J ARGUMENT 000054 0146S 0163S 0170 0173 0174M 0178 0179 ITER J ARGUMENT 000115 0146S 0189 0200 ITO J LINKAGE 003670 0179M 0180 0181 0182 0193 0195 0207 0212 J J LINKAGE 003650 0168M 0169 0170 0177M 0178 0179 0181 0182 0183 0184 0185 0186 0187 0188 0191 0192 0198 0199 0202 0203 0204 0205 0206 0207 0212 0216M 0217 0218M 0220 0221 0223M 0227 0228 0229 0231 0234M 0237 0238 K J LINKAGE 003676 0187M 0188 0207 0212 0219M 0220 0221 0224M 0227 0228 0229 0231 0235M 0238 L J LINKAGE 003752 0236M 0237 0238 L1 J LINKAGE 003746 0225M 0227 0228 0229 0231 L2 J LINKAGE 003750 0226M 0227 0228 0229 0231 M J LINKAGE 003652 0169M 0172 0173 0174 0177 0223 0224 0234 NCODE J ARGUMENT 000046 0146S 0189 0190 0201 0233 NUM J LINKAGE 003654 0172M 0173M 0216 0218 0219 0235 0240 P D LINKAGE 000424 0163S 0188M 0217 0220 0221 PI D LINKAGE 003656 0175M 0176 0192 0194 0196 0197 0198 RN D ARGUMENT 000101 0146S 0163S 0229M RO D LINKAGE 003662 0176M 0181 0182 0199 RU D ARGUMENT 000070 0146S 0163S 0238M SEC D LINKAGE 003726 0206M 0207 SIJ D LINKAGE 003672 0180M 0181 0182 SUM D LINKAGE 003742 0215M 0217M 0220 U D LINKAGE 000544 0163S 0220M 0221M 0229 0238 W D ARGUMENT 000120 0146S 0163S 0198M 0199M 0207 0238 XI D 000000 0166 XJ D 000000 0166 YI D 000000 0166 YJ D 000000 0166 Z D LINKAGE 003706 0193M 0194M 0197 0198 $1 000102 0168 0171D $10 002655 0233 0240D $101 001567 0207 0209D $102 001751 0212 0213D $2 000113 0170 0172D $3 001021 0191 0195D $4 001637 0190 0201 0212D $5 002003 0177 0189 0200 0211 0214D $6 002024 0216 0217D $7 002125 0218 0219 0222D $8 002430 0223 0224 0225 0226 0227 0228 0232D $9 002622 0234 0235 0236 0237 0239D 0000 ERRORS [FTN-REV18.2] SUBROUTINE DIST(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, DIST00 (0243) SUBROUTINE DIST(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS, (0244) @ NZERO,ITER,W,NOR,NSR,NR,ZER,CNAM,DOBR,N3DIM,DLDH) (0245) C*********************************************************************** (0246) C* (0247) C* DIST COMPUTES THE CONTRIBUTION OF DISTANCE OBSERVATIONS TO THE NORMA (0248) C* EQUATIONS AND CONSTANT VECTOR. (0249) C* (0250) C* (0251) C* INPUT: (0252) C* -ALL DESCRIBED IN MAIN (0253) C* (0254) C* (0255) C* WRITTEN BY: (0256) C* R.R. STEEVES, JUNE, 1976 (0257) C* (0258) C*********************************************************************** (0259) IMPLICIT REAL*8(A-H,O-Z) (0260) DIMENSION IOB(NOR,4),DOB(NOR,4),AP(NSR,12),A(NOR,6),ICA(NOR,6), (0261) @IB(N),RN(NR,NR) ,RU(N),W(NO),CNAM(NSR),DOBR(NOR,4), (0262) @ DLDH(NOR,2) (0263) DISE(XI,YI,XJ,YJ)=DSQRT((XJ-XI)**2+(YJ-YI)**2) (0264) IFR=IOB(I,2) (0265) ITO=IOB(I,3) (0266) SIJ=DISE(AP(IFR,1),AP(IFR,2),AP(ITO,1),AP(ITO,2)) (0267) A(I,1)=(AP(IFR,1)-AP(ITO,1))/SIJ (0268) A(I,2)=(AP(IFR,2)-AP(ITO,2))/SIJ (0269) A(I,3)=-A(I,1) (0270) A(I,4)=-A(I,2) (0271) A(I,5)=0.D0 (0272) A(I,6)=0.D0 (0273) C 3-DIM. ADJ. (0274) 11 IF(N3DIM.EQ.0) GOTO 12 (0275) A(I,5) = DLDH(I,1) (0276) A(I,6) = DLDH(I,2) (0277) 12 CONTINUE (0278) IF(NZERO.EQ.0)GOTO1 (0279) A(I,5)=-1.0D0 (0280) ICA(I,5)=N (0281) 1 P=1.D0/DOBR(I,1)**2 (0282) CALL NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) (0283) IF(NCODE.EQ.1)GOTO4 (0284) W(I)=SIJ-DOB(I,3)-ZER (0285) CALL WVEC(ICA,A,RU,W(I),P,N,NO,I,NOR) (0286) 4 IF(ITER.GT.0)GOTO3 (0287) STD=DOBR(I,1) (0288) IF(NCODE.EQ.1)GOTO2 (0289) WRITE(6 , 101)CNAM(IFR),CNAM(IFR),CNAM(ITO),DOBR(I,3),STD,DOB(I, (0290) 13), (0291) @W(I) (0292) 101 FORMAT(' ',7X,'DISTANCE',6X,A8,2X,A8,2X,A8,F13.4,F10.4,F13.4, (0293) @F13.4,/) (0294) GOTO3 (0295) 2 WRITE(6 , 102)CNAM(IFR),CNAM(IFR),CNAM(ITO),STD (0296) 102 FORMAT(' ',27X,'DISTANCE',7X,A8,3X,A8,3X,A8,F9.3,/) (0297) 3 I=I+1 (0298) RETURN (0299) END PROGRAM SIZE: PROCEDURE - 001304 LINKAGE - 000056 STACK - 000216 A D ARGUMENT 000063 0243S 0260S 0267M 0268M 0269M 0270M 0271M 0272M 0275M 0276M 0279M 0282A 0285A AP D ARGUMENT 000060 0243S 0260S 0266A 0267 0268 CNAM D ARGUMENT 000140 0243S 0260S 0289 0295 DISE D 000000 0263S 0266 DLDH D ARGUMENT 000151 0243S 0260S 0275 0276 DOB D ARGUMENT 000055 0243S 0260S 0284 0289 DOBR D ARGUMENT 000143 0243S 0260S 0281 0287 0289 DSQR$X D EXTERNAL 000000 0263 DSQRT D EXTERNAL 000000 0263 I J ARGUMENT 000047 0243S 0264 0265 0267 0268 0269 0270 0271 0272 0275 0276 0279 0280 0281 0282A 0284 0285A 0287 0289 0297M IB J ARGUMENT 000074 0243S 0260S 0282A ICA J ARGUMENT 000071 0243S 0260S 0280M 0282A 0285A IFR J LINKAGE 000424 0264M 0266 0267 0268 0289 0295 IOB J ARGUMENT 000052 0243S 0260S 0264 0265 ITER J ARGUMENT 000116 0243S 0286 ITO J LINKAGE 000426 0265M 0266 0267 0268 0289 0295 N J ARGUMENT 000102 0243S 0260S 0280 0282A 0285A N3DIM J ARGUMENT 000146 0243S 0274 NCODE J ARGUMENT 000044 0243S 0283 0288 NO J ARGUMENT 000105 0243S 0260S 0282A 0285A NOR J ARGUMENT 000124 0243S 0260S 0282A 0285A NORM J EXTERNAL 000000 0282 NR J ARGUMENT 000132 0243S 0260S 0282A NZERO J ARGUMENT 000113 0243S 0278 P D LINKAGE 000434 0281M 0282A 0285A RN D ARGUMENT 000077 0243S 0260S 0282A RU D ARGUMENT 000066 0243S 0260S 0285A SIJ D LINKAGE 000430 0266M 0267 0268 0284 STD D LINKAGE 000444 0287M 0289 0295 W D ARGUMENT 000121 0243S 0260S 0284M 0285A 0289 WVEC D EXTERNAL 000000 0285 XI D 000000 0263 XJ D 000000 0263 YI D 000000 0263 YJ D 000000 0263 ZER D ARGUMENT 000135 0243S 0284 $1 000512 0278 0281D $101 001061 0289 0292D $102 001216 0295 0296D $11 000355 0274D $12 000447 0274 0277D $2 001123 0288 0295D $3 001246 0286 0294 0297D $4 000654 0283 0286D 0000 ERRORS [FTN-REV18.2] SUBROUTINE DMSRAD(IDEG,IMIN,SEC,RAD) DMSRAD (0300) SUBROUTINE DMSRAD(IDEG,IMIN,SEC,RAD) (0301) C*********************************************************************** (0302) C* (0303) C* THIS ROUTINE CONVERTS AN ANGLE FROM DEGREES,MINUTES AND SECONDS (0304) C* TO RADIANS. (0305) C* (0306) C* (0307) C* INPUT: (0308) C* IDEG-DEGREES (0309) C* IMIN-MINUTES (0310) C* SEC -SECONDS (0311) C* (0312) C* OUTPUT: (0313) C* RAD -THE ANGLE IN RADIANS (0314) C* (0315) C* (0316) C* WRITTEN BY: (0317) C* G. BOWIE, JUNE, 1977 (0318) C* MODIFIED BY: (0319) C* R.R. STEEVES, JUNE, 1978 (0320) C* (0321) C*********************************************************************** (0322) IMPLICIT REAL *8(A-H,O-Z) (0323) DEG=IABS(IDEG)+IABS(IMIN)/60.D0+DABS(SEC)/3600.D0 (0324) RAD=DEG*3.141592653589793D0/180.D0 (0325) RAD=RAD*ISIGN(1,IDEG) (0326) IF(IDEG.EQ.0)RAD=RAD*ISIGN(1,IMIN) (0327) IF(IDEG.EQ.0.AND.IMIN.EQ.0)RAD=RAD*DSIGN(1.D0,SEC) (0328) RETURN (0329) END PROGRAM SIZE: PROCEDURE - 000144 LINKAGE - 000032 STACK - 000070 DABS D EXTERNAL 000000 0323 DEG D LINKAGE 000422 0323M 0324 DSIGN D EXTERNAL 000000 0327 IABS J EXTERNAL 000000 0323 IDEG J ARGUMENT 000044 0300S 0323 0325 0326 0327 IMIN J ARGUMENT 000047 0300S 0323 0326 0327 ISIGN J EXTERNAL 000000 0325 0326 RAD D ARGUMENT 000055 0300S 0324M 0325M 0326M 0327M SEC D ARGUMENT 000052 0300S 0323A 0327A 0000 ERRORS [FTN-REV18.2] SUBROUTINE ELEBM(K,I,SBM,ICA,B,NOR,RN,NR) ELEBM0 (0330) SUBROUTINE ELEBM(K,I,SBM,ICA,B,NOR,RN,NR) (0331) C*********************************************************************** (0332) C* (0333) C* ELEBM COMPUTES PART OF THE CORRECTION TO THE COVARIANCE MATRIX WHEN (0334) C* BLAHA STATIONS ARE USED. (0335) C* (0336) C* (0337) C* WRITTEN BY: (0338) C* R.R. STEEVES, JULY, 1978 (0339) C* (0340) C*********************************************************************** (0341) IMPLICIT REAL*8(A-H,O-Z) (0342) DIMENSION ICA(NOR,6),B(NOR,6),RN(NR,NR) (0343) SBM=0.D0 (0344) DO 1 J=1,6 (0345) IF(ICA(K,J).EQ.0)GOTO1 (0346) II=MIN0(I,ICA(K,J)) (0347) JJ=MAX0(I,ICA(K,J)) (0348) SBM=SBM+B(K,J) *RN(II,JJ) (0349) 1 CONTINUE (0350) RETURN (0351) END PROGRAM SIZE: PROCEDURE - 000142 LINKAGE - 000032 STACK - 000076 B D ARGUMENT 000056 0330S 0342S 0348 I J ARGUMENT 000045 0330S 0346 0347 ICA J ARGUMENT 000053 0330S 0342S 0345 0346 0347 II J LINKAGE 000424 0346M 0348 J J LINKAGE 000420 0344M 0345 0346 0347 0348 JJ J LINKAGE 000430 0347M 0348 K J ARGUMENT 000042 0330S 0345 0346 0347 0348 MAX0 J EXTERNAL 000000 0347 MIN0 J EXTERNAL 000000 0346 RN D ARGUMENT 000064 0330S 0342S 0348 SBM D ARGUMENT 000050 0330S 0343M 0348M $1 000114 0344 0345 0349D 0000 ERRORS [FTN-REV18.2] SUBROUTINE ELEMD(L,J1,SD,ICA,A,NOR,SBH,NB2R,MAX,NZ) ELEMD0 (0352) SUBROUTINE ELEMD(L,J1,SD,ICA,A,NOR,SBH,NB2R,MAX,NZ) (0353) C*********************************************************************** (0354) C* (0355) C* ELEMD COMPUTES PART OF THE CORRECTION TO THE COVARIANCE MATRIX WHEN (0356) C* BLAHA STATIONS ARE USED. (0357) C* (0358) C* (0359) C* WRITTEN BY: (0360) C* R.R. STEEVES, JULY, 1978 (0361) C* (0362) C*********************************************************************** (0363) IMPLICIT REAL*8(A-H,O-Z) (0364) INTEGER R1,S1 (0365) DIMENSION ICA(NOR,6),A(NOR,6),SBH(NB2R,NB2R) (0366) SD=0.D0 (0367) DO 60 R1=1,6 (0368) DO 60 S1=1,6 (0369) IF(ICA(L,R1).GT.MAX.AND.ICA(L,R1).NE.NZ.AND.ICA(J1,S1).GT.MAX (0370) @ .AND.ICA(J1,S1).NE.NZ)SD=SD+A(L,R1)*A(J1,S1)* (0371) @ SBH(ICA(L,R1)-MAX,ICA(J1,S1)-MAX) (0372) 60 CONTINUE (0373) RETURN (0374) END PROGRAM SIZE: PROCEDURE - 000234 LINKAGE - 000024 STACK - 000114 A D ARGUMENT 000062 0352S 0365S 0369 ICA J ARGUMENT 000057 0352S 0365S 0369 J1 J ARGUMENT 000051 0352S 0369 L J ARGUMENT 000046 0352S 0369 MAX J ARGUMENT 000076 0352S 0369 NZ J ARGUMENT 000101 0352S 0369 R1 J LINKAGE 000420 0364S 0367M 0369 S1 J LINKAGE 000422 0364S 0368M 0369 SBH D ARGUMENT 000070 0352S 0365S 0369 SD D ARGUMENT 000054 0352S 0366M 0369M $60 000175 0367 0368 0372D 0000 ERRORS [FTN-REV18.2] SUBROUTINE ELIPS(QXX,QXY,QYY,A,B,C,PHI) ELIPS0 (0375) SUBROUTINE ELIPS(QXX,QXY,QYY,A,B,C,PHI) (0376) C*********************************************************************** (0377) C* (0378) C* ELIPS COMPUTES THE SEMI-MAJOR AND SEMI-MINOR AXES AND THE ORIENTATIO (0379) C* (AZIMUTH OF THE MAJOR AXIS) OF THE ERROR ELLIPSE SPECIFIED BY QXX, Q (0380) C* QXY AND THE FACTOR C. (0381) C* (0382) C* (0383) C* INPUT: (0384) C* QXX,QXY,QYY- ELEMENTS OF THE 2 BY 2 COVARIANCE MATRIX OF THE VARI (0385) C* FOR WHICH AN ERROR ELLIPSE IS REQUIRED (0386) C* C- FACTOR FOR THE ELLIPSE IN RAISING IT TO A SPECIFIC (0387) C* PROBABILITY LEVEL (COMPUTED IN ERREL) (0388) C* (0389) C* OUTPUT: (0390) C* A,B- SEMI-MAJOR AND SEMI-MINOR AXES OF THE ELLIPSE (0391) C* PHI- AZIMUTH OF THE MAJOR AXIS (IN RADIANS) (0392) C* (0393) C* (0394) C* WRITTEN BY: (0395) C* R.R. STEEVES, APRIL, 1976 (0396) C* (0397) C*********************************************************************** (0398) IMPLICIT REAL*8(A-H,O-Z) (0399) P1=(QXX+QYY)/2.D0 (0400) P2=DSQRT((QXX-QYY)**2/4.0D0+QXY**2) (0401) A=DSQRT(P1+P2)*C (0402) B=DSQRT(P1-P2)*C (0403) PI=3.141592653589793D0 (0404) IF(QXX.LT.1.D0-20.AND.QYY.LT.1.D0-20)PHI=0.D0 (0405) IF(QXX.LT.1.D0-20.AND.QYY.LT.1.D0-20)GOTO1 (0406) PHI = 0.D0 (0407) IF(QYY-QXX.EQ.0.D0.AND.QXY.EQ.0.D0)GOTO 1 (0408) PHI=-0.5D0*DATAN2(-2.D0*QXY,QYY-QXX) (0409) IF(PHI.LT.0.D0)PHI=PHI+2.D0*PI (0410) 1 RETURN (0411) END PROGRAM SIZE: PROCEDURE - 000246 LINKAGE - 000040 STACK - 000102 A D ARGUMENT 000055 0375S 0401M B D ARGUMENT 000060 0375S 0402M C D ARGUMENT 000063 0375S 0401 0402 DATAN2 D EXTERNAL 000000 0408 DSQR$X D EXTERNAL 000000 0410 DSQRT D EXTERNAL 000000 0400 0401 0402 P1 D LINKAGE 000420 0399M 0401 0402 P2 D LINKAGE 000426 0400M 0401 0402 PHI D ARGUMENT 000066 0375S 0404M 0406M 0408M 0409M PI D LINKAGE 000432 0403M 0409 QXX D ARGUMENT 000044 0375S 0399 0400 0404 0405 0407 0408 QXY D ARGUMENT 000047 0375S 0400 0407 0408 QYY D ARGUMENT 000052 0375S 0399 0400 0404 0405 0407 0408 $1 000204 0405 0407 0410D 0000 ERRORS [FTN-REV18.2] SUBROUTINE ELTSP(PHI,ELAM,E,A,C1,C2,R,CHI,SLAM,ESK) ELTSP0 (0412) SUBROUTINE ELTSP(PHI,ELAM,E,A,C1,C2,R,CHI,SLAM,ESK) (0413) C*********************************************************************** (0414) C* (0415) C* THIS ROUTINE TRANSFORMS ELLIPSOIDAL COORDINATES PHI,ELAM TO (0416) C* SPHERICAL (CONFORMAL SPHERE) COORDINATES CHI,SLAM AND COMPUTES (0417) C* THE CORRESPONDING POINT SCALE FACTOR ESK (ELLIPSOID TO SPHERE). (0418) C* THE POINT SCALE FACTOR AT THE ORIGIN OF THIS CONFORMAL PROJECTION (0419) C* IS UNITY. (0420) C* (0421) C* INPUT: (0422) C* PHI - ELLIPSOIDAL LATITUDE OF THE POINT, IN RADIANS. (0423) C* ELAM - ELLIPSOIDAL LONGITUDE OF THE POINT, IN RADIANS. (0424) C* (POSITIVE EAST OF GREENWICH). (0425) C* E - FIRST ECCENTRICITY OF THE ELLIPSOID (COMPUTED IN (0426) C* SUBROUTINE STGINL). (0427) C* A - SEMI-MAJOR AXES OF THE REFERENCE ELLIPSOID. (0428) C* C1 - CONSTANT COMPUTED IN STGINL. (0429) C* C2 - CONSTANT COMPUTED IN STGINL. (0430) C* R - RADIUS OF THE CONFORMAL SPHERE (COMPUTED IN STGINL). (0431) C* (0432) C* OUTPUT: (0433) C* CHI - SPHERICAL LATITUDE OF THE POINT, IN RADIANS. (0434) C* SLAM - SPHERICAL LONGITUDE OF THE POINT, IN RADIANS. (0435) C* ESK - POINT SCALE FACTOR AT THE POINT,FROM THE ELLIPSOID (0436) C* TO THE SPHERE. (0437) C* (0438) C* (0439) C* WRITTEN BY: (0440) C* R.R. STEEVES, JULY, 1977 (0441) C* (0442) C*********************************************************************** (0443) IMPLICIT REAL*8(A-H,O-Z) (0444) SP=DSIN(PHI) (0445) PI4=3.141592653589793D0/4.D0 (0446) CHI=DATAN(C2*(DTAN(PI4+PHI/2.D0)*((1.D0-E*SP)/(1.D0+E*SP))**(E/2.D (0447) 1 0))**C1) (0448) CHI=2.D0*(CHI-PI4) (0449) SLAM=C1*ELAM (0450) RN=A/DSQRT(1.D0-E**2*SP**2) (0451) ESK=C1*R*DCOS(CHI)/RN/DCOS(PHI) (0452) RETURN (0453) END PROGRAM SIZE: PROCEDURE - 000222 LINKAGE - 000050 STACK - 000114 A D ARGUMENT 000053 0412S 0450 C1 D ARGUMENT 000056 0412S 0446 0449 0451 C2 D ARGUMENT 000061 0412S 0446 CHI D ARGUMENT 000067 0412S 0446M 0448M 0451A DATAN D EXTERNAL 000000 0446 DATN$X D EXTERNAL 000000 0453 DCOS D EXTERNAL 000000 0451 DCOS$X D EXTERNAL 000000 0453 DSIN D EXTERNAL 000000 0444 DSIN$X D EXTERNAL 000000 0453 DSQR$X D EXTERNAL 000000 0453 DSQRT D EXTERNAL 000000 0450 DTAN D EXTERNAL 000000 0446 E D ARGUMENT 000050 0412S 0446 0450 ELAM D ARGUMENT 000045 0412S 0449 ESK D ARGUMENT 000075 0412S 0451M PHI D ARGUMENT 000042 0412S 0444A 0446 0451A PI4 D LINKAGE 000426 0445M 0446 0448 R D ARGUMENT 000064 0412S 0451 RN D LINKAGE 000442 0450M 0451 SLAM D ARGUMENT 000072 0412S 0449M SP D LINKAGE 000422 0444M 0446 0450 0000 ERRORS [FTN-REV18.2] SUBROUTINE ERREL(RN,NR,N,IC,NS,NELPS,NSIMU,NVARF,AP,NSR,A,NOR, ERREL0 (0454) SUBROUTINE ERREL(RN,NR,N,IC,NS,NELPS,NSIMU,NVARF,AP,NSR,A,NOR, (0455) @ CERR,ALPHA,IDF,NF,NB,CNAM,VARF,NMULT,NCODE,NSTAN,NUNIT,ICER,TL, (0456) @CNF,NFR,CPX,NPR,PX,NPXR,FAC,X,D, IOB,DOB,CIO,NO,CENT,CBH,NBR, (0457) @BH,NBHR, NPRCX,NABST,NUTM,N3DIM) (0458) C*********************************************************************** (0459) C* (0460) C* ERREL COMPUTES STATION AND RELATIVE ELLIPSES AND PRINTS THEM. (0461) C* (0462) C* (0463) C* INPUT: (0464) C* -ALL DESCRIBED IN MAIN (0465) C* (0466) C* OUTPUT: (0467) C* -ALL DESCRIBED IN MAIN (0468) C* (0469) C* (0470) C* WRITTEN BY: (0471) C* R.R. STEEVES, AUG., 1978 (0472) C* (0473) C*********************************************************************** (0474) IMPLICIT REAL*8(A-H,O-Z) (0475) REAL*4 FLOAT,DF,RALP,RX,SNGL (0476) DIMENSION RN(NR,NR),IC(NSR,3),AP(NSR,12),A(NOR,6),CERR(NSR), (0477) @ CNAM(NSR),NCOL(4),Q(10),ICER(NSR),CNF(NFR),CPX(NPR),PX(NPXR), (0478) @FAC(5),X(NR),D(NR),IOB(NOR,4),DOB(NOR,4),CIO(NOR,3),CENT(4), (0479) @CBH(NBR),BH(NBHR),TL(10) (0480) (0481) COMMON /STATIS/ NDF1 (0482) (0483) DATA UF,UM,VKN,VUN,WAS,WASN/'(FEET) ','(METRES)','KNOWN) ', (0484) @ 'UNKNOWN)',' WAS ','WAS NOT '/ (0485) ALPH=1.D0-ALPHA/100.D0 (0486) PI=3.141592653589793D0 (0487) RO=3600.D0/PI*180.D0 (0488) IF(IDF.EQ.0.AND.NVARF.EQ.0)NSTAN=2 (0489) IF(NUNIT.EQ.0)UNIT=UM (0490) IF(NUNIT.EQ.1)UNIT=UF (0491) IF(NVARF.EQ.0)VKNO=VUN (0492) IF(NVARF.EQ.1)VKNO=VKN (0493) IF(NMULT.EQ.0)WMUL=WASN (0494) IF(NMULT.EQ.1)WMUL=WAS (0495) IF(NSTAN.EQ.2.AND.NELPS.LT.2)WRITE(6 ,101)UNIT (0496) IF(NSTAN.NE.2.AND.NELPS.LT.2)WRITE(6 ,102)ALPHA,UNIT (0497) NSTA=NS-NB (0498) IF(NSTAN.EQ.2)GOTO3 (0499) IF(NVARF.EQ.0)GOTO1 (0500) RALP=SNGL(ALPHA/100.D0) (0501) C CALL MDCHI(RALP,2.0,RX,IER) (0502) C FAK=DSQRT(DBLE(RX)) (0503) (0504) DRALP = ALPHA/100.D0 (0505) NDF1 = 2 (0506) DRX = DICCHI(DRALP) (0507) FAK = DSQRT(DRX) (0508) (0509) GOTO2 (0510) 1 CALL F2DI(ALPH,IDF,XX) (0511) FAK=DSQRT(2.D0*XX) (0512) GOTO2 (0513) 3 FAK=1.D0 (0514) GOTO4 (0515) 2 IF(NELPS.LT.2)WRITE(6 ,103)VKNO,FAK (0516) 4 IF(NELPS.LT.2.AND.IDF.GT.0.AND.NCODE.EQ.2)WRITE(6 ,104)WMUL,VARF (0517) IF(NELPS.GT.1)GOTO20 (0518) WRITE(6 ,105) (0519) SUMA=0.D0 (0520) DO 5 I=1,NSTA (0521) IF(IC(I,1).EQ.0)GOTO5 (0522) QXX=RN(IC(I,1),IC(I,1)) (0523) QYY=RN(IC(I,2),IC(I,2)) (0524) QXY=RN(IC(I,1),IC(I,2)) (0525) CALL ELIPS(QXX,QXY,QYY,AX,BX,FAK,PHI) (0526) CALL RADMS(PHI,IDP,IMP,SP) (0527) IP=SP (0528) AR=AX*BX*PI (0529) WRITE(6 ,106)CNAM(I),AX,BX,IDP,IMP,IP,AR (0530) 301 IF(N3DIM.EQ.0) GOTO 302 (0531) SH = DSQRT(RN(IC(I,3),IC(I,3))) * FAK (0532) WRITE(6,112) SH (0533) 112 FORMAT(1H+,T100,F12.4) (0534) 302 CONTINUE (0535) SUMA=SUMA+AR (0536) 5 CONTINUE (0537) WRITE(6 ,107)SUMA (0538) 20 IF(NELPS.EQ.1)GOTO30 (0539) NSREL=0 (0540) DO 8 I=1,NS (0541) IF(IC(I,1).NE.0)NSREL=NSREL+1 (0542) IF(NSREL.GT.1)GOTO9 (0543) 8 CONTINUE (0544) GOTO30 (0545) 9 IF(NSTAN.EQ.2)WRITE(6 ,108)UNIT (0546) IF(NSTAN.NE.2)WRITE(6 ,109)ALPHA,UNIT (0547) IF(NSTAN.NE.2)WRITE(6 ,103)VKNO,FAK (0548) IF(IDF.GT.0.AND.NCODE.EQ.2)WRITE(6 ,104)WMUL,VARF (0549) WRITE(6 ,110) (0550) NS1=NSTA-1 (0551) DO 6 I=1,NS1 (0552) K=I+1 (0553) NCOL(1)=IC(I,1) (0554) NCOL(2)=IC(I,2) (0555) DO 6 J=K,NSTA (0556) NCOL(3)=IC(J,1) (0557) NCOL(4)=IC(J,2) (0558) IF(NCOL(1).EQ.0.OR .NCOL(3).EQ.0)GOTO6 (0559) DO 7 L=1,10 (0560) 7 Q(L)=0.D0 (0561) KI=1 (0562) DO 47 II=1,4 (0563) KK=II+1 (0564) IF(NCOL(II).NE.0)Q(KI)=RN(NCOL(II),NCOL(II)) (0565) KI=KI+1 (0566) IF(II.EQ.4)GOTO47 (0567) DO 45 JJ=KK,4 (0568) IF(NCOL(II).NE.0.AND.NCOL(JJ).NE.0)Q(KI)=RN(NCOL(II),NCOL(JJ)) (0569) 45 KI=KI+1 (0570) 47 CONTINUE (0571) QXX=Q(8)-2.D0*Q(3)+Q(1) (0572) QXY=Q(9)-Q(6)-Q(4)+Q(2) (0573) QYY=Q(10)-2.D0*Q(7)+Q(5) (0574) CALL ELIPS(QXX,QXY,QYY,AX,BX,FAK,PHI) (0575) CALL RADMS(PHI,IDP,IMP,SP) (0576) IP=SP (0577) SIJ=DSQRT((AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2) (0578) IPR=SIJ/AX (0579) CALL SDADIS(I,J,IC,NSR,RN,NR,SIJ,AP,STDIS) (0580) CALL SDAAZM(I,J,IC,NSR,RN,NR,SIJ,AP,STDAZ) (0581) WRITE(6,111)CNAM(I),CNAM(J),AX,BX,IDP,IMP,IP,SIJ,IPR,STDIS,STDAZ (0582) 6 CONTINUE (0583) 30 IF(NSIMU.EQ.0)RETURN (0584) IF(IDF.EQ.0)RETURN (0585) NRCOD=2 (0586) 29 CALL READ(TL,1,NCODE,1,1,NSTAN,0,NUNIT,NELPS,1,1,1,1,0,NMULT,1, (0587) @CNF,NFR,1,1,CPX,NPR,PX,NPXR,ALPHA,FAC,CNAM,NSR,AP,NS,X,D,NR,IOB, (0588) @NOR,DOB,CIO,NO,1,N,1,1.D0,CENT,1,1,1,1,1,1,CBH,BH,NBR,NBHR, (0589) @1,1,1,1,1,CERR,NSIMU,1,0,0,0,0,NPRCX,0,1,1,NVARF,0,NRCOD,1.D0, (0590) @1.D0,NABST,NUTM,CNHF) (0591) IF(NRCOD.EQ.3)RETURN (0592) CALL MAKICE(ICER,CERR,CNAM,NSR,NS,NSTA) (0593) IF(NSTA.EQ.0)GOTO29 (0594) IF(NSTAN.EQ.2)WRITE(6 ,201)UNIT (0595) IF(NSTAN.NE.2)WRITE(6 ,202)ALPHA,UNIT (0596) IF(NVARF.EQ.0)GOTO31 (0597) DNSTA = NSTA (0598) RALP=SNGL(1.D0-ALPH/DNSTA) (0599) C CALL MDCHI(RALP,2.0,RX,IER) (0600) C FAK=DSQRT(DBLE(RX)) (0601) (0602) DRALP = 1.D0 - ALPH/DNSTA (0603) NDF1 = 2 (0604) DRX = DICCHI(DRALP) (0605) FAK = DSQRT(DRX) (0606) (0607) GOTO32 (0608) 31 ALPS=ALPH/NSTA (0609) CALL F2DI(ALPS,IDF,XX) (0610) FAK=DSQRT(2.D0*XX) (0611) 32 IF(NCODE.EQ.2)WRITE(6 ,104)WMUL,VARF (0612) WRITE(6 ,209)VKNO,FAK (0613) WRITE(6 ,105) (0614) SUMA=0.D0 (0615) DO 35 I=1,NSTA (0616) IN=ICER(I) (0617) IF(IC(I,1).EQ.0)GOTO35 (0618) QXX=RN(IC(IN,1),IC(IN,1)) (0619) QYY=RN(IC(IN,2),IC(IN,2)) (0620) QXY=RN(IC(IN,1),IC(IN,2)) (0621) CALL ELIPS(QXX,QXY,QYY,AX,BX,FAK,PHI) (0622) CALL RADMS(PHI,IDP,IMP,SP) (0623) IP=SP (0624) AR=AX*BX*PI (0625) WRITE(6 ,106)CNAM(IN),AX,BX,IDP,IMP,IP,AR (0626) 303 IF(N3DIM.EQ.0) GOTO 304 (0627) SH = DSQRT(RN(IC(IN,3),IC(IN,3))) * FAK (0628) WRITE(6,112) SH (0629) 304 CONTINUE (0630) SUMA=SUMA+AR (0631) 35 CONTINUE (0632) WRITE(6 ,107)SUMA (0633) IF(NSTA.EQ.1)GOTO29 (0634) IF(NSTAN.EQ.2)WRITE(6 ,207)UNIT (0635) IF(NSTAN.NE.2)WRITE(6 ,208)ALPHA,UNIT (0636) IF(NCODE.EQ.2)WRITE(6 ,104)WMUL,VARF (0637) WRITE(6 ,209)VKNO,FAK (0638) WRITE(6 ,205) (0639) NS1=NSTA-1 (0640) DO 36 I=1,NS1 (0641) IN=ICER(I) (0642) K=I+1 (0643) NCOL(1)=IC(IN,1) (0644) NCOL(2)=IC(IN,2) (0645) DO 36 J=K,NSTA (0646) JN=ICER(J) (0647) NCOL(3)=IC(JN,1) (0648) NCOL(4)=IC(JN,2) (0649) IF(NCOL(1).EQ.0.OR .NCOL(3).EQ.0)GOTO36 (0650) DO 37 L=1,10 (0651) 37 Q(L)=0.D0 (0652) KI=1 (0653) DO 57 II=1,4 (0654) KK=II+1 (0655) IF(NCOL(II).NE.0)Q(KI)=RN(NCOL(II),NCOL(II)) (0656) KI=KI+1 (0657) IF(II.EQ.4)GOTO57 (0658) DO 55 JJ=KK,4 (0659) IF(NCOL(II).NE.0.AND.NCOL(JJ).NE.0)Q(KI)=RN(NCOL(II),NCOL(JJ)) (0660) 55 KI=KI+1 (0661) 57 CONTINUE (0662) QXX=Q(8)-2.D0*Q(3)+Q(1) (0663) QXY=Q(9)-Q(6)-Q(4)+Q(2) (0664) QYY=Q(10)-2.D0*Q(7)+Q(5) (0665) CALL ELIPS(QXX,QXY,QYY,AX,BX,FAK,PHI) (0666) CALL RADMS(PHI,IDP,IMP,SP) (0667) IP=SP (0668) SIJ=DSQRT((AP(JN,1)-AP(IN,1))**2+(AP(JN,2)-AP(IN,2))**2) (0669) IPR=SIJ/AX (0670) WRITE(6 ,206)CNAM(IN),CNAM(JN),AX,BX,IDP,IMP,IP,SIJ,IPR (0671) 36 CONTINUE (0672) GOTO29 (0673) 101 FORMAT('1',32X,'STATION STANDARD CONFIDENCE ELLIPSES ',A8,/,' ', (0674) @ 32X,36('-'),//) (0675) 102 FORMAT('1',32X,'STATION',F7.3,' % CONFIDENCE ELLIPSES ',A8,/,' ', (0676) @ 32X,36('-'),//) (0677) 103 FORMAT(' ',4X,'FACTOR USED FOR OBTAINING THESE ELLIPSES FROM STAND (0678) @ARD ELLIPSES: (VARIANCE FACTOR ',A8,' =',F9.4,/) (0679) 104 FORMAT(' ',4X,'(COVARIANCE MATRIX OF PARAMETERS ',A8,'MULTIPLIED B (0680) @Y THE ESTIMATED VARIANCE FACTOR (',F12.6,' )).',//) (0681) 105 FORMAT(' ',10X,'STATION',3X,'SEMI-MAJOR AXIS',3X,'SEMI-MINOR AXIS' (0682) @,3X,'AZIMUTH OF SEMI-MAJOR AXIS',3X,'AREA OF ELLIPSE', (0683) @ 4X,'STD.DEV.HEIGHTS'/) (0684) 106 FORMAT(' ',10X,A8,F12.4,6X,F12.4,7X,I9,I4,I4,13X,D12.5,/) (0685) 107 FORMAT(//,' ',33X,'TOTAL AREA OF STATION ELLIPSES =',D12.5) (0686) 108 FORMAT('1',32X,'RELATIVE STANDARD CONFIDENCE ELLIPSES ',A8,/,' ', (0687) @32X,37('-'),//) (0688) 109 FORMAT('1',32X,'RELATIVE',F7.3,' % CONFIDENCE ELLIPSES ',A8,/, (0689) @' ',32X,37('-'),//) (0690) 110 FORMAT(' ',2X,44X,'AZIMUTH',31X,'STD.DEV.',7X,'STD.DEV.',/,' ', (0691) @2X,'FROM',5X,'TO',7X,'SEMI-MAJOR',3X,'SEMI-MINOR',4X,'MAJOR',6X, (0692) @'DISTANCE',3X,'PRECISION',4X,'ADJ.DISTANCE',3X,'ADJ.AZIMUTH',/) (0693) 111 FORMAT(' ',2X,A8,1X,A8,1X,F8.4,5X,F8.4,2X,I5,I3,I3,1X,F11.4,3X, (0694) @'1:',I8,2X,F9.4,6X,F8.2,/) (0695) 201 FORMAT('1',27X,'SIMULTANEOUS STATION STANDARD CONFIDENCE ELLIPSES (0696) @',A8,/,' ',27X,49('-'),//) (0697) 202 FORMAT('1',27X,'SIMULTANEOUS STATION',F7.3,' % CONFIDENCE ELLIPSES (0698) @ ',A8,/,' ',27X,49('-'),//) (0699) 205 FORMAT(' ',16X,44X,'AZIMUTH',/,' ',16X,'FROM',5X,'TO', 7X,'SEMI-MA (0700) @JOR',3X,'SEMI-MINOR',4X,'MAJOR',6X,'DISTANCE',3X,'PRECISION',/) (0701) 206 FORMAT(' ',16X,A8,1X,A8,F9.4,5X,F8.4,I7,I3,I3,1X,F11.4,3X,'1:', (0702) @I8,/) (0703) 207 FORMAT('1',27X,'SIMULTANEOUS RELATIVE STANDARD CONFIDENCE ELLIPSES (0704) @ ',A8,/,' ',27X,50('-'),//) (0705) 208 FORMAT('1',27X,'SIMULTANEOUS RELATIVE',F7.3,' % CONFIDENCE ELLIPSE (0706) @S ',A8,/,' ',27X,50('-'),//) (0707) 209 FORMAT(' ',19X,'FACTOR FOR OBTAINING THESE ELLIPSES (VARIANCE FACT (0708) @OR ',A8, '=',F8.3,//) (0709) END PROGRAM SIZE: PROCEDURE - 006462 LINKAGE - 000412 STACK - 000302 ALPH D LINKAGE 000534 0485M 0510A 0598 0602 0608 ALPHA D ARGUMENT 000113 0454S 0485 0496 0500 0504 0546 0586A 0595 0635 ALPS D LINKAGE 001002 0608M 0609A AP D ARGUMENT 000074 0454S 0476S 0577 0579A 0580A 0586A 0668 AR D LINKAGE 000704 0528M 0529 0535 0624M 0625 0630 AX D LINKAGE 000654 0525A 0528 0529 0574A 0578 0581 0621A 0624 0625 0665A 0669 0670 BH D ARGUMENT 000237 0454S 0476S 0586A BX D LINKAGE 000660 0525A 0528 0529 0574A 0581 0621A 0624 0625 0665A 0670 CBH D ARGUMENT 000231 0454S 0476S 0586A CENT D ARGUMENT 000226 0454S 0476S 0586A CERR D ARGUMENT 000110 0454S 0476S 0586A 0592A CIO D ARGUMENT 000220 0454S 0476S 0586A CNAM D ARGUMENT 000127 0454S 0476S 0529 0581 0586A 0592A 0625 0670 CNF D ARGUMENT 000157 0454S 0476S 0586A CNHF D LINKAGE 000766 0586A CPX D ARGUMENT 000165 0454S 0476S 0586A D D ARGUMENT 000207 0454S 0476S 0586A DICCHI D EXTERNAL 000000 0506 0604 DNSTA D LINKAGE 000774 0597M 0598 0602 DOB D ARGUMENT 000215 0454S 0476S 0586A DRALP D LINKAGE 000600 0504M 0506A 0602M 0604A DRX D LINKAGE 000610 0506M 0507A 0604M 0605A DSQR$X D EXTERNAL 000000 0510 0513 0532 0581 0608 0611 0628 0670 DSQRT D EXTERNAL 000000 0507 0511 0531 0577 0605 0610 0627 0668 ELIPS D EXTERNAL 000000 0525 0574 0621 0665 F2DI D EXTERNAL 000000 0510 0609 FAC D ARGUMENT 000201 0454S 0476S 0586A FAK D LINKAGE 000616 0507M 0511M 0513M 0515 0525A 0531 0547 0574A 0605M 0610M 0612 0621A 0627 0637 0665A I J LINKAGE 000634 0520M 0521 0522 0523 0524 0529 0531 0540M 0541 0551M 0552 0553 0554 0577 0579A 0580A 0581 0615M 0616 0617 0640M 0641 0642 IC J ARGUMENT 000055 0454S 0476S 0521 0522 0523 0524 0531 0541 0553 0554 0556 0557 0579A 0580A 0617 0618 0619 0620 0627 0643 0644 0647 0648 ICER J ARGUMENT 000151 0454S 0476S 0592A 0616 0641 0646 IDF J ARGUMENT 000116 0454S 0488 0510A 0516 0548 0584 0609A IDP J LINKAGE 000672 0526A 0529 0575A 0581 0622A 0625 0666A 0670 II J LINKAGE 000732 0562M 0563 0564 0566 0568 0653M 0654 0655 0657 0659 IMP J LINKAGE 000674 0526A 0529 0575A 0581 0622A 0625 0666A 0670 IN J LINKAGE 001006 0616M 0618 0619 0620 0625 0627 0641M 0643 0644 0668 0670 IOB J ARGUMENT 000212 0454S 0476S 0586A IP J LINKAGE 000702 0527M 0529 0576M 0581 0623M 0625 0667M 0670 IPR J LINKAGE 000744 0578M 0581 0669M 0670 J J LINKAGE 000724 0555M 0556 0557 0577 0579A 0580A 0581 0645M 0646 JJ J LINKAGE 000736 0567M 0568 0658M 0659 JN J LINKAGE 001010 0646M 0647 0648 0668 0670 K J LINKAGE 000722 0552M 0555 0642M 0645 KI J LINKAGE 000730 0561M 0564 0565M 0568 0569M 0652M 0655 0656M 0659 0660M KK J LINKAGE 000734 0563M 0567 0654M 0658 L J LINKAGE 000726 0559M 0560 0650M 0651 MAKICE J EXTERNAL 000000 0592 N J ARGUMENT 000052 0454S 0586A N3DIM J ARGUMENT 000256 0454S 0530 0626 NABST J ARGUMENT 000250 0454S 0586A NB J ARGUMENT 000124 0454S 0497 NBHR J ARGUMENT 000242 0454S 0476S 0586A NBR J ARGUMENT 000234 0454S 0476S 0586A NCODE J ARGUMENT 000140 0454S 0516 0548 0586A 0611 0636 NCOL J LINKAGE 000454 0476S 0553M 0554M 0556M 0557M 0558 0564 0568 0643M 0644M 0647M 0648M 0649 0655 0659 NDF1 J /STATIS/ 000000 0481S 0505M 0603M NELPS J ARGUMENT 000063 0454S 0495 0496 0515 0516 0517 0538 0586A NFR J ARGUMENT 000162 0454S 0476S 0586A NMULT J ARGUMENT 000135 0454S 0493 0494 0586A NO J ARGUMENT 000223 0454S 0586A NOR J ARGUMENT 000105 0454S 0476S 0586A NPR J ARGUMENT 000170 0454S 0476S 0586A NPRCX J ARGUMENT 000245 0454S 0586A NPXR J ARGUMENT 000176 0454S 0476S 0586A NR J ARGUMENT 000047 0454S 0476S 0579A 0580A 0586A NRCOD J LINKAGE 000762 0585M 0586A 0591 NS J ARGUMENT 000060 0454S 0497 0540 0586A 0592A NS1 J LINKAGE 000720 0550M 0551 0639M 0640 NSIMU J ARGUMENT 000066 0454S 0583 0586A NSR J ARGUMENT 000077 0454S 0476S 0579A 0580A 0586A 0592A NSREL J LINKAGE 000716 0539M 0541M 0542 NSTA J LINKAGE 000572 0497M 0520 0550 0555 0592A 0593 0597 0608 0615 0633 0639 0645 NSTAN J ARGUMENT 000143 0454S 0488M 0495 0496 0498 0545 0546 0547 0586A 0594 0595 0634 0635 NUNIT J ARGUMENT 000146 0454S 0489 0490 0586A NUTM J ARGUMENT 000253 0454S 0586A NVARF J ARGUMENT 000071 0454S 0488 0491 0492 0499 0586A 0596 PHI D LINKAGE 000664 0525A 0526A 0574A 0575A 0621A 0622A 0665A 0666A PI D LINKAGE 000540 0486M 0487 0528 0624 PX D ARGUMENT 000173 0454S 0476S 0586A Q D LINKAGE 000464 0476S 0560M 0564M 0568M 0571 0572 0573 0651M 0655M 0659M 0662 0663 0664 QXX D LINKAGE 000636 0522M 0525A 0571M 0574A 0618M 0621A 0662M 0665A QXY D LINKAGE 000646 0524M 0525A 0572M 0574A 0620M 0621A 0663M 0665A QYY D LINKAGE 000642 0523M 0525A 0573M 0574A 0619M 0621A 0664M 0665A RADMS D EXTERNAL 000000 0526 0575 0622 0666 RALP R LINKAGE 000576 0475S 0500M 0598M READ D EXTERNAL 000000 0586 RN D ARGUMENT 000044 0454S 0476S 0522 0523 0524 0531A 0564 0568 0579A 0580A 0618 0619 0620 0627A 0655 0659 RO D LINKAGE 000544 0487M SDAAZM D EXTERNAL 000000 0580 SDADIS D EXTERNAL 000000 0579 SH D LINKAGE 000712 0531M 0532 0627M 0628 SIJ D LINKAGE 000740 0577M 0578 0579A 0580A 0581 0668M 0669 0670 SNGL R EXTERNAL 000000 0475S 0500 0598 SP D LINKAGE 000676 0526A 0527 0575A 0576 0622A 0623 0666A 0667 STDAZ D LINKAGE 000756 0580A 0581 STDIS D LINKAGE 000750 0579A 0581 SUMA D LINKAGE 000630 0519M 0535M 0537 0614M 0630M 0632 TL D ARGUMENT 000154 0454S 0476S 0586A UF D LINKAGE 000424 0483I 0490 UM D LINKAGE 000430 0483I 0489 UNIT D LINKAGE 000550 0489M 0490M 0495 0496 0545 0546 0594 0595 0634 0635 VARF D ARGUMENT 000132 0454S 0516 0548 0611 0636 VKN D LINKAGE 000434 0483I 0492 VKNO D LINKAGE 000554 0491M 0492M 0515 0547 0612 0637 VUN D LINKAGE 000440 0483I 0491 WAS D LINKAGE 000444 0483I 0494 WASN D LINKAGE 000450 0483I 0493 WMUL D LINKAGE 000560 0493M 0494M 0516 0548 0611 0636 X D ARGUMENT 000204 0454S 0476S 0586A XX D LINKAGE 000624 0510A 0511 0609A 0610 $1 000313 0499 0510D $101 004676 0495 0673D $102 004744 0496 0675D $103 005012 0515 0547 0677D $104 005101 0516 0548 0611 0636 0679D $105 005172 0518 0613 0681D $106 005277 0529 0625 0684D $107 005332 0537 0632 0685D $108 005366 0545 0686D $109 005434 0546 0688D $110 005503 0549 0690D $111 005640 0581 0693D $112 001041 0532 0533D 0628 $2 000345 0509 0512 0515D $20 001107 0517 0538D $201 005713 0594 0695D $202 005767 0595 0697D $205 006044 0638 0699D $206 006142 0670 0701D $207 006202 0634 0703D $208 006257 0635 0705D $209 006334 0612 0637 0707D $29 002355 0586D 0593 0633 0672 $3 000340 0498 0513D $30 002337 0538 0544 0583D $301 000753 0530D $302 001052 0530 0534D $303 003441 0626D $304 003527 0626 0629D $31 003000 0596 0608D $32 003034 0607 0611D $35 003535 0615 0617 0631D $36 004654 0640 0645 0649 0671D $37 004117 0650 0651D $4 000377 0514 0516D $45 001651 0567 0569D $47 001670 0562 0566 0570D $5 001060 0520 0521 0536D $55 004274 0658 0660D $57 004313 0653 0657 0661D $6 002315 0551 0555 0558 0582D $7 001474 0559 0560D $8 001153 0540 0543D $9 001164 0542 0545D 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE FILAP(AP,NSR,NPROJ,NUNIT,AA,BB,NS,RP,RL,XO,YO,X1,Y1, FILAP0 (0001) SUBROUTINE FILAP(AP,NSR,NPROJ,NUNIT,AA,BB,NS,RP,RL,XO,YO,X1,Y1, (0002) @ Z1,R1,RKO,NUTM) (0003) C*********************************************************************** (0004) C* (0005) C* FILAP COMPUTES ELLIPSOIDAL COORDINATES OF STATIONS, RADII OF CURVATU (0006) C* OF ELLIPSOID AT STATIONS AND THE POINT SCALE FACTOR AND MERIDIAN (0007) C* CONVERGENCE FOR EACH STATION IF A SPECIFIC MAP-PROJECTION IS REQUEST (0008) C* ALL THIS INFORMATION IS STORED, ALONG WIGH APPROXIMATE COORDINATES, (0009) C* HEIGHTS AND DEFLECTION COMPONENTS, IN THE MATRIX AP. (0010) C* (0011) C* (0012) C* INPUT: (0013) C* -ALL DESCRIBED IN MAIN (0014) C* (0015) C* OUTPUT: (0016) C* AA,BB- SEMI MAJOR AND SEMI MINOR AXES OF THE REFERENCE ELLIPSOI (0017) C* AP,RL- ELLIPSOIDAL COORDINATES OF THE ORIGIN OF THE MAP PROJECT (0018) C* USED. (0019) C* XO,YO- GRID COORDINATES OF THE ORIGIN OF THE PROJECTION (0020) C* X1,Y1,Z1-TRANSLATION COMPONENTS FROM THE GEOCENTRE TO THE CENTRE (0021) C* OF THE REFERENCE ELLIPSOID (0022) C* R1- RADIUS OF THE STEREOGRAPHIC CONFORMAL SPHERE (IF THIS (0023) C* PROJECTION IS USED) (0024) C* RKO- SCALE FACTOR AT THE ORIGIN OF THE MAP PROJECTION (0025) C* (0026) C* NOTE: ALL ITEMS IN THE OUTPUT LIST ABOVE ARE ASSIGNED VALUES I (0027) C* ROUTINE. (0028) C* (0029) C* (0030) C* WRITTEN BY: (0031) C* R.R. STEEVES, JULY, 1978 (0032) C* (0033) C*********************************************************************** (0034) IMPLICIT REAL*8(A-H,O-Z) (0035) DIMENSION AP(NSR,12) (0036) EN(PHI)=AA/DSQRT(1.D0-ESQ*DSIN(PHI)**2) (0037) EM(PHI)=AA*(1.D0-ESQ)/DSQRT((1.D0-ESQ*DSIN(PHI)**2)**3) (0038) FAK=1.D0 (0039) IF(NUNIT.EQ.1)FAK=0.3048D0 (0040) AA=6378206.4D0/FAK /* CLARKE 1866 (0041) BB=6356583.8D0/FAK /* CLARKE 1866 (0042) X1=-15.D0/FAK (0043) Y1=150.D0/FAK (0044) Z1=180.D0/FAK (0045) ESQ=(AA**2-BB**2)/AA**2 (0046) RP=0.D0 (0047) IF(NPROJ.EQ.6) GOTO 4 (0048) GOTO( 5,10,15,20,25),NPROJ (0049) 4 CONTINUE (0050) ICM = - ( 180 - ( 3 + 6 * (NUTM-1))) (0051) CALL DMSRAD(ICM,0,0.D0,RL) (0052) XO = 5.D5 (0053) RKO = 0.9996D0 (0054) GOTO 30 (0055) 5 CALL DMSRAD(46,30,0.D0,RP) (0056) CALL DMSRAD(-66,30,0.D0,RL) (0057) IF(NUNIT.EQ.1)GOTO6 (0058) XO=300000.D0 (0059) YO=800000.D0 (0060) GOTO7 (0061) 6 XO=1000000.D0 (0062) YO=1000000.D0 (0063) 7 RKO=0.999912D0 (0064) GOTO30 (0065) 10 CALL DMSRAD(47,15,0.D0,RP) (0066) CALL DMSRAD(-63,0,0.D0,RL) (0067) IF(NUNIT.EQ.1)GOTO11 (0068) XO=700000.D0 (0069) YO=400000.D0 (0070) GOTO12 (0071) 11 XO=1000000.D0 (0072) YO=1000000.D0 (0073) 12 RKO=0.999912D0 (0074) GOTO30 (0075) 15 GOTO30 (0076) 20 CALL DMSRAD(-61,30,0.D0,RL) (0077) IF(NUNIT.EQ.1)GOTO21 (0078) XO=4500000.D0 (0079) GOTO22 (0080) 21 XO=1000000.D0 (0081) 22 RKO=0.9999D0 (0082) GOTO30 (0083) 25 CALL DMSRAD(-64,30,0.D0,RL) (0084) RP=0.D0 (0085) IF(NUNIT.EQ.1)GOTO26 (0086) XO=5500000.D0 (0087) GOTO27 (0088) 26 XO=1000000.D0 (0089) 27 RKO=0.9999D0 (0090) 30 IF(NPROJ.LT.3)CALL STGINL(RP,RL,AA,BB,R,C1,C2,E,CHIO,SLAMO) (0091) IF(NPROJ.LT.3)R1=R (0092) DO 40 I=1,NS (0093) IF(NPROJ.GT.3)GOTO31 (0094) CALL PLTSP(AP(I,1),AP(I,2),XO,YO,RKO,R,CHIO,SLAMO,CHI,SLAM) (0095) CALL SPTEL(CHI,SLAM,C1,C2,E,PHI,ELAM) (0096) CALL ELTSP(PHI,ELAM,E,AA,C1,C2,R,CHI,SLAM,ESK) (0097) CALL SPTPL(CHI,SLAM,XO,YO,RKO,CHIO,SLAMO,R,X,Y,SPK,C) (0098) SF=ESK*SPK (0099) GOTO32 (0100) 31 CONTINUE (0101) YY0 = 4.D6 (0102) YY = AP(I,2) (0103) IF(NPROJ.EQ.6) YY = AP(I,2) + YY0 (0104) CALL TMXYPL(AP(I,1),YY,AA,BB,RKO,XO,RL,PHI,ELAM) (0105) DLAM=ELAM-RL (0106) CALL TMSFMC(PHI,DLAM,RKO,AA,BB,SF,C) (0107) 32 AP(I,11)=SF (0108) AP(I,9)=PHI (0109) AP(I,10)=ELAM (0110) AP(I,7)=EN(PHI) (0111) AP(I,8)=EM(PHI) (0112) AP(I,12)=C (0113) 40 CONTINUE (0114) RETURN (0115) END PROGRAM SIZE: PROCEDURE - 001464 LINKAGE - 000176 STACK - 000154 AA D ARGUMENT 000060 0001S 0036 0037 0040M 0045 0090A 0096A 0104A 0106A AP D ARGUMENT 000044 0001S 0035S 0094A 0102 0103 0104A 0107M 0108M 0109M 0110M 0111M 0112M BB D ARGUMENT 000063 0001S 0041M 0045 0090A 0104A 0106A C D LINKAGE 000546 0097A 0106A 0112 C1 D LINKAGE 000450 0090A 0095A 0096A C2 D LINKAGE 000454 0090A 0095A 0096A CHI D LINKAGE 000500 0094A 0095A 0096A 0097A CHIO D LINKAGE 000464 0090A 0094A 0097A DLAM D LINKAGE 000570 0105M 0106A DMSRAD D EXTERNAL 000000 0051 0055 0056 0065 0066 0076 0083 DSIN D EXTERNAL 000000 0036 0037 DSIN$X D EXTERNAL 000000 0036 0037 DSQR$X D EXTERNAL 000000 0036 0037 DSQRT D EXTERNAL 000000 0036 0037 E D LINKAGE 000460 0090A 0095A 0096A ELAM D LINKAGE 000516 0095A 0096A 0104A 0105 0109 ELTSP D EXTERNAL 000000 0096 EM D 000034 0037 0111 EN D 000000 0036S 0110 ESK D LINKAGE 000524 0096A 0098 ESQ D LINKAGE 000422 0036 0037 0045M FAK D LINKAGE 000432 0038M 0039M 0040 0041 0042 0043 0044 I J LINKAGE 000474 0092M 0094 0102 0103 0104 0107 0108 0109 0110 0111 0112 ICM J LINKAGE 000436 0050M 0051A NPROJ J ARGUMENT 000052 0001S 0047 0048 0090 0091 0093 0103 NS J ARGUMENT 000066 0001S 0092 NUNIT J ARGUMENT 000055 0001S 0039 0057 0067 0077 0085 NUTM J ARGUMENT 000124 0001S 0050 PHI D LINKAGE 000512 0036A 0037A 0095A 0096A 0104A 0106A 0108 0110A 0111A PLTSP D EXTERNAL 000000 0094 R D LINKAGE 000444 0090A 0091 0094A 0096A 0097A R1 D ARGUMENT 000116 0001S 0091M RKO D ARGUMENT 000121 0001S 0053M 0063M 0073M 0081M 0089M 0094A 0097A 0104A 0106A RL D ARGUMENT 000074 0001S 0051A 0056A 0066A 0076A 0083A 0090A 0104A 0105 RP D ARGUMENT 000071 0001S 0046M 0055A 0065A 0084M 0090A SF D LINKAGE 000552 0098M 0106A 0107 SLAM D LINKAGE 000504 0094A 0095A 0096A 0097A SLAMO D LINKAGE 000470 0090A 0094A 0097A SPK D LINKAGE 000542 0097A 0098 SPTEL D EXTERNAL 000000 0095 SPTPL D EXTERNAL 000000 0097 STGINL D EXTERNAL 000000 0090 TMSFMC D EXTERNAL 000000 0106 TMXYPL D EXTERNAL 000000 0104 X D LINKAGE 000532 0097A X1 D ARGUMENT 000105 0001S 0042M XO D ARGUMENT 000077 0001S 0052M 0058M 0061M 0068M 0071M 0078M 0080M 0086M 0088M 0094A 0097A 0104A Y D LINKAGE 000536 0097A Y1 D ARGUMENT 000110 0001S 0043M YO D ARGUMENT 000102 0001S 0059M 0062M 0069M 0072M 0094A 0097A YY D LINKAGE 000562 0102M 0103M 0104A YY0 D LINKAGE 000556 0101M 0103 Z1 D ARGUMENT 000113 0001S 0044M $10 000342 0048 0065D $11 000405 0067 0071D $12 000413 0070 0073D $15 000420 0048 0075D $20 000421 0048 0076D $21 000446 0077 0080D $22 000452 0079 0081D $25 000457 0048 0083D $26 000510 0085 0088D $27 000514 0087 0089D $30 000520 0054 0064 0074 0075 0082 0090D $31 000761 0093 0100D $32 001104 0099 0107D $4 000224 0047 0049D $40 001266 0092 0113D $5 000264 0048 0055D $6 000327 0057 0061D $7 000335 0060 0063D 0000 ERRORS [FTN-REV18.2] SUBROUTINE FILDOR(IOB,DOB,DOBR,NO,NOR,NCENT,AP,NSR,CENT) FILDOR (0116) SUBROUTINE FILDOR(IOB,DOB,DOBR,NO,NOR,NCENT,AP,NSR,CENT) (0117) C*********************************************************************** (0118) C* (0119) C* FILDOR COMPUTES STANDARD DEVIATIONS OF OBSERVATIONS AND STORES THEM (0120) C* IN DOBR. (0121) C* (0122) C* (0123) C* INPUT: (0124) C* -ALL DESCRIBED IN MAIN (0125) C* (0126) C* (0127) C* WRITTEN BY: (0128) C* R.R. STEEVES, JULY, 1978 (0129) C* (0130) C*********************************************************************** (0131) IMPLICIT REAL*8(A-H,O-Z) (0132) DIMENSION IOB(NOR,4),DOB(NOR,4),DOBR(NOR,4),AP(NSR,12),CENT(4) (0133) DO 3 I=1,NO (0134) IF(IOB(I,1).EQ.1)GOTO2 (0135) DOBR(I,1)=DOB(I,1) (0136) DO 1 J=2,4 (0137) DOBR(I,J)=DOB(I,J) (0138) 1 CONTINUE (0139) GOTO3 (0140) 2 DOBR(I,3)=DOB(I,3) (0141) IA=IOB(I,2) (0142) IF=IOB(I,3) (0143) SIJ=DSQRT((AP(IF,1)-AP(IA,1))**2+(AP(IF,2)-AP(IA,2))**2) (0144) DOBR(I,1)=DSQRT(DOB(I,1)**2+(DOB(I,2)*SIJ*1.D-6)**2) (0145) 3 CONTINUE (0146) IF(NCENT.EQ.0)GOTO4 (0147) CALL CENERR(IOB,DOBR,NOR,AP,NSR,CENT,NO) (0148) 4 CONTINUE (0149) RETURN (0150) END PROGRAM SIZE: PROCEDURE - 000450 LINKAGE - 000040 STACK - 000120 AP D ARGUMENT 000064 0116S 0132S 0143 0147A CENERR D EXTERNAL 000000 0147 CENT D ARGUMENT 000072 0116S 0132S 0147A DOB D ARGUMENT 000045 0116S 0132S 0135 0137 0140 0144 DOBR D ARGUMENT 000050 0116S 0132S 0135M 0137M 0140M 0144M 0147A DSQR$X D EXTERNAL 000000 0145 DSQRT D EXTERNAL 000000 0143 0144 I J LINKAGE 000420 0133M 0134 0135 0137 0140 0141 0142 0144 IA J LINKAGE 000424 0141M 0143 IF J LINKAGE 000426 0142M 0143 IOB J ARGUMENT 000042 0116S 0132S 0134 0141 0142 0147A J J LINKAGE 000422 0136M 0137 NCENT J ARGUMENT 000061 0116S 0146 NO J ARGUMENT 000053 0116S 0133 0147A NOR J ARGUMENT 000056 0116S 0132S 0147A NSR J ARGUMENT 000067 0116S 0132S 0147A SIJ D LINKAGE 000432 0143M 0144 $1 000105 0136 0138D $2 000116 0134 0140D $3 000374 0133 0139 0145D $4 000431 0146 0148D 0000 ERRORS [FTN-REV18.2] SUBROUTINE FORMPX(OX,AP,NPR,NSR,NP,NP2,SPX,NP2R,PX,NPXR,NCOV,IB, FORMPX (0151) SUBROUTINE FORMPX(OX,AP,NPR,NSR,NP,NP2,SPX,NP2R,PX,NPXR,NCOV,IB, (0152) @ NR,RU,D,IPX,X,CONVG,CNAM,NS,IOB,NOR,IC,ICA,W,CPX,WX,NO,IPB) (0153) C*********************************************************************** (0154) C* (0155) C* FORMPX FORMS THE A PRIORI WEIGHT OR COVARIANCE MATRIX FOR WEIGHTED O (0156) C* BLAHA STATIONS FROM THE VECTOR OF ELEMENTS (PX) READ. IT ALSO STORE (0157) C* COORDINATES OF WEIGHTED STATIONS FOR USE IN COMPUTING THE CORRESPOND (0158) C* MISCLOSURES. ALSO ECHOES THE FORMED MATRIX. (0159) C* (0160) C* (0161) C* INPUT: (0162) C* -ALL DESCRIBED IN MAIN (0163) C* (0164) C* OUTPUT: (0165) C* SPX- THE A PRIORI WEIGHT OR COVARIANCE MATRIX (0166) C* (0167) C* (0168) C* WRITTEN BY: (0169) C* R.R. STEEVES, JUNE, 1976 (0170) C* (0171) C*********************************************************************** (0172) IMPLICIT REAL*8(A-H,O-Z) (0173) DIMENSION OX(NPR,2),AP(NSR,12),SPX(NP2R,NP2R),PX(NPXR),IB(NR), (0174) @ RU(NR),D(NR),IPX(NPR),X(NR),CNAM(NSR),IOB(NOR,4),IC(NSR,3), (0175) @ ICA(NOR,6),W(NOR),CPX(NPR),WX(NP2R) (0176) IF(NCOV.EQ.0.AND.IPB.EQ.1)ICODE=24 (0177) IF(NCOV.EQ.1.AND.IPB.EQ.1)ICODE=25 (0178) IF(NCOV.EQ.0.AND.IPB.EQ.2)ICODE=27 (0179) IF(NCOV.EQ.1.AND.IPB.EQ.2)ICODE=26 (0180) IF(IPB.EQ.2)GOTO6 (0181) C RETAIN THE COORDINATES OF WEIGHTED STATIONS (0182) DO 1 I=1,NP (0183) OX(I,1)=AP(IPX(I),1) (0184) OX(I,2)=AP(IPX(I),2) (0185) 1 CONTINUE (0186) 6 K=0 (0187) DO 2 I=1,NP2 (0188) DO 2 J=I,NP2 (0189) K=K+1 (0190) SPX(J,I)=PX(K) (0191) 2 SPX(I,J)=PX(K) (0192) C ECHO THE FORMED A PRIORI MATRIX (0193) CALL PRAR(SPX,NP2R,NP2R,NP2,NP2,ICODE,CNAM,NS,0,IOB,NOR,IC,NSR,ICA (0194) @ ,RU,W,CPX,NP,WX,NR,NP2R,NPR,NO) (0195) C CHECK FOR ZERO DIAGONAL ELEMENTS (0196) DO 3 I=1,NP2 (0197) IF(SPX(I,I).NE.0.D0)GOTO3 (0198) WRITE(6 ,101) (0199) STOP (0200) 3 CONTINUE (0201) 101 FORMAT(' ','*** INPUT ERROR #009 *** IN INPUT OF A PRIORI INFORMA (0202) @TION MATRIX ELEMENTS; ZERO DIAGONAL ELEMENT ENCOUNTERED.') (0203) IF(NCOV.EQ.0.AND.IPB.EQ.2)GOTO5 (0204) IF(NCOV.EQ.1.AND.IPB.EQ.1)GOTO5 (0205) DO 4 I=1,NP2 (0206) 4 IB(I)=1 (0207) C INVERT A PRIORI MATRIX IF NECESSARY (0208) CALL XSIN(SPX,NP2,1,0,RU,D,IID,IB,X,NP2R,CONVG,0,0,CNAM,NS,IOB,NOR (0209) @ ,IC,NSR,ICA,RU,W,CPX,NP,WX,NP2R,NPR,NO,0,0,IPB) (0210) 5 RETURN (0211) END PROGRAM SIZE: PROCEDURE - 000764 LINKAGE - 000046 STACK - 000204 AP D ARGUMENT 000051 0151S 0173S 0183 0184 CNAM D ARGUMENT 000134 0151S 0173S 0193A 0208A CONVG D ARGUMENT 000131 0151S 0208A CPX D ARGUMENT 000161 0151S 0173S 0193A 0208A D D ARGUMENT 000120 0151S 0173S 0208A I J LINKAGE 000424 0182M 0183 0184 0187M 0188 0190 0191 0196M 0197 0205M 0206 IB J ARGUMENT 000107 0151S 0173S 0206M 0208A IC J ARGUMENT 000150 0151S 0173S 0193A 0208A ICA J ARGUMENT 000153 0151S 0173S 0193A 0208A ICODE J LINKAGE 000422 0176M 0177M 0178M 0179M 0193A IID J LINKAGE 000444 0208A IOB J ARGUMENT 000142 0151S 0173S 0193A 0208A IPB J ARGUMENT 000172 0151S 0176 0177 0178 0179 0180 0203 0204 0208A IPX J ARGUMENT 000123 0151S 0173S 0183 0184 J J LINKAGE 000430 0188M 0190 0191 K J LINKAGE 000426 0186M 0189M 0190 0191 NCOV J ARGUMENT 000104 0151S 0176 0177 0178 0179 0203 0204 NO J ARGUMENT 000167 0151S 0193A 0208A NOR J ARGUMENT 000145 0151S 0173S 0193A 0208A NP J ARGUMENT 000062 0151S 0182 0193A 0208A NP2 J ARGUMENT 000065 0151S 0187 0188 0193A 0196 0205 0208A NP2R J ARGUMENT 000073 0151S 0173S 0193A 0208A NPR J ARGUMENT 000054 0151S 0173S 0193A 0208A NR J ARGUMENT 000112 0151S 0173S 0193A NS J ARGUMENT 000137 0151S 0193A 0208A NSR J ARGUMENT 000057 0151S 0173S 0193A 0208A OX D ARGUMENT 000046 0151S 0173S 0183M 0184M PRAR D EXTERNAL 000000 0193 PX D ARGUMENT 000076 0151S 0173S 0190 0191 RU D ARGUMENT 000115 0151S 0173S 0193A 0208A SPX D ARGUMENT 000070 0151S 0173S 0190M 0191M 0193A 0197 0208A W D ARGUMENT 000156 0151S 0173S 0193A 0208A WX D ARGUMENT 000164 0151S 0173S 0193A 0208A X D ARGUMENT 000126 0151S 0173S 0208A XSIN D EXTERNAL 000000 0208 $1 000162 0182 0185D $101 000463 0198 0201D $2 000247 0187 0188 0191D $3 000452 0196 0197 0200D $4 000615 0205 0206D $5 000741 0203 0204 0210D $6 000173 0180 0186D 0000 ERRORS [FTN-REV18.2] SUBROUTINE FPLAT(A,B,Y,PHI1) FPLAT0 (0212) SUBROUTINE FPLAT(A,B,Y,PHI1) (0213) C*********************************************************************** (0214) C* (0215) C* THIS ROUTINE COMPUTES THE FOOT-POINT LATITUDE REQUIRED IN (0216) C* TRANSFORMING TRANSVERSE MERCATOR PLANE COORDINATES X,Y TO (0217) C* ELLIPSOIDAL COORDINATES. (0218) C* (0219) C* (0220) C* INPUT: (0221) C* A - SEMI-MAJOR AXES OF THE REFERENCE ELLIPSOID. (0222) C* B - SEMI-MINOR AXES OF THE REFERENCE ELLIPSOID. (0223) C* Y - NORTHING OF THE POINT FOR WHICH THE FOOT-POINT (0224) C* LATITUDE IS TO BE COMPUTED. (0225) C* (0226) C* OUTPUT: (0227) C* PHI1 - FOOT-POINT LATITUDE IN RADIANS. (0228) C* (0229) C* (0230) C* WRITTEN BY: (0231) C* R.R. STEEVES, JUNE, 1977 (0232) C* (0233) C*********************************************************************** (0234) IMPLICIT REAL*8(A-Z) (0235) F(PHI)=A*(A0*PHI-A2*DSIN(2.D0*PHI)+A4*DSIN(4.D0*PHI)-A6*DSIN(6.D0* (0236) 1 PHI)+A8*DSIN(8.D0*PHI))-Y (0237) FP(PHI)=A*(A0-2.D0*A2*DCOS(2.D0*PHI)+4.D0*A4*DCOS(4.D0*PHI)-6.D0* (0238) 1 A6*DCOS(6.D0*PHI)+8.D0*A8*DCOS(8.D0*PHI)) (0239) E2=(A*A-B*B)/(A*A) (0240) E4=E2*E2 (0241) E6=E4*E2 (0242) E8=E6*E2 (0243) A0=1.D0-E2/4.D0-3.D0*E4/64.D0-5.D0*E6/256.D0-175.D0*E8/16384.D0 (0244) A2=3.D0/8.D0*(E2+E4/4.D0+15.D0*E6/128.D0-455.D0*E8/4096.D0) (0245) A4=15.D0/256.D0*(E4+3.D0*E6/4.D0-77.D0*E8/128.D0) (0246) A6=35.D0/3072.D0*(E6-41.D0*E8/32.D0) (0247) A8=-315.D0*E8/131072.D0 (0248) PHI1=Y/A (0249) 1 DPHI=F(PHI1)/FP(PHI1) (0250) PHI1=PHI1-DPHI (0251) IF(DABS(DPHI).LT.1.D-11)GOTO 2 (0252) GO TO 1 (0253) 2 CONTINUE (0254) RETURN (0255) END PROGRAM SIZE: PROCEDURE - 000606 LINKAGE - 000076 STACK - 000140 A D ARGUMENT 000044 0212S 0235 0237 0239 0248 A0 D LINKAGE 000442 0235 0237 0243M A2 D LINKAGE 000436 0235 0237 0244M A4 D LINKAGE 000432 0235 0237 0245M A6 D LINKAGE 000426 0235 0237 0246M A8 D LINKAGE 000422 0235 0237 0247M B D ARGUMENT 000047 0212S 0239 DABS D EXTERNAL 000000 0251 DCOS D EXTERNAL 000000 0237 DCOS$X D EXTERNAL 000000 0237 DPHI D LINKAGE 000470 0249M 0250 0251A DSIN D EXTERNAL 000000 0235 DSIN$X D EXTERNAL 000000 0235 E2 D LINKAGE 000450 0239M 0240 0241 0242 0243 0244 E4 D LINKAGE 000454 0240M 0241 0243 0244 0245 E6 D LINKAGE 000460 0241M 0242 0243 0244 0245 0246 E8 D LINKAGE 000464 0242M 0243 0244 0245 0246 0247 F D 000000 0235S 0249 FP D 000113 0237 0249 PHI D 000000 0235 0237 PHI1 D ARGUMENT 000055 0212S 0248M 0249A 0250M Y D ARGUMENT 000052 0212S 0235 0248 $1 000427 0249D 0252 $2 000470 0251 0253D 0000 ERRORS [FTN-REV18.2] SUBROUTINE F2DI(ALPHA,IDF,X) F2DI00 (0256) SUBROUTINE F2DI(ALPHA,IDF,X) (0257) C*********************************************************************** (0258) C* (0259) C* F2DI COMPUTES THE INVERSE F-DISTRIBUTION PROBLEM FOR 2 DEGREES OF FR (0260) C* DOM IN THE NUMERATOR (0261) C* (0262) C* (0263) C* INPUT: (0264) C* ALPHA- SUCH THAT THE PROBABILITY OF AN F RANDOM VARIABLE (WITH (0265) C* AND IDF DEGREES OF FREEDOM) BEING GREATER THAN X IS ALPH (0266) C* IDF- DEGREES OF FREEDOM IN DENOMINATOR (0267) C* (0268) C* OUTPUT: (0269) C* X- SEE DESCRIPTION OF ALPHA ABOVE (0270) C* (0271) C* (0272) C* WRITTEN BY: (0273) C* R.R. STEEVES, AUG., 1978 (0274) C* (0275) C*********************************************************************** (0276) IMPLICIT REAL*8(A-H,O-Z) (0277) R=IDF (0278) X=(R/(ALPHA**(2.D0/R))-R)/2.D0 (0279) RETURN (0280) END PROGRAM SIZE: PROCEDURE - 000050 LINKAGE - 000026 STACK - 000060 ALPHA D ARGUMENT 000042 0256S 0278 IDF J ARGUMENT 000045 0256S 0277 R D LINKAGE 000420 0277M 0278 X D ARGUMENT 000050 0256S 0278M 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE LPRNT(NVAL,MAX,PLOTV,RVEC,WINT,N,KK) LPRNT0 (0001) SUBROUTINE LPRNT(NVAL,MAX,PLOTV,RVEC,WINT,N,KK) (0002) C*********************************************************************** (0003) C* (0004) C* LPRNT CONTROLS THE LINE SPACING FOR THE NORMAL-HISTOGRAM PLOT PRINTI (0005) C* (0006) C* WRITTEN BY: (0007) C* LAURIE PACH, JULY, 1978 (0008) C* (0009) C*********************************************************************** (0010) INTEGER WINT,PLOTV,SV,RVEC (0011) DIMENSION PLOTV(110),SV(22),RVEC(WINT) (0012) DATA SV/' ',' ',' ',' ','R','E','L','A','T','I','V','E',' ','F', (0013) @ 'R','E','Q','U','E','N','C','Y'/ (0014) B=.3 (0015) C=.2 (0016) D=.1 (0017) DO 2 I=1,100 (0018) DO 3 N=1,WINT (0019) IF(RVEC(N).EQ.MAX)RETURN (0020) 3 CONTINUE (0021) N=N-1 (0022) IF(NVAL.EQ.MAX)RETURN (0023) WRITE(6 ,101)(PLOTV(L),L=1,110) (0024) IF(MAX.EQ.25)WRITE(6 ,113)B (0025) IF(MAX.EQ.17)WRITE(6 ,113)C (0026) IF(MAX.EQ.9)WRITE(6 ,113)D (0027) MAX=MAX-1 (0028) IF(MAX.GT.32.OR.KK.EQ.23)GOTO2 (0029) WRITE(6 ,114)SV(KK) (0030) KK=KK+1 (0031) 2 CONTINUE (0032) 101 FORMAT(' ',6X,110A1) (0033) 113 FORMAT('+',3X,F3.1,'-') (0034) 114 FORMAT('+',1X,A1) (0035) RETURN (0036) END PROGRAM SIZE: PROCEDURE - 000410 LINKAGE - 000120 STACK - 000074 B R LINKAGE 000476 0014M 0024 C R LINKAGE 000500 0015M 0025 D R LINKAGE 000502 0016M 0026 I J LINKAGE 000504 0017M KK J ARGUMENT 000066 0001S 0028 0029 0030M L J LINKAGE 000510 0023M MAX J ARGUMENT 000047 0001S 0019 0022 0024 0025 0026 0027M 0028 N J ARGUMENT 000063 0001S 0018M 0019 0021M NVAL J ARGUMENT 000044 0001S 0022 PLOTV J ARGUMENT 000052 0001S 0010S 0011S 0023 RVEC J ARGUMENT 000055 0001S 0010S 0011S 0019 SV J LINKAGE 000422 0010S 0011S 0012I 0029 WINT J ARGUMENT 000060 0001S 0010S 0011S 0018 $101 000326 0023 0032D $113 000336 0024 0025 0026 0033D $114 000350 0029 0034D $2 000315 0017 0028 0031D $3 000044 0018 0020D 0000 ERRORS [FTN-REV18.2] SUBROUTINE MAKICE(ICER,CERR,CNAM,NSR,NS,NSTA) MAKICE (0037) SUBROUTINE MAKICE(ICER,CERR,CNAM,NSR,NS,NSTA) (0038) C*********************************************************************** (0039) C* (0040) C* MAKICE FORMS A VECTOR OF SEQUENCE NUMBERS (ICER) FOR STATIONS IN A (0041) C* SET FOR SIMULTANEOUS ELLIPSES. CHECKS SET OF NAMES FOR DUPLICATION (0042) C* OR EXISTANCE. (0043) C* (0044) C* (0045) C* INPUT: (0046) C* -ALL DESCRIBED IN MAIN (0047) C* (0048) C* OUTPUT: (0049) C* -ALL DESCRIBED IN MAIN (0050) C* (0051) C* (0052) C* WRITTEN BY: (0053) C* R.R. STEEVES, AUG., 1978 (0054) C* (0055) C*********************************************************************** (0056) IMPLICIT REAL*8(A-H,O-Z) (0057) DIMENSION ICER(NSR),CERR(NSR),CNAM(NSR) (0058) DATA BLNK/' '/ (0059) NSTA=0 (0060) DO 1 J=1,NSR (0061) IF(CERR(J).EQ.BLNK)GOTO2 (0062) IF(J.EQ.1)GOTO3 (0063) K=J-1 (0064) DO 4 L=1,K (0065) IF(CERR(J).EQ.CERR(L))GOTO5 (0066) 4 CONTINUE (0067) 3 DO 6 L=1,NS (0068) IF(CERR(J).EQ.CNAM(L))GOTO7 (0069) 6 CONTINUE (0070) WRITE(6 ,101)CERR(J) (0071) 101 FORMAT(' ','*** INPUT ERROR #042 *** STATION NAME ',A8,'READ' , ' (0072) @IN A SET FOR SIMULTANEOUS ELLIPSES',/,' ',10X,'IS NOT ONE OF THOSE (0073) @ IN THE NETWORK.',/) (0074) STOP (0075) 5 WRITE(6 ,102)CERR(L) (0076) 102 FORMAT(' ','*** INPUT ERROR #043 ***STATION NAME ',A8,' APPEARS AT (0077) @ LEAST TWICE IN A SET FOR SIMULTANEOUS ELLIPSES',/) (0078) STOP (0079) 7 ICER(J)=L (0080) NSTA=NSTA+1 (0081) 1 CONTINUE (0082) 2 RETURN (0083) END PROGRAM SIZE: PROCEDURE - 000512 LINKAGE - 000046 STACK - 000070 BLNK D LINKAGE 000424 0058I 0061 CERR D ARGUMENT 000045 0037S 0057S 0061 0065 0068 0070 0075 CNAM D ARGUMENT 000050 0037S 0057S 0068 ICER J ARGUMENT 000042 0037S 0057S 0079M J J LINKAGE 000430 0060M 0061 0062 0063 0065 0068 0070 0079 K J LINKAGE 000432 0063M 0064 L J LINKAGE 000434 0064M 0065 0067M 0068 0075 0079 NS J ARGUMENT 000056 0037S 0067 NSR J ARGUMENT 000053 0037S 0057S 0060 NSTA J ARGUMENT 000061 0037S 0059M 0080M $1 000471 0060 0081D $101 000201 0070 0071D $102 000347 0075 0076D $2 000502 0061 0082D $3 000105 0062 0067D $4 000074 0064 0066D $5 000320 0065 0075D $6 000141 0067 0069D $7 000446 0068 0079D 0000 ERRORS [FTN-REV18.2] SUBROUTINE MULCX(VARF,RN,NR,N) MULCX0 (0084) SUBROUTINE MULCX(VARF,RN,NR,N) (0085) C*********************************************************************** (0086) C* (0087) C* MULCX MULTIPLIES THE ELEMENTS OF THE INVERSE OF NORMAL EQUATIONS BY (0088) C* THE VARIANCE FACTOR. (0089) C* (0090) C* (0091) C* INPUT: (0092) C* VARF- ESTIMATED VARIANCE FACTOR. (0093) C* OTHERS- DESCRIBED IN MAIN. (0094) C* (0095) C* (0096) C* WRITTEN BY: (0097) C* R.R. STEEVES, AUG, 1978 (0098) C* (0099) C*********************************************************************** (0100) IMPLICIT REAL*8(A-H,O-Z) (0101) DIMENSION RN(NR,NR) (0102) DO 1 I=1,N (0103) DO 1 J=1,N (0104) 1 RN(I,J)=RN(I,J)*VARF (0105) RETURN (0106) END PROGRAM SIZE: PROCEDURE - 000066 LINKAGE - 000024 STACK - 000060 I J LINKAGE 000420 0102M 0104 J J LINKAGE 000422 0103M 0104 N J ARGUMENT 000053 0084S 0102 0103 RN D ARGUMENT 000045 0084S 0101S 0104M VARF D ARGUMENT 000042 0084S 0104 $1 000011 0102 0103 0104D 0000 ERRORS [FTN-REV18.2] SUBROUTINE NAMC(NSR,NOR,NO,NS,NP,NFIX,IPX,CIO,CNAM,CNF,CPX,IOB,NF,NAMC00 (0107) SUBROUTINE NAMC(NSR,NOR,NO,NS,NP,NFIX,IPX,CIO,CNAM,CNF,CPX,IOB,NF, (0108) @ NPR,NFR,IBH,CBH,NBR,NB,CNHF,NHF,NHFIX) (0109) C*********************************************************************** (0110) C* (0111) C* NAMC GENERATES SEQUENCE NUMBERS FOR CODING OF STATION NAMES. IT ALS (0112) C* CHECKS FOR CORRESPONDENCE OF STATION NAMES USED IN SEPARATE PARTS OF (0113) C* INPUT DATA. (0114) C* (0115) C* (0116) C* INPUT: (0117) C* - ALL DESCRIBED IN MAIN (0118) C* (0119) C* OUTPUT: (0120) C* NFIX - SEQUENCE NUMBERS FOR FIXED STATIONS (0121) C* IPX- SEQUENCE NUMBERS FOR WEIGHTED STATIONS (0122) C* IOB - SEQUENCE NUMBERS FOR OBSERVATION STATIONS (0123) C* IBH - SEQUENCE NUMBERS FOR BLAHA STATIONS (0124) C* (0125) C* (0126) C* WRITTEN BY: (0127) C* R.R. STEEVES, MAY, 1978 (0128) C* (0129) C*********************************************************************** (0130) IMPLICIT REAL*8(A-H,O-Z) (0131) REAL*8 BLNK (0132) DIMENSION NFIX(NFR),IPX(NPR),CIO(NOR,3),CNAM(NSR),CNF(NFR), (0133) @ CPX(NPR),IOB(NOR,4),IBH(NBR),CBH(NBR),CNHF(NFR),NHFIX(NFR) (0134) DATA BLNK/' '/ (0135) IF(NP.EQ.0)GOTO20 (0136) C ASSIGN SEQUENCE NUMBERS TO WEIGHTED STATIONS IF ANY (0137) DO 3 I=1,NP (0138) J=1 (0139) 1 IF(CPX(I).NE.CNAM(J))GOTO2 (0140) IPX(I)=J (0141) GOTO3 (0142) 2 IF(J.EQ.NS)GOTO4 (0143) J=J+1 (0144) GOTO1 (0145) 3 CONTINUE (0146) GOTO20 (0147) 4 WRITE(6 , 101) (0148) STOP (0149) 20 IF(NB.EQ.0)GOTO5 (0150) C ASSIGN SEQUENCE NUMBERS TO BLAHA STATIONS IF ANY (0151) DO 23 I=1,NB (0152) J=1 (0153) 21 IF(CBH(I).NE.CNAM(J))GOTO22 (0154) IBH(I)=J (0155) GOTO23 (0156) 22 IF(J.EQ.NS)GOTO24 (0157) J=J+1 (0158) GOTO21 (0159) 23 CONTINUE (0160) GOTO5 (0161) 24 WRITE(6 , 201) (0162) STOP (0163) C ASSIGN SEQUENCE NUMBERS TO FIXED STATIONS IF ANY (0164) 5 IF(NF.EQ.0)GOTO10 (0165) DO 8 I=1,NF (0166) J=1 (0167) 6 IF(CNF(I).NE.CNAM(J))GOTO7 (0168) NFIX(I)=J (0169) GOTO8 (0170) 7 IF(J.EQ.NS)GOTO9 (0171) J=J+1 (0172) GOTO6 (0173) 8 CONTINUE (0174) GOTO10 (0175) 9 WRITE(6 , 102) (0176) STOP (0177) C ASSIGN SEQUENCE NUMBER TO H-FIXED STATIONS (0178) 10 CONTINUE (0179) IF(NHF.EQ.0) GOTO 30 (0180) 25 DO 26 I=1,NHF (0181) J = 1 (0182) 27 IF(CNHF(I).NE.CNAM(J)) GOTO 28 (0183) NHFIX(I) = J (0184) GOTO 26 (0185) 28 IF(J.EQ.NS) GOTO 29 (0186) J = J + 1 (0187) GOTO 27 (0188) 26 CONTINUE (0189) GOTO 30 (0190) 29 CONTINUE (0191) WRITE(6,106) (0192) WRITE(1,106) (0193) STOP (0194) C CHECK THAT OBSERVATION STATION NAMES EXIST IN STATION NAMES READ (0195) 30 DO 13 I=1,NO (0196) DO 13 J=1,3 (0197) K=1 (0198) 11 IF(J.EQ.3.AND.IOB(I,1).NE.3)IOB(I,4)=0 (0199) IF(J.EQ.3.AND.IOB(I,1).NE.3)GOTO13 (0200) IF(CIO(I,J).EQ.CNAM(K))GOTO12 (0201) K=K+1 (0202) IF(K.GT.NS)GOTO14 (0203) GOTO11 (0204) 12 IOB(I,J+1)=K (0205) 13 CONTINUE (0206) GOTO15 (0207) 14 WRITE(6 , 103)I,CIO(I,J) (0208) STOP (0209) 15 NUM=NS-1 (0210) C CHECK THAT STATIONS ALL HAVE DIFFERENT NAMES OR THAT A STATION NAME DO (0211) C NOT CONSIST OF ALL BLANKS. (0212) DO 16 I=1,NUM (0213) M=I+1 (0214) DO 16 J=M,NS (0215) IF(CNAM(I).NE.CNAM(J))GOTO16 (0216) WRITE(6 , 104)I,J,CNAM(I) (0217) STOP (0218) 16 CONTINUE (0219) DO 17 I=1,NS (0220) IF(CNAM(I).NE.BLNK)GOTO17 (0221) WRITE(6 , 105)I (0222) STOP (0223) 17 CONTINUE (0224) 101 FORMAT(' ','*** INPUT ERROR #045 *** STATION NAME REFERENCED AS W (0225) @EIGHTED WAS NOT FOUND AMONG THOSE INPUT WITH APPROXIMATE COORDINAT (0226) @ES') (0227) 102 FORMAT(' ','*** INPUT ERROR #047 *** STATION NAME REFERENCED AS B (0228) @EING HELD FIXED WAS NOT FOUND AMONG THOSE INPUT WITH APPROXIMATE', (0229) @/,' ',21X,'COORDINATES') (0230) 103 FORMAT(' ','*** INPUT ERROR #048 *** OBSERVATION NO. ',I4,' REFER (0231) @ENCES STATIONS ',A8,',WHICH CANNOT BE FOUND AMONG THOSE INPUT WITH (0232) @',/,' ',21X,'THE APPROXIMATE COORDINATES') (0233) 104 FORMAT(' ','*** INPUT ERROR #049 *** STATIONS ',I4,' AND ',I4, (0234) @' (AS THEY WERE READ IN) HAVE SAME NAME, NAMELY:',A8) (0235) 105 FORMAT(' ','*** INPUT ERROR #050 *** STATION NO. ',I4,'AS IT WAS (0236) @READ IN) HAS NO NAME') (0237) 106 FORMAT(' ','*** INPUT ERROR #047 *** STATION NAME REFERENCED AS B (0238) @EING HELD H-FIX WAS NOT FOUND AMONG THOSE INPUT WITH APPROXIMATE', (0239) @/,' ',21X,'COORDINATES') (0240) 201 FORMAT(' ','*** INPUT ERROR #046 *** STATION NAME REFERENCED AS H (0241) @AVING BLAHA INFORMATION WAS NOT FOUND AMONG THOSE WITH APPROXIMATE (0242) @',/,' ',21X,'COORDINATES') (0243) RETURN (0244) END PROGRAM SIZE: PROCEDURE - 002216 LINKAGE - 000056 STACK - 000152 BLNK D LINKAGE 000426 0131S 0134I 0220 CBH D ARGUMENT 000124 0107S 0132S 0153 CIO D ARGUMENT 000071 0107S 0132S 0200 0207 CNAM D ARGUMENT 000074 0107S 0132S 0139 0153 0167 0182 0200 0215 0216 0220 CNF D ARGUMENT 000077 0107S 0132S 0167 CNHF D ARGUMENT 000135 0107S 0132S 0182 CPX D ARGUMENT 000102 0107S 0132S 0139 I J LINKAGE 000432 0137M 0139 0140 0151M 0153 0154 0165M 0167 0168 0180M 0182 0183 0195M 0198 0199 0200 0204 0207 0212M 0213 0215 0216 0219M 0220 0221 IBH J ARGUMENT 000121 0107S 0132S 0154M IOB J ARGUMENT 000105 0107S 0132S 0198M 0199 0204M IPX J ARGUMENT 000066 0107S 0132S 0140M J J LINKAGE 000434 0138M 0139 0140 0142 0143M 0152M 0153 0154 0156 0157M 0166M 0167 0168 0170 0171M 0181M 0182 0183 0185 0186M 0196M 0198 0199 0200 0204 0207 0214M 0215 0216 K J LINKAGE 000444 0197M 0200 0201M 0202 0204 M J LINKAGE 000454 0213M 0214 NB J ARGUMENT 000132 0107S 0149 0151 NF J ARGUMENT 000110 0107S 0164 0165 NFIX J ARGUMENT 000063 0107S 0132S 0168M NHF J ARGUMENT 000140 0107S 0179 0180 NHFIX J ARGUMENT 000143 0107S 0132S 0183M NO J ARGUMENT 000052 0107S 0195 NP J ARGUMENT 000060 0107S 0135 0137 NS J ARGUMENT 000055 0107S 0142 0156 0170 0185 0202 0209 0214 0219 NUM J LINKAGE 000452 0209M 0212 $1 000015 0139D 0144 $10 000400 0164 0174 0178D $101 001245 0147 0224D $102 001347 0175 0227D $103 001463 0207 0230D $104 001610 0216 0233D $105 001701 0221 0235D $106 001753 0191 0192 0237D $11 000551 0198D 0203 $12 000704 0200 0204D $13 000726 0195 0196 0199 0205D $14 000750 0202 0207D $15 001022 0206 0209D $16 001144 0212 0214 0215 0218D $17 001234 0219 0220 0223D $2 000064 0139 0142D $20 000126 0135 0146 0149D $201 002067 0161 0240D $21 000142 0153D 0158 $22 000211 0153 0156D $23 000224 0151 0155 0159D $24 000235 0156 0161D $25 000404 0180D $26 000476 0180 0184 0188D $27 000414 0182D 0187 $28 000463 0182 0185D $29 000507 0185 0190D $3 000077 0137 0141 0145D $30 000535 0179 0189 0195D $4 000110 0142 0147D $5 000253 0149 0160 0164D $6 000267 0167D 0172 $7 000336 0167 0170D $8 000351 0165 0169 0173D $9 000362 0170 0175D 0000 ERRORS [FTN-REV18.2] SUBROUTINE NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) NORM00 (0245) SUBROUTINE NORM(ICA,A,RN,P,N,NO,I,IB,NOR,NR) (0246) C*********************************************************************** (0247) C* (0248) C* NORM SEQUENTIALLY ADDS CONTRIBUTION OF DISTANCE, ANGLE AND AZIMUTH (0249) C* OBSERVATIONS TO THE NORMAL EQUATIONS (0250) C* (0251) C* (0252) C* INPUT: (0253) C* -ALL DESCRIBED IN MAIN (0254) C* (0255) C* (0256) C* WRITTEN BY: (0257) C* R.R. STEEVES, JUNE, 1976 (0258) C* (0259) C*********************************************************************** (0260) IMPLICIT REAL*8(A-H,O-Z) (0261) DIMENSION ICA(NOR,6),A(NOR,6),RN(NR,NR),IB(N) (0262) DO 1 L=1,6 (0263) DO 1 M=1,6 (0264) IF(ICA(I,L).GT.ICA(I,M))GOTO1 (0265) IF(ICA(I,L).EQ.0.OR.ICA(I,M).EQ.0)GOTO1 (0266) RN(ICA(I,L),ICA(I,M))=RN(ICA(I,L),ICA(I,M))+A(I,L)*A(I,M)*P (0267) IF(ICA(I,L).LT.IB(ICA(I,M)))IB(ICA(I,M))=ICA(I,L) (0268) 1 CONTINUE (0269) RETURN (0270) END PROGRAM SIZE: PROCEDURE - 000226 LINKAGE - 000024 STACK - 000114 A D ARGUMENT 000047 0245S 0261S 0266 I J ARGUMENT 000066 0245S 0264 0265 0266 0267 IB J ARGUMENT 000071 0245S 0261S 0267M ICA J ARGUMENT 000044 0245S 0261S 0264 0265 0266 0267 L J LINKAGE 000420 0262M 0264 0265 0266 0267 M J LINKAGE 000422 0263M 0264 0265 0266 0267 P D ARGUMENT 000055 0245S 0266 RN D ARGUMENT 000052 0245S 0261S 0266M $1 000172 0262 0263 0264 0265 0268D 0000 ERRORS [FTN-REV18.2] SUBROUTINE NORVEC(IOB,DOB,N,SPX,NP,IPX,ICP,RN,RU,A,ICA,AP,IC,IB, NORVEC (0271) SUBROUTINE NORVEC(IOB,DOB,N,SPX,NP,IPX,ICP,RN,RU,A,ICA,AP,IC,IB, (0272) @ NO,NS,NCODE,OX,NZERO,W,WX,NPR,NOR,NP2R,NR,NSR,ITER,ZER,CNAM,DOBR, (0273) @NFAC,FAC,N3DIM,DLDH) (0274) C*********************************************************************** (0275) C* (0276) C* NORVEC CONTROLS COMPUTATIONS IN FORMING THE NORMAL EQUATIONS AND THE (0277) C* CONSTANT VECTOR. IT ALSO CHECKS FOR VALID DIRECTION BUNDLE. ALSO (0278) C* PRINTS MISCLOSURES ON THE ZEROTH ITERATION. (0279) C* (0280) C* (0281) C* INPUT: (0282) C* -ALL DESCRIBED IN MAIN (0283) C* (0284) C* OUTPUT: (0285) C* -ALL DESCRIBED IN MAIN (0286) C* (0287) C* (0288) C* WRITTEN BY: (0289) C* R.R. STEEVES, JUNE, 1978 (0290) C* (0291) C*********************************************************************** (0292) IMPLICIT REAL*8(A-H,O-Z) (0293) DIMENSION IOB(NOR, 4),DOB(NOR,4),SPX(NP2R,NP2R),IPX(NPR),ICP(NR), (0294) @ RN(NR,NR),RU(NR),A(NOR,6),ICA(NOR,6),AP(NSR,12),IC(NSR,3),IB(NR), (0295) @ OX(NPR,2),W(NOR),WX(NP2R),CNAM(NSR),DOBR(NOR,4),FAC(5), (0296) @ DLDH(NOR,2) (0297) IF(ITER.GT.0)GOTO8 (0298) IF(NFAC.EQ.1)WRITE(6 ,169)FAC(1),FAC(5),(FAC(I),I=2,4) (0299) IF(NFAC.EQ.0)WRITE(6 ,107) (0300) 107 FORMAT('1') (0301) IF(NCODE.EQ.2)WRITE(6 ,104) (0302) IF(NCODE.EQ.1)WRITE(6 ,105) (0303) IF(NCODE.EQ.1)WRITE(6 ,106) (0304) IF(NCODE.EQ.2)WRITE(6 ,102) (0305) 8 I=1 (0306) C CHECK FOR DIRECTION BUNDLES OF ONE DIRECTION ONLY (0307) 1 IF(IOB(I,1).EQ.-2.OR.(IABS(IOB(I+1,1)).NE.2.AND.IOB(I,1).EQ.2)) (0308) @WRITE(6 , 101)I (0309) IF(IOB(I,1).EQ.-2.OR.(IABS(IOB(I+1,1)).NE.2.AND.IOB(I,1).EQ.2)) (0310) @STOP (0311) IG=IOB(I,1) (0312) GOTO(2,3,4,5),IG (0313) C ADD TO NORMAL AND CONSTANT VECTOR FOR DISTANCE OBSERVATIONS (0314) 2 CALL DIST(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS,NZERO, (0315) @ ITER,W,NOR,NSR,NR,ZER,CNAM,DOBR,N3DIM,DLDH) (0316) GOTO6 (0317) C ADD TO NORMAL AND CONSTANT VECTOR FOR DIRECTION OBSERVATIONS (0318) 3 CALL DIRN(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS,ITER,W, (0319) @ NOR,NSR,NR,CNAM,DOBR) (0320) GOTO6 (0321) C ADD TO NORMAL AND CONSTANT VECTOR FOR ANGLE OBSERVATIONS (0322) 4 CALL ANGL(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS,ITER,W, (0323) @ NOR,NSR,NR,CNAM,DOBR) (0324) GOTO6 (0325) C ADD TO NORMAL AND CONSTANT VECTOR FOR AZIMUTH OBSERVATIONS (0326) 5 CALL AZIM(NCODE,I,IOB,DOB,AP,A,RU,ICA,IB,RN,N,NO ,NS,ITER,W, (0327) @ NOR,NSR,NR,CNAM,DOBR) (0328) 6 IF(I.LE.NO)GOTO1 (0329) IF(NP.EQ.0)GOTO7 (0330) C ADD TO NORMAL AND CONSTANT VECTOR FOR WEIGHTED STATIONS (0331) CALL XOBS(NCODE,RN,RU,N,SPX,NP,IPX,ICP,AP,OX,IB,NS,IC,WX,NR,NP2R, (0332) @ NP2R,NSR,CNAM,NPR,NPR) (0333) C ADD TO NORMAL FOR HEIGHT OBSERVATIONS (0334) 7 CONTINUE (0335) IF(N3DIM.NE.2) GOTO 99 (0336) C CALL HOBS( ) (0337) 99 CONTINUE (0338) RETURN (0339) 101 FORMAT(' ','*** INPUT ERROR #008 *** OBSERVATION NO. ',I4,' IS FIR (0340) @ST AND POSSIBLY THE ONLY DIRECTION IN A BUNDLE,SHOULD HAVE CODE 2 (0341) @NOT -2') (0342) 102 FORMAT(' ',21X,'AT',8X,'FROM',6X,'TO',10X,'OBSERVED',4X,'STD.DEV', (0343) @3X,'REDUCED OBS', 3X,'MISCLOSURE',/) (0344) 104 FORMAT(' ',17X,'SUMMARY OF INPUT OBSERVATIONS, REDUCED OBSERVATION (0345) @S AND INITIAL MISCLOSURES:',/,' ',17X,75('-'),//) (0346) 105 FORMAT(' ',25X,'SUMMARY OF INPUT OBSERVATIONS AND THEIR STANDARD D (0347) @EVIATIONS:',/,' ',25X,60('-'),//) (0348) 106 FORMAT(' ',42X,'AT',9X,'FROM',7X,'TO',8X,'STD.DEV',/) (0349) 169 FORMAT('1',15X,12('*'),' FACTORS FOR INPUT STANDARD DEVIATIONS OF (0350) @OBSERVATIONS ',13('*'),/,' ',15X,'(DIST=',D10.3,' ,',D10.3,' ; DIR (0351) @=',D10.3,' ; ANG=',D10.3,' ; AZ =',D10.3,')',/) (0352) END PROGRAM SIZE: PROCEDURE - 001530 LINKAGE - 000054 STACK - 000216 A D ARGUMENT 000077 0271S 0293S 0314A 0318A 0322A 0326A ANGL D EXTERNAL 000000 0322 AP D ARGUMENT 000105 0271S 0293S 0314A 0318A 0322A 0326A 0331A AZIM D EXTERNAL 000000 0326 CNAM D ARGUMENT 000170 0271S 0293S 0314A 0318A 0322A 0326A 0331A DIRN D EXTERNAL 000000 0318 DIST D EXTERNAL 000000 0314 DLDH D ARGUMENT 000207 0271S 0293S 0314A DOB D ARGUMENT 000047 0271S 0293S 0314A 0318A 0322A 0326A DOBR D ARGUMENT 000173 0271S 0293S 0314A 0318A 0322A 0326A FAC D ARGUMENT 000201 0271S 0293S 0298 I J LINKAGE 000430 0298M 0305M 0307 0309 0311 0314A 0318A 0322A 0326A 0328 IABS J EXTERNAL 000000 0307 0309 IB J ARGUMENT 000113 0271S 0293S 0314A 0318A 0322A 0326A 0331A IC J ARGUMENT 000110 0271S 0293S 0331A ICA J ARGUMENT 000102 0271S 0293S 0314A 0318A 0322A 0326A ICP J ARGUMENT 000066 0271S 0293S 0331A IG J LINKAGE 000440 0311M 0312 IOB J ARGUMENT 000044 0271S 0293S 0307 0309 0311 0314A 0318A 0322A 0326A IPX J ARGUMENT 000063 0271S 0293S 0331A ITER J ARGUMENT 000162 0271S 0297 0314A 0318A 0322A 0326A N J ARGUMENT 000052 0271S 0314A 0318A 0322A 0326A 0331A N3DIM J ARGUMENT 000204 0271S 0314A 0335 NCODE J ARGUMENT 000124 0271S 0301 0302 0303 0304 0314A 0318A 0322A 0326A 0331A NFAC J ARGUMENT 000176 0271S 0298 0299 NO J ARGUMENT 000116 0271S 0314A 0318A 0322A 0326A 0328 NOR J ARGUMENT 000146 0271S 0293S 0314A 0318A 0322A 0326A NP J ARGUMENT 000060 0271S 0329 0331A NP2R J ARGUMENT 000151 0271S 0293S 0331A NPR J ARGUMENT 000143 0271S 0293S 0331A NR J ARGUMENT 000154 0271S 0293S 0314A 0318A 0322A 0326A 0331A NS J ARGUMENT 000121 0271S 0314A 0318A 0322A 0326A 0331A NSR J ARGUMENT 000157 0271S 0293S 0314A 0318A 0322A 0326A 0331A NZERO J ARGUMENT 000132 0271S 0314A OX D ARGUMENT 000127 0271S 0293S 0331A RN D ARGUMENT 000071 0271S 0293S 0314A 0318A 0322A 0326A 0331A RU D ARGUMENT 000074 0271S 0293S 0314A 0318A 0322A 0326A 0331A SPX D ARGUMENT 000055 0271S 0293S 0331A W D ARGUMENT 000135 0271S 0293S 0314A 0318A 0322A 0326A WX D ARGUMENT 000140 0271S 0293S 0331A XOBS D EXTERNAL 000000 0331 ZER D ARGUMENT 000165 0271S 0314A $1 000220 0307D 0328 $101 000776 0307 0339D $102 001102 0304 0342D $104 001163 0301 0344D $105 001253 0302 0346D $106 001333 0303 0348D $107 000114 0299 0300D $169 001364 0298 0349D $2 000415 0312 0314D $3 000500 0312 0318D $4 000553 0312 0322D $5 000626 0312 0326D $6 000700 0316 0320 0324 0328D $7 000766 0329 0334D $8 000214 0297 0305D $99 000775 0335 0337D 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE PBLANK(PLOTV) PBLANK (0001) SUBROUTINE PBLANK(PLOTV) (0002) C*********************************************************************** (0003) C* (0004) C* PBLANK CLEARS (SETS ELEMENTS TO BLANKS) VECTOR PLOTV, WHICH IS (0005) C* USED IN SUBROUTINE PLOT. (0006) C* (0007) C* (0008) C* WRITTEN BY: (0009) C* LAURIE PACH, JULY, 1978 (0010) C* (0011) C*********************************************************************** (0012) INTEGER PLOTV,BLNK (0013) DIMENSION PLOTV(110) (0014) DATA BLNK/' '/ (0015) DO 1 I=1,110 (0016) PLOTV(I)=BLNK (0017) 1 CONTINUE (0018) RETURN (0019) END PROGRAM SIZE: PROCEDURE - 000036 LINKAGE - 000024 STACK - 000050 BLNK J LINKAGE 000420 0012S 0014I 0016 I J LINKAGE 000422 0015M 0016 PLOTV J ARGUMENT 000042 0001S 0012S 0013S 0016M $1 000020 0015 0017D 0000 ERRORS [FTN-REV18.2] SUBROUTINE PLHXYZ(PHI,RLAM,H,XO,YO,ZO,A,B,X,Y,Z) PLHXYZ (0020) SUBROUTINE PLHXYZ(PHI,RLAM,H,XO,YO,ZO,A,B,X,Y,Z) (0021) C*********************************************************************** (0022) C* (0023) C* THIS ROUTINE COMPUTES THE CARTESIAN COORDINATES X,Y,Z GIVEN THE (0024) C* ELLIPSOIDAL COORDINATES PHI,RLAM,H. (0025) C* (0026) C* (0027) C* INPUT: (0028) C* PHI-ELLIPSOIDAL LATITUDE IN RADIANS. (0029) C* RLAM-ELLIPSOIDAL LONGITUDE IN RADIANS. (0030) C* (POSITIVE EAST OF GREENWICH) (0031) C* H-ELLIPSOIDAL HEIGHT IN METRES. (0032) C* XO,YO,ZO-TRANSLATION COMPONENTS FROM THE ORIGIN OF THE (0033) C* CARTESIAN COORDINATE SYTEM (X,Y,Z)TO THE CENTER (0034) C* OF THE REFERENCE ELLIPSOID. (IN METRES.) (0035) C* A,B-SEMI-MAJOR AND SEMI-MINOR AXES OF THE REFERENCE (0036) C* ELLIPSOID IN METRES. (0037) C* (0038) C* OUTPUT: (0039) C* X,Y,Z-CARTESIAN COORDINATES OF THE POINT IN METRES. (0040) C* (0041) C* (0042) C* WRITTEN BY: (0043) C* R.R. STEEVES, JUNE, 1977 (0044) C* (0045) C*********************************************************************** (0046) IMPLICIT REAL*8(A-Z) (0047) E2=(A*A-B*B)/(A*A) (0048) SP=DSIN(PHI) (0049) CP=DCOS(PHI) (0050) N=A/DSQRT(1.D0-E2*SP**2) (0051) X=XO+(N+H)*CP*DCOS(RLAM) (0052) Y=YO+(N+H)*CP*DSIN(RLAM) (0053) Z=ZO+(N*(1.D0-E2)+H)*SP (0054) RETURN (0055) END PROGRAM SIZE: PROCEDURE - 000150 LINKAGE - 000046 STACK - 000114 A D ARGUMENT 000064 0020S 0047 0050 B D ARGUMENT 000067 0020S 0047 CP D LINKAGE 000434 0049M 0051 0052 DCOS D EXTERNAL 000000 0049 0051 DCOS$X D EXTERNAL 000000 0055 DSIN D EXTERNAL 000000 0048 0052 DSIN$X D EXTERNAL 000000 0055 DSQR$X D EXTERNAL 000000 0055 DSQRT D EXTERNAL 000000 0050 E2 D LINKAGE 000420 0047M 0050 0053 H D ARGUMENT 000050 0020S 0051 0052 0053 N D LINKAGE 000442 0050M 0051 0052 0053 PHI D ARGUMENT 000042 0020S 0048A 0049A RLAM D ARGUMENT 000045 0020S 0051A 0052A SP D LINKAGE 000426 0048M 0050 0053 X D ARGUMENT 000072 0020S 0051M XO D ARGUMENT 000053 0020S 0051 Y D ARGUMENT 000075 0020S 0052M YO D ARGUMENT 000056 0020S 0052 Z D ARGUMENT 000100 0020S 0053M ZO D ARGUMENT 000061 0020S 0053 0000 ERRORS [FTN-REV18.2] SUBROUTINE PLOT(WINT,HVEC) (0056) SUBROUTINE PLOT(WINT,HVEC) (0057) C*********************************************************************** (0058) C* (0059) C* PLOT PLOTS THE STANDARD NORMAL CURVE OVERLAYED WITH THE HISTOGRAM OF (0060) C* STANDARD RESIDUALS. (0061) C* (0062) C* (0063) C* INPUT: (0064) C* WINT- NUMBER OF HISTOGRAM INTERVALS (0065) C* HVEC- VECTOR CONTAINING THE NUMBER OF RESIDUALS IN EACH HISTOG (0066) C* INTERVAL (0067) C* (0068) C* (0069) C* WRITTEN BY: (0070) C* LAURIE PACH, JULY, 1978 (0071) C* (0072) C*********************************************************************** (0073) INTEGER WINT,NVEC,RVEC,HVEC,STAR,HLINE,VLINE,PLOTV,PLOTL,PLOTH (0074) DIMENSION PLOTV(110),NVEC(53),PLOTL(110),PLOTH(110),RVEC(20), (0075) @ HVEC(20) (0076) DATA STAR,HLINE,VLINE/'.','-','I'/ (0077) DATA NVEC/22*0,4*1,2,2,3,4,4,5,6,8,9,10,12,14,16,17,19,21,23,25, (0078) @27,28,29,31,31,32,32,32,31/ (0079) MAX=50 (0080) A=.4 (0081) K=2 (0082) I=52 (0083) NUMR=0 (0084) KK=1 (0085) NVAL=32 (0086) NFLG=0 (0087) IF(WINT.EQ.20)INT=5 (0088) IF(WINT.EQ.10.OR.WINT.EQ.9)INT=10 (0089) IF(WINT.EQ.2)INT=50 (0090) IF(WINT.EQ.3)INT=30 (0091) IF(WINT.EQ.5)INT=20 (0092) IF(WINT.EQ.4)INT=25 (0093) WIDF=10./FLOAT(INT) (0094) CALL PBLANK(PLOTV) (0095) CALL PBLANK(PLOTH) (0096) CALL PBLANK(PLOTL) (0097) DO 2 JJ=1,WINT (0098) NUMR=NUMR+HVEC(JJ) (0099) 2 CONTINUE (0100) DO 33 JJ=1,WINT (0101) RVEC(JJ)=(80*HVEC(JJ)/NUMR)*WIDF+.5 (0102) 33 CONTINUE (0103) WRITE(6 ,103) (0104) DO 29 JJ=1,50 (0105) DO 28 N=1,WINT (0106) IF(RVEC(N).GE.MAX)GOTO19 (0107) 28 CONTINUE (0108) WRITE(6 ,104) (0109) IF(N.EQ.(WINT+1))N=WINT (0110) IF(MAX.EQ.32)GOTO21 (0111) MAX=MAX-1 (0112) 29 CONTINUE (0113) 19 RVEC(N)=0 (0114) MM=(INT*(N-1))+1 (0115) IF(WINT.EQ.9.OR.WINT.EQ.3)MM=(INT*(N-1))+6 (0116) PLOTL(MM)=VLINE (0117) III=INT-1 (0118) DO 12 JJ=1,III (0119) PLOTH(JJ+MM)=HLINE (0120) 12 CONTINUE (0121) PLOTL(MM+INT)=VLINE (0122) DO 32 N=1,WINT (0123) IF(RVEC(N).EQ.MAX.OR.RVEC(N).GT.50)GOTO19 (0124) 32 CONTINUE (0125) IF(NFLG.EQ.1)GOTO25 (0126) WRITE(6 ,101)(PLOTH(L),L=1,110) (0127) CALL PBLANK(PLOTH) (0128) CALL LPRNT(NVAL,MAX,PLOTL,RVEC,WINT,N,KK) (0129) IF(RVEC(N).EQ.MAX.AND.MAX.NE.32)GOTO19 (0130) 21 DO 31 L=2,100 (0131) PLOTV(I)=STAR (0132) IF(NVEC(I).NE.NVEC(I-1))GOTO4 (0133) K=K+1 (0134) I=I-1 (0135) 31 CONTINUE (0136) 4 I=I-1 (0137) NFLG=1 (0138) IF(RVEC(N).EQ.MAX)GOTO19 (0139) 25 DO 26 L=1,110 (0140) IF(PLOTH(L).EQ.HLINE)GOTO36 (0141) 26 CONTINUE (0142) GOTO38 (0143) 36 DO 39 L=1,110 (0144) IF(PLOTH(L).EQ.HLINE)PLOTV(L)=PLOTH(L) (0145) 39 CONTINUE (0146) 38 CALL PBLANK(PLOTH) (0147) 11 WRITE(6 ,102)(PLOTV(L),L=1,110) (0148) IF(MAX.EQ.32)WRITE(6 ,113)A (0149) IF(I.EQ.1)GOTO20 (0150) NVAL=NVEC(I) (0151) IF(NVAL.EQ.0)GOTO20 (0152) CALL PBLANK(PLOTV) (0153) DO 37 L=1,110 (0154) IF(PLOTL(L).EQ.VLINE)PLOTV(L)=PLOTL(L) (0155) 37 CONTINUE (0156) CALL LPRNT(NVAL,MAX,PLOTV,RVEC,WINT,N,KK) (0157) CALL PBLANK(PLOTV) (0158) DO 3 L=2,100 (0159) PLOTV(I)=STAR (0160) PLOTV(I+K)=STAR (0161) K=K+2 (0162) IF(I.EQ.1)GOTO11 (0163) IF(NVEC(I).NE.NVEC(I-1))GOTO4 (0164) I=I-1 (0165) 3 CONTINUE (0166) GOTO4 (0167) 20 WRITE(6 ,111) (0168) WRITE(6 ,112) (0169) IF(WINT.EQ.20)WRITE(6 ,107)(HVEC(L),L=1,20) (0170) IF(WINT.EQ.10)WRITE(6 ,106)(HVEC(L),L=1,10) (0171) IF(WINT.EQ.4)WRITE(6 ,108)(HVEC(L),L=1,4) (0172) IF(WINT.EQ.2)WRITE(6 ,109)(HVEC(L),L=1,2) (0173) IF(WINT.EQ.9)WRITE(6 ,116)(HVEC(L),L=1,9) (0174) IF(WINT.EQ.5)WRITE(6 ,114)(HVEC(L),L=1,5) (0175) IF(WINT.EQ.3)WRITE(6 ,115)(HVEC(L),L=1,3) (0176) 101 FORMAT(' ',6X,110A1) (0177) 102 FORMAT('+',6X,110A1) (0178) 103 FORMAT('1') (0179) 104 FORMAT(' ') (0180) 106 FORMAT(' ',8X,10(I4,6X),/) (0181) 107 FORMAT(' ',7X,20(I4,1X),/) (0182) 108 FORMAT(' ',15X,I4,3(21X,I4),/) (0183) 109 FORMAT(' ',34X,I4,36X,I4,/) (0184) 111 FORMAT(' ',6X,20('I----'),'I') (0185) 112 FORMAT(' ',5X,'-5',8X,'-4',8X,'-3',8X,'-2',8X,'-1',9X,'0',9X,'1' , (0186) @ 9X,'2',9X,'3',9X,'4',9X,'5',/) (0187) 113 FORMAT('+',3X,F3.1,'-') (0188) 114 FORMAT(' ',13X,I4,4(16X,I4),/) (0189) 115 FORMAT(' ',23X,3(I4,26X),/) (0190) 116 FORMAT(' ',14X,9(I4,6X),/) (0191) RETURN (0192) END PROGRAM SIZE: PROCEDURE - 002350 LINKAGE - 001550 STACK - 000056 A R LINKAGE 002100 0080M 0148 FLOAT R EXTERNAL 000000 0093 HLINE J LINKAGE 000424 0073S 0076I 0119 0140 0144 HVEC J ARGUMENT 000047 0056S 0073S 0074S 0098 0101 0169 0170 0171 0172 0173 0174 0175 I J LINKAGE 002104 0082M 0131 0132 0134M 0136M 0149 0150 0159 0160 0162 0163 0164M III J LINKAGE 002136 0117M 0118 INT J LINKAGE 002116 0087M 0088M 0089M 0090M 0091M 0092M 0093 0114 0115 0117 0121 JJ J LINKAGE 002124 0097M 0098 0100M 0101 0104M 0118M 0119 K J LINKAGE 002102 0081M 0133M 0160 0161M KK J LINKAGE 002110 0084M 0128A 0156A L J LINKAGE 002140 0126M 0130M 0139M 0140 0143M 0144 0147M 0153M 0154 0158M 0169M 0170M 0171M 0172M 0173M 0174M 0175M LPRNT J EXTERNAL 000000 0128 0156 MAX J LINKAGE 002076 0079M 0106 0110 0111M 0123 0128A 0129 0138 0148 0156A MM J LINKAGE 002134 0114M 0115M 0116 0119 0121 N J LINKAGE 002132 0105M 0106 0109M 0113 0114 0115 0122M 0123 0128A 0129 0138 0156A NFLG J LINKAGE 002114 0086M 0125 0137M NUMR J LINKAGE 002106 0083M 0098M 0101 NVAL J LINKAGE 002112 0085M 0128A 0150M 0151 0156A NVEC J LINKAGE 000430 0073S 0074S 0077I 0132 0150 0163 PBLANK R EXTERNAL 000000 0094 0095 0096 0127 0146 0152 0157 PLOTH J LINKAGE 000602 0073S 0074S 0095A 0119M 0126 0127A 0140 0144 0146A PLOTL J LINKAGE 001136 0073S 0074S 0096A 0116M 0121M 0128A 0154 PLOTV J LINKAGE 001472 0073S 0074S 0094A 0131M 0144M 0147 0152A 0154M 0156A 0157A 0159M 0160M RVEC J LINKAGE 002026 0073S 0074S 0101M 0106 0113M 0123 0128A 0129 0138 0156A STAR J LINKAGE 000422 0073S 0076I 0131 0159 0160 VLINE J LINKAGE 000426 0073S 0076I 0116 0121 0154 WIDF R LINKAGE 002120 0093M 0101 WINT J ARGUMENT 000044 0056S 0073S 0087 0088 0089 0090 0091 0092 0097 0100 0105 0109 0115 0122 0128A 0156A 0169 0170 0171 0172 0173 0174 0175 $101 002015 0126 0176D $102 002025 0147 0177D $103 002035 0103 0178D $104 002041 0108 0179D $106 002045 0170 0180D $107 002060 0169 0181D $108 002073 0171 0182D $109 002110 0172 0183D $11 001060 0147D 0162 $111 002124 0167 0184D $112 002141 0168 0185D $113 002217 0148 0187D $114 002231 0174 0188D $115 002246 0175 0189D $116 002262 0173 0190D $12 000511 0118 0120D $19 000412 0106 0113D 0123 0129 0138 $2 000221 0097 0099D $20 001336 0149 0151 0167D $21 000705 0110 0130D $25 000775 0125 0139D $26 001011 0139 0141D $28 000331 0105 0107D $29 000401 0104 0112D $3 001325 0158 0165D $31 000742 0130 0135D $32 000561 0122 0124D $33 000270 0100 0102D $36 001022 0140 0143D $37 001211 0153 0155D $38 001054 0142 0146D $39 001043 0143 0145D $4 000753 0132 0136D 0163 0166 0000 ERRORS [FTN-REV18.2] SUBROUTINE PLTSP (X,Y,XO,YO,KO,R,CHIO,SLAMO,CHI,SLAM) PLTSP0 (0193) SUBROUTINE PLTSP (X,Y,XO,YO,KO,R,CHIO,SLAMO,CHI,SLAM) (0194) C*********************************************************************** (0195) C* (0196) C* THIS ROUTINE TRANSFORMS STEREOGRAPHIC GRID COORDINATES X,Y TO (0197) C* SPHERICAL COORDINATES CHI,SLAM. (0198) C* (0199) C* (0200) C* INPUT: (0201) C* X - STEREOGRAPHIC GRID EASTING. (0202) C* Y - STEREOGRAPHIC GRID NORTHING. (0203) C* XO - FALSE EASTING. (0204) C* YO - FALSE NORTHING. (0205) C* KO - POINT SCALE FACTOR AT THE ORIGIN (FROM SPHERE TO (0206) C* PLANE). (0207) C* R - RADIUS OF THE SPHERE. (0208) C* CHIO - SPHERICAL LATITUDE OF THE ORIGIN, IN RADIANS. (0209) C* SLAMO - SPHERICAL LONGITUDE OF THE ORIGIN, IN RADIANS. (0210) C* (POSITIVE EAST OF GREENWICH.) (0211) C* (0212) C* OUTPUT: (0213) C* CHI - SPHERICAL LATITUDE OF THE POINT, IN RADIANS. (0214) C* SLAM - SPHERICAL LONGITUDE OF THE POINT, IN RADIANS. (0215) C* (0216) C* (0217) C* WRITTEN BY: (0218) C* R.R. STEEVES, JULY, 1977 (0219) C* (0220) C*********************************************************************** (0221) IMPLICIT REAL*8(A-H,O-Z) (0222) REAL*8 KO,K (0223) XX=(X-XO)/KO (0224) YY=(Y-YO)/KO (0225) S=DSQRT(XX**2+YY**2) (0226) DEL=2.D0*DATAN(S/2.D0/R) (0227) CB=1.D0 (0228) IF(S.GT.1.D-50)CB=XX/S (0229) SB=0.D0 (0230) IF(S.GT.1.D-50)SB=YY/S (0231) CD=DCOS(DEL) (0232) SD=DSIN(DEL) (0233) CHI=DARSIN(DSIN(CHIO)*CD+DCOS(CHIO)*SD*SB) (0234) SLAM=SLAMO+DARSIN(CB*SD/DCOS(CHI)) (0235) RETURN (0236) END PROGRAM SIZE: PROCEDURE - 000242 LINKAGE - 000072 STACK - 000104 CB D LINKAGE 000444 0227M 0228M 0234 CD D LINKAGE 000456 0231M 0233 CHI D ARGUMENT 000072 0193S 0233M 0234A CHIO D ARGUMENT 000064 0193S 0233A DARSIN D EXTERNAL 000000 0233 0234 DATAN D EXTERNAL 000000 0226 DATN$X D EXTERNAL 000000 0236 DCOS D EXTERNAL 000000 0231 0233 0234 DCOS$X D EXTERNAL 000000 0236 DEL D LINKAGE 000440 0226M 0231A 0232A DSIN D EXTERNAL 000000 0232 0233 DSIN$X D EXTERNAL 000000 0236 DSQR$X D EXTERNAL 000000 0236 DSQRT D EXTERNAL 000000 0225 KO D ARGUMENT 000056 0193S 0222S 0223 0224 R D ARGUMENT 000061 0193S 0226 S D LINKAGE 000432 0225M 0226 0228 0230 SB D LINKAGE 000450 0229M 0230M 0233 SD D LINKAGE 000464 0232M 0233 0234 SLAM D ARGUMENT 000075 0193S 0234M SLAMO D ARGUMENT 000067 0193S 0234 X D ARGUMENT 000042 0193S 0223 XO D ARGUMENT 000050 0193S 0223 XX D LINKAGE 000420 0223M 0225 0228 Y D ARGUMENT 000045 0193S 0224 YO D ARGUMENT 000053 0193S 0224 YY D LINKAGE 000424 0224M 0225 0230 0000 ERRORS [FTN-REV18.2] SUBROUTINE PRAR(ARRAY,RDIM,CDIM,R,C,ICODE,CNAM,NS,ITER, PRAR00 (0237) SUBROUTINE PRAR(ARRAY,RDIM,CDIM,R,C,ICODE,CNAM,NS,ITER, (0238) @ IOB,NOR,IC,NSR,ICA,RU,W,CPX,NP,WX,NR,NP2R,NPR,NO) (0239) C*********************************************************************** (0240) C* (0241) C* PRAR PRINTS VARIOUS INTERMEDIATE RESULTS ON REQUEST. (0242) C* (0243) C* (0244) C* INPUT: (0245) C* ARRAY- MATRIX OR VECTOR TO BE PRINTED (0246) C* RDIM- ROW DIMENSIONS OF ARRAY (0247) C* CDIM- COLUMN DIMENSIONS OF ARRAY (0248) C* R,C- ROW AND COLUMN SIZES OF ACTUAL MATRIX OR VECTOR TO BE PR (0249) C* ICODE- CODE OF MATRIX OR VECTOR TO BE PRINTED. EACH CODE FOLLOW (0250) C* = 1- DESIGN MATRIX A (0251) C* =21- NORMAL EQUATIONS (0252) C* =22- CHOLESKI SQUARE ROOT (0253) C* =23- INVERSE OF NORMAL EQUATIONS (COVARIANCE MATRIX OF PARAME (0254) C* =24- COVARIANCE MATRIX OF WEIGHTED STATIONS (0255) C* =25- WEIGHT MATRIX OF WEIGHTED STATIONS (0256) C* =26- BLAHA WEIGHT MATRIX (0257) C* =27- BLAHA COVARIANCE MATRIX (0258) C* = 3- CONSTANT VECTOR (0259) C* = 4- MISCLOSURE VECTOR (0260) C* OTHERS- DESCRIBED IN MAIN (0261) C* (0262) C* (0263) C* OUTPUT: (0264) C* PRINTED MATRIX OR VECTOR ACCORDING TO ICODE. (0265) C* (0266) C* (0267) C* WRITTEN BY: (0268) C* LAURIE PACH, JUNE, 1978 (0269) C* (0270) C*********************************************************************** (0271) IMPLICIT REAL*8(A-H,O-Z) (0272) INTEGER ROW,R,C,RDIM,CDIM,FLAG,IVC(200) (0273) INTEGER C1 (0274) DIMENSION ARRAY(RDIM,CDIM),CNAM(NSR),IOB(NOR,4),IC(NSR,3),ICA(NOR (0275) @,6),RU(NR),W(NOR),WX(NP2R),CPX(NPR),LCC(6) (0276) DATA FB,BL/'FIXED',' '/ (0277) IF(ICODE.EQ.1)WRITE(6 ,10)ITER (0278) IF(ICODE.EQ.21)WRITE(6 ,11)ITER (0279) IF(ICODE.EQ.22)WRITE(6 ,14)ITER (0280) IF(ICODE.EQ.23)WRITE(6 ,15) (0281) IF(ICODE.EQ.3)WRITE(6 ,12)ITER (0282) IF(ICODE.EQ.4)WRITE(6 ,13)ITER (0283) IF(ICODE.EQ.24)WRITE(6 ,64) (0284) IF(ICODE.EQ.25)WRITE(6 ,65) (0285) IF(ICODE.EQ.26)WRITE(6 ,118) (0286) IF(ICODE.EQ.27)WRITE(6 ,119) (0287) M=1 (0288) DO 41 N=1,NS (0289) IF(IC(N,1).EQ.0)GOTO41 (0290) IVC(M)=N (0291) M=M+1 (0292) 41 CONTINUE (0293) NC=M-1 (0294) C (0295) IF(ICODE.NE.1)GOTO60 (0296) N=1 (0297) DO 20 ROW=1,R (0298) FB1=BL (0299) IF(IC(IOB(ROW,2),1).EQ.0)FB1=FB (0300) FB2=BL (0301) IF(IC(IOB(ROW,3),1).EQ.0)FB2=FB (0302) FB3=BL (0303) IF(IOB(ROW,1).NE.3)GOTO32 (0304) IF(IC(IOB(ROW,4),1).EQ.0)FB3=FB (0305) 32 ID=IOB(ROW,1) (0306) IF(ID.EQ.1)WRITE(6 ,25)CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2 (0307) IF(ID.EQ.1.AND.ICA(ROW,5).NE.0)WRITE(6 ,26) (0308) IF(IABS(ID).EQ.2)WRITE(6 ,27)N,CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW (0309) @,3)), (0310) @ FB2 (0311) IF(ID.EQ.2)N=N+1 (0312) IF(ID.EQ.-2)N=1 (0313) IF(ID.EQ.3)WRITE(6 ,28)CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2 (0314) @,CNAM (0315) @ (IOB(ROW,4)),FB3 (0316) IF(ID.EQ.4)WRITE(6 ,29)CNAM(IOB(ROW,2)),FB1,CNAM(IOB(ROW,3)),FB2 (0317) I=ROW (0318) ID1=4 (0319) IF(IOB(I,1).EQ.1.AND.ICA(I,5).NE.0)ID1=5 (0320) IF(IOB(I,1).EQ.1.AND.ICA(I,6).NE.0)ID1=6 (0321) IF(IOB(I,1).EQ.3)ID1=6 (0322) WRITE(6 , 30)(ARRAY(ROW,L),L=1,ID1) (0323) WRITE(6 , 31) (0324) 20 CONTINUE (0325) RETURN (0326) 60 IF(ICODE.NE.21.AND.ICODE.NE.22.AND.ICODE.NE.23)GOTO70 (0327) I=1 (0328) LL=0 (0329) IF(((C/2)*2).NE.C)LL=1 (0330) J=1 (0331) FLAG=0 (0332) 7 K=J+49 (0333) N=0 (0334) NCC=0 (0335) C1=0 (0336) 6 IF(N+3.GT.NC)GOTO16 (0337) IF(FLAG.EQ.0)GOTO38 (0338) WRITE(6 ,23)CNAM(IVC(N+1)),CNAM(IVC(N+2)),CNAM(IVC(N+3)) (0339) WRITE(6 ,95) (0340) DO 210 L=1,6 (0341) 210 LCC(L)=NCC+L (0342) WRITE(6 ,110)(LCC(L),L=1,6) (0343) 42 DO 5 I=J,K (0344) WRITE(6 ,3)I,(ARRAY(I,C1+L),L=1,6) (0345) IF(I.EQ.R)GOTO4 (0346) 5 CONTINUE (0347) 4 C1=C1+6 (0348) N=N+3 (0349) NCC=NCC+6 (0350) GOTO6 (0351) 16 IF(N+3-NC.EQ.1)GOTO8 (0352) IF(N+3-NC.EQ.2)GOTO9 (0353) IF(LL.EQ.1)GOTO104 (0354) IF(N.EQ.NC.AND.I.EQ.R)RETURN (0355) J=J+50 (0356) GOTO7 (0357) 8 IF(FLAG.EQ.0)GOTO43 (0358) WRITE(6 ,2)CNAM(IVC(N+1)),CNAM(IVC(N+2)) (0359) IF(LL.EQ.1)WRITE(6 ,101) (0360) WRITE(6 ,96) (0361) DO 211 L=1,4 (0362) 211 LCC(L)=NCC+L (0363) WRITE(6 ,111)(LCC(L),L=1,4) (0364) 46 DO 17 I=J,K (0365) WRITE(6 ,18)I,(ARRAY(I,C1+L),L=1,4) (0366) IF(LL.EQ.1)WRITE(6 ,98)ARRAY(I,C1+5) (0367) IF(I.EQ.R)RETURN (0368) 17 CONTINUE (0369) J=J+50 (0370) GOTO7 (0371) 43 WRITE(6 ,44)CNAM(IVC(N+1)),CNAM(IVC(N+2)) (0372) IF(LL.EQ.1)WRITE(6 ,101) (0373) WRITE(6 ,96) (0374) DO 212 L=1,4 (0375) 212 LCC(L)=NCC+L (0376) WRITE(6 ,111)(LCC(L),L=1,4) (0377) FLAG=1 (0378) GOTO46 (0379) 9 IF(FLAG.EQ.0)GOTO47 (0380) WRITE(6 ,19)CNAM(IVC(N+1)) (0381) IF(LL.EQ.1)WRITE(6 ,102) (0382) WRITE(6 ,97) (0383) DO 213 L=1,2 (0384) 213 LCC(L)=NCC+L (0385) WRITE(6 ,112)(LCC(L),L=1,2) (0386) 49 DO 200 I=J,K (0387) WRITE(6 ,37)I,ARRAY(I,C1+1),ARRAY(I,C1+2) (0388) IF(LL.EQ.1)WRITE(6 ,99)ARRAY(I,C1+3) (0389) IF(I.EQ.R)RETURN (0390) 200 CONTINUE (0391) J=J+50 (0392) GOTO7 (0393) 47 WRITE(6 ,48)CNAM(IVC(N+1)) (0394) WRITE(6 ,97) (0395) DO 214 L=1,2 (0396) 214 LCC(L)=NCC+6 (0397) WRITE(6 ,112)(LCC(L),L=1,2) (0398) FLAG=1 (0399) GOTO49 (0400) 104 WRITE(6 ,103) (0401) DO 105 I=J,K (0402) WRITE(6 , 106)I,ARRAY(I,C1+1) (0403) IF(I.EQ.R)RETURN (0404) 105 CONTINUE (0405) J=J+50 (0406) GOTO7 (0407) 38 WRITE(6 ,39)CNAM(IVC(N+1)),CNAM(IVC(N+2)),CNAM(IVC(N+3)) (0408) WRITE(6 ,95) (0409) DO 215 L=1,6 (0410) 215 LCC(L)=L+NCC (0411) WRITE(6 ,110)(LCC(L),L=1,6) (0412) FLAG=1 (0413) GOTO42 (0414) C (0415) 70 IF(ICODE.NE.3)GOTO80 (0416) WRITE(6 ,50) (0417) I1=1 (0418) DO 51 I=1,NC (0419) WRITE(6 ,52)I,CNAM(IVC(I)),RU(I1),RU(I1+1) (0420) I1=I1+2 (0421) 51 CONTINUE (0422) RETURN (0423) 80 IF(ICODE.NE.4)GOTO90 (0424) I=1 (0425) WRITE(6 ,53) (0426) DO 54 J=1,NO (0427) IF(IOB(J,1).EQ.1)WRITE(6 ,55)CNAM(IOB(J,2)),CNAM(IOB(J,2)), (0428) @CNAM(IOB(J,3)),W(J) (0429) IF(IOB(J,1).EQ.3)WRITE(6 ,56)CNAM(IOB(J,2)),CNAM(IOB(J,3)), (0430) @ CNAM(IOB(J,4)),W(J) (0431) IF(IOB(J,1).EQ.4)WRITE(6 ,57)CNAM(IOB(J,2)),CNAM(IOB(J,2)), (0432) @ CNAM(IOB(J,3)),W(J) (0433) IF(IOB(J,1).EQ.2.OR.IOB(J,1).EQ.-2)GOTO58 (0434) GOTO54 (0435) 58 WRITE(6 ,59)I,CNAM(IOB(J,2)),CNAM(IOB(J,2)),CNAM(IOB(J,3)),W(J) (0436) I=I+1 (0437) IF(IOB(J,1).EQ.-2)I=1 (0438) 54 CONTINUE (0439) K=2*NP (0440) J=1 (0441) IF(NP.EQ.0)RETURN (0442) DO 61 I=1,K,2 (0443) WRITE(6 ,62)CPX(J),WX(I) (0444) WRITE(6 ,63)WX(I+1) (0445) J=J+1 (0446) 61 CONTINUE (0447) RETURN (0448) 90 IF(ICODE.NE.24.AND.ICODE.NE.25.AND.ICODE.NE.26.AND.ICODE.NE.27) (0449) @GOTO100 (0450) I=1 (0451) J=1 (0452) FLAG=0 (0453) 66 K=J+49 (0454) N=0 (0455) NCC=0 (0456) C1=0 (0457) 67 IF(N+3.GT.NP)GOTO68 (0458) IF(FLAG.EQ.0)GOTO69 (0459) WRITE(6 , 71)CPX(N+1),CPX(N+2),CPX(N+3) (0460) WRITE(6 ,95) (0461) DO 216 L=1,6 (0462) 216 LCC(L)=L+NCC (0463) WRITE(6 ,110)(LCC(L),L=1,6) (0464) 72 DO 75 I=J,K (0465) WRITE(6 , 73)I,(ARRAY(I,C1+L),L=1,6) (0466) IF(I.EQ.R)GOTO74 (0467) 75 CONTINUE (0468) 74 C1=C1+6 (0469) N=N+3 (0470) NCC=NCC+6 (0471) GOTO67 (0472) 68 IF(N+3-NP.EQ.1)GOTO76 (0473) IF(N+3-NP.EQ.2)GOTO77 (0474) IF(N.EQ.NP.AND.I.EQ.R)RETURN (0475) J=J+50 (0476) GOTO66 (0477) 76 IF(FLAG.EQ.0)GOTO83 (0478) WRITE(6 ,78)CPX(N+1),CPX(N+2) (0479) WRITE(6 ,96) (0480) DO 217 L=1,6 (0481) 217 LCC(L)=L+NCC (0482) WRITE(6 ,111)(LCC(L),L=1,6) (0483) 79 DO 81 I=J,K (0484) WRITE(6 ,82)I,(ARRAY(I,C1+L),L=1,4) (0485) IF(I.EQ.R)RETURN (0486) 81 CONTINUE (0487) J=J+50 (0488) GOTO66 (0489) 83 WRITE(6 ,84)CPX(N+1),CPX(N+2) (0490) WRITE(6 ,96) (0491) DO 218 L=1,4 (0492) 218 LCC(L)=L+NCC (0493) WRITE(6 ,111)(LCC(L),L=1,4) (0494) FLAG=1 (0495) GOTO79 (0496) 77 IF(FLAG.EQ.0)GOTO85 (0497) WRITE(6 ,86)CPX(N+1) (0498) WRITE(6 ,97) (0499) DO219 L=1,2 (0500) 219 LCC(L)=L+NCC (0501) WRITE(6 ,112)(LCC(L),L=1,2) (0502) 87 DO 88 I=J,K (0503) WRITE(6 ,89)I,ARRAY(I,C1+1),ARRAY(I,C1+2) (0504) IF(I.EQ.R)RETURN (0505) 88 CONTINUE (0506) J=J+50 (0507) GOTO66 (0508) 85 WRITE(6 ,91)CPX(N+1) (0509) WRITE(6 ,97) (0510) DO 220 L=1,2 (0511) 220 LCC(L)=L+NCC (0512) WRITE(6 ,112)(LCC(L),L=1,2) (0513) FLAG=1 (0514) GOTO87 (0515) 69 WRITE(6 ,92)CPX(N+1),CPX(N+2),CPX(N+3) (0516) WRITE(6 ,95) (0517) DO 221 L=1,6 (0518) 221 LCC(L)=L+NCC (0519) WRITE(6 ,110)(LCC(L),L=1,6) (0520) FLAG=1 (0521) GOTO72 (0522) 2 FORMAT('1',7X,2(10('#'),1X,A8,1X,10('#'),4X)) (0523) 3 FORMAT(' ',1X,I3,2X,3(D15.8,1X,D15.8,3X)) (0524) 10 FORMAT('1',39X,'DESIGN MATRIX A (ITERATION #',I3,')',/,' ',39X, (0525) @ 32('-'),//) (0526) 11 FORMAT('1',35X,'NORMAL EQUATION MATRIX (ITERATION #',I3,')',/, (0527) @ ' ',35X,39('-'),/) (0528) 12 FORMAT('1',34X,'CONSTANT VECTOR ELEMENTS (ITERATION #',I3,')', (0529) @ /,' ',34X,41('-'),//) (0530) 13 FORMAT('1',33X,'MISCLOSURE VECTOR ELEMENTS (ITERATION #',I3,')', (0531) @ /,' ',33X,43('-'),//) (0532) 14 FORMAT('1',36X,'CHOLESKI SQUARE ROOT (ITERATION #',I3,')',/, (0533) @ ' ',36X,37('-'),/) (0534) 15 FORMAT('1',37X,'COVARIANCE MATRIX OF THE PARAMETERS',/,38X,35('-') (0535) @,//) (0536) 18 FORMAT(' ',1X,I3,2X,2(D15.8,1X,D15.8,3X)) (0537) 19 FORMAT('1',7X,10('#'),1X,A8,1X,10('#')) (0538) 23 FORMAT('1',7X,3(10('#'),1X,A8,1X,10('#'),4X),//) (0539) 25 FORMAT(' ','DISTANCE',6X,A8,4X,'(X,Y)',2X,A5,9X,A8,4X,'(X,Y)', (0540) @ 2X,A5,9X) (0541) 26 FORMAT('+',80X,'ZERO ERROR') (0542) 27 FORMAT(' ','DIRECTION',I3,2X,A8,4X,'(X,Y)',2X,A5,9X,A8,4X,'(X,Y)', (0543) @ 2X,A5,9X) (0544) 28 FORMAT(' ','ANGLE',9X,A8,4X,'(X,Y)',2X,A5,9X,A8,4X,'(X,Y)',2X,A5, (0545) @ 9X,A8,4X,'(X,Y)',2X,A5,9X) (0546) 29 FORMAT(' ','AZIMUTH',7X,A8,4X,'(X,Y)',2X,A5,9X,A8,4X,'(X,Y)', (0547) @ 2X,A5,9X) (0548) 30 FORMAT(' ',10X,3(3X,D14.7,2X,D14.7)) (0549) 31 FORMAT(' ',/) (0550) 37 FORMAT(' ',1X,I3,2X,D15.8,1X,D15.8) (0551) 39 FORMAT(' ',7X,3(10('#'),1X,A8,1X,10('#'),4X),//) (0552) 44 FORMAT(' ',7X,2(10('#'),1X,A8,1X,10('#'),4X)) (0553) 48 FORMAT(' ',7X,10('#'),1X,A8,1X,10('#'),//) (0554) 50 FORMAT(' ',32X,'STATION',12X,'(X)',14X,'(Y)',/) (0555) 52 FORMAT(' ',28X,I3,1X,A8,5X,D15.8,3X,D15.8,/) (0556) 53 FORMAT(' ',38X,'AT',9X,'FROM',7X,'TO',10X,'MISCLOSURE',//) (0557) 55 FORMAT(' ',24X,'DISTANCE',6X,A8,3X,A8,3X,A8,3X,D15.8,/) (0558) 56 FORMAT(' ',24X,'ANGLE',9X,A8,3X,A8,3X,A8,3X,D15.8,/) (0559) 57 FORMAT(' ',24X,'AZIMUTH',7X,A8,3X,A8,3X,A8,3X,D15.8,/) (0560) 59 FORMAT(' ',24X,'DIRECTION ',I2,2X,A8,3X,A8,3X,A8,3X,D15.8,/) (0561) 62 FORMAT(' ',24X,'COORDINATES',3X,A8,1X,18('.'),'(X)',3X,D15.8) (0562) 63 FORMAT(' ',65X,'(Y)',3X,D15.8,/) (0563) 64 FORMAT('1',42X,'A PRIORI COVARIANCE MATRIX',/,' ',42X,26('-'),/) (0564) 65 FORMAT('1',44X,'A PRIORI WEIGHT MATRIX',/,' ',44X,22('-'),/) (0565) 71 FORMAT('1',7X,3(10('#'),1X,A8,1X,10('#'),4X),//) (0566) 73 FORMAT(' ',1X,I3,2X,3(D15.8,1X,D15.8,3X)) (0567) 78 FORMAT('1',7X,2(10('#'),1X,A8,1X,10('#'),4X)) (0568) 82 FORMAT(' ',1X,I3,2X,2(D15.8,1X,D15.8,3X)) (0569) 84 FORMAT(' ',7X,2(10('#'),1X,A8,1X,10('#'),4X),//) (0570) 86 FORMAT('1',7X,10('#'),1X,A8,1X,10('#')) (0571) 89 FORMAT(' ',1X,I3,2X,D15.8,1X,D15.8) (0572) 91 FORMAT(' ',7X,10('#'),1X,A8,1X,10('#'),//) (0573) 92 FORMAT(' ',7X,3(10('#'),1X,A8,1X,10('#'),4X),//) (0574) 95 FORMAT(' ',13X,3('X',14X,'Y',18X),/) (0575) 96 FORMAT(' ',/,' ',13X,2('X',14X,'Y',18X),/) (0576) 97 FORMAT(' ',/,' ',13X,'X',14X,'Y',/) (0577) 98 FORMAT('+',74X,D15.8) (0578) 99 FORMAT('+',40X,D15.8) (0579) 101 FORMAT('+',75X,'# ZERO ERROR #') (0580) 102 FORMAT('+',40X,'# ZERO ERROR #') (0581) 103 FORMAT('1',7X,'# ZERO ERROR #',//) (0582) 106 FORMAT(' ',1X,I3,2X,D15.8) (0583) 110 FORMAT(' ',9X,3('(COL',I4,')',7X,'(COL',I4,')',8X),/) (0584) 111 FORMAT(' ',9X,2('(COL',I4,')',7X,'(COL',I4,')',8X),/) (0585) 112 FORMAT(' ',9X,'(COL',I4,')',7X,'(COL',I4,')',/) (0586) 118 FORMAT('1',45X,'BLAHA WEIGHT MATRIX',/,' ',45X,19('-'),/) (0587) 119 FORMAT('1',43X,'BLAHA COVARIANCE MATRIX',/,' ',43X,23('-'),/) (0588) 100 RETURN (0589) END PROGRAM SIZE: PROCEDURE - 012012 LINKAGE - 000752 STACK - 000160 ARRAY D ARGUMENT 000046 0237S 0274S 0322 0344 0365 0366 0387 0388 0402 0465 0484 0503 BL D LINKAGE 000430 0276I 0298 0300 0302 C J ARGUMENT 000062 0237S 0272S 0329 C1 J LINKAGE 001346 0273S 0335M 0344 0347M 0365 0366 0387 0388 0402 0456M 0465 0468M 0484 0503 CNAM D ARGUMENT 000070 0237S 0274S 0306 0308 0313 0316 0338 0358 0371 0380 0393 0407 0419 0427 0429 0431 0435 CPX D ARGUMENT 000126 0237S 0274S 0443 0459 0478 0489 0497 0508 0515 FB D LINKAGE 000424 0276I 0299 0301 0304 FB1 D LINKAGE 001306 0298M 0299M 0306 0308 0313 0316 FB2 D LINKAGE 001312 0300M 0301M 0306 0308 0313 0316 FB3 D LINKAGE 001316 0302M 0304M 0313 FLAG J LINKAGE 001340 0272S 0331M 0337 0357 0377M 0379 0398M 0412M 0452M 0458 0477 0494M 0496 0513M 0520M I J LINKAGE 001326 0317M 0319 0320 0321 0327M 0343M 0344 0345 0354 0364M 0365 0366 0367 0386M 0387 0388 0389 0401M 0402 0403 0418M 0419 0424M 0435 0436M 0437M 0442M 0443 0444 0450M 0464M 0465 0466 0474 0483M 0484 0485 0502M 0503 0504 I1 J LINKAGE 001350 0417M 0419 0420M IABS J EXTERNAL 000000 0308 IC J ARGUMENT 000107 0237S 0274S 0289 0299 0301 0304 ICA J ARGUMENT 000115 0237S 0274S 0307 0319 0320 ICODE J ARGUMENT 000065 0237S 0277 0278 0279 0280 0281 0282 0283 0284 0285 0286 0295 0326 0415 0423 0448 ID J LINKAGE 001322 0305M 0306 0307 0308 0311 0312 0313 0316 ID1 J LINKAGE 001330 0318M 0319M 0320M 0321M 0322 IOB J ARGUMENT 000101 0237S 0274S 0299 0301 0303 0304 0305 0306 0308 0313 0316 0319 0320 0321 0427 0429 0431 0433 0435 0437 ITER J ARGUMENT 000076 0237S 0277 0278 0279 0281 0282 IVC J LINKAGE 000434 0272S 0290M 0338 0358 0371 0380 0393 0407 0419 J J LINKAGE 001336 0330M 0332 0343 0355M 0364 0369M 0386 0391M 0401 0405M 0426M 0427 0429 0431 0433 0435 0437 0440M 0443 0445M 0451M 0453 0464 0475M 0483 0487M 0502 0506M K J LINKAGE 001342 0332M 0343 0364 0386 0401 0439M 0442 0453M 0464 0483 0502 L J LINKAGE 001332 0322M 0340M 0341 0342M 0344M 0361M 0362 0363M 0365M 0374M 0375 0376M 0383M 0384 0385M 0395M 0396 0397M 0409M 0410 0411M 0461M 0462 0463M 0465M 0480M 0481 0482M 0484M 0491M 0492 0493M 0499M 0500 0501M 0510M 0511 0512M 0517M 0518 0519M LCC J LINKAGE 001254 0274S 0341M 0342 0362M 0363 0375M 0376 0384M 0385 0396M 0397 0410M 0411 0462M 0463 0481M 0482 0492M 0493 0500M 0501 0511M 0512 0518M 0519 LL J LINKAGE 001334 0328M 0329M 0353 0359 0366 0372 0381 0388 M J LINKAGE 001276 0287M 0290 0291M 0293 N J LINKAGE 001300 0288M 0289 0290 0296M 0308 0311M 0312M 0333M 0336 0338 0348M 0351 0352 0354 0358 0371 0380 0393 0407 0454M 0457 0459 0469M 0472 0473 0474 0478 0489 0497 0508 0515 NC J LINKAGE 001302 0293M 0336 0351 0352 0354 0418 NCC J LINKAGE 001344 0334M 0341 0349M 0362 0375 0384 0396 0410 0455M 0462 0470M 0481 0492 0500 0511 0518 NO J ARGUMENT 000150 0237S 0426 NP J ARGUMENT 000131 0237S 0439 0441 0457 0472 0473 0474 NS J ARGUMENT 000073 0237S 0288 R J ARGUMENT 000057 0237S 0272S 0297 0345 0354 0367 0389 0403 0466 0474 0485 0504 ROW J LINKAGE 001304 0272S 0297M 0299 0301 0303 0304 0305 0306 0307 0308 0313 0316 0317 0322 RU D ARGUMENT 000120 0237S 0274S 0419 W D ARGUMENT 000123 0237S 0274S 0427 0429 0431 0435 WX D ARGUMENT 000134 0237S 0274S 0443 0444 $10 007412 0277 0524D $100 011745 0448 0588D $101 011457 0359 0372 0579D $102 011475 0381 0580D $103 011513 0400 0581D $104 003603 0353 0400D $105 003671 0401 0404D $106 011532 0402 0582D $11 007455 0278 0526D $110 011545 0342 0411 0463 0519 0583D $111 011576 0363 0376 0482 0493 0584D $112 011627 0385 0397 0501 0512 0585D $118 011655 0285 0586D $119 011710 0286 0587D $12 007523 0281 0528D $13 007573 0282 0530D $14 007644 0279 0532D $15 007711 0280 0534D $16 002262 0336 0351D $17 002670 0364 0368D $18 007752 0365 0536D $19 007775 0380 0537D $2 007342 0358 0522D $20 001616 0297 0324D $200 003427 0386 0390D $210 002051 0340 0341D $211 002444 0361 0362D $212 003015 0374 0375D $213 003174 0383 0384D $214 003514 0395 0396D $215 004020 0409 0410D $216 005643 0461 0462D $217 006203 0480 0481D $218 006462 0491 0492D $219 006616 0499 0500D $220 007065 0510 0511D $221 007253 0517 0518D $23 010017 0338 0538D $25 010045 0306 0539D $26 010107 0307 0541D $27 010123 0308 0542D $28 010167 0313 0544D $29 010243 0316 0546D $3 007367 0344 0523D $30 010304 0322 0548D $31 010324 0323 0549D $32 000536 0303 0305D $37 010331 0387 0550D $38 003711 0337 0407D $39 010351 0407 0551D $4 002237 0345 0347D $41 000322 0288 0289 0292D $42 002133 0343D 0413 $43 002710 0357 0371D $44 010377 0371 0552D $46 002526 0364D 0378 $47 003447 0379 0393D $48 010424 0393 0553D $49 003256 0386D 0399 $5 002226 0343 0346D $50 010447 0416 0554D $51 004235 0418 0421D $52 010475 0419 0555D $53 010521 0425 0556D $54 005300 0426 0434 0438D $55 010554 0427 0557D $56 010606 0429 0558D $57 010636 0431 0559D $58 005072 0433 0435D $59 010667 0435 0560D $6 001726 0336D 0350 $60 001630 0295 0326D $61 005434 0442 0446D $62 010723 0443 0561D $63 010760 0444 0562D $64 010776 0283 0563D $65 011034 0284 0564D $66 005513 0453D 0476 0488 0507 $67 005530 0457D 0471 $68 006054 0457 0472D $69 007154 0458 0515D $7 001711 0332D 0356 0370 0392 0406 $70 004107 0326 0415D $71 011070 0459 0565D $72 005725 0464D 0521 $73 011116 0465 0566D $74 006031 0466 0468D $75 006020 0464 0467D $76 006117 0472 0477D $77 006551 0473 0496D $78 011141 0478 0567D $79 006265 0483D 0495 $8 002333 0351 0357D $80 004247 0415 0423D $81 006362 0483 0486D $82 011166 0484 0568D $83 006402 0477 0489D $84 011211 0489 0569D $85 007024 0496 0508D $86 011237 0497 0570D $87 006700 0502D 0514 $88 007004 0502 0505D $89 011261 0503 0571D $9 003104 0352 0379D $90 005446 0423 0448D $91 011301 0508 0572D $92 011324 0515 0573D $95 011352 0339 0408 0460 0516 0574D $96 011372 0360 0373 0479 0490 0575D $97 011415 0382 0394 0498 0509 0576D $98 011435 0366 0577D $99 011446 0388 0578D 0000 ERRORS [FTN-REV18.2] SUBROUTINE PRES(IDF,S0,NO,IOB,DOB,ZER,V,NV,CNAM,NSR,DOBR,NOR, PRES00 (0590) SUBROUTINE PRES(IDF,S0,NO,IOB,DOB,ZER,V,NV,CNAM,NSR,DOBR,NOR, (0591) @ NSRES) (0592) C*********************************************************************** (0593) C* (0594) C* PRES COMPUTES ADUSTED OBSERVATIONS AND APPROXIMATE STANDARD DEVIATIO (0595) C* OF RESIDUALS IF REQUESTED. ALSO PRINTS THIS INFORMATION. STANDARDIZ (0596) C* RESIDUALS. (0597) C* (0598) C* (0599) C* INPUT: (0600) C* -ALL DESCRIBED IN MAIN (0601) C* (0602) C* (0603) C* WRITTEN BY: (0604) C* R.R. STEEVES, JULY, 1978 (0605) C* (0606) C*********************************************************************** (0607) IMPLICIT REAL*8(A-H,O-Z) (0608) DIMENSION IOB(NOR,4),DOB(NOR,4),DOBR(NOR,4),V(NV),CNAM(NSR) (0609) PI2=2.D0*3.141592653589793D0 (0610) RO=1296.D3/PI2 (0611) I=1 (0612) FACV=1.0D0 (0613) IF(NSRES.EQ.1)FACV=DSQRT(S0/NO) (0614) WRITE(6 , 109) (0615) WRITE(6 , 104) (0616) 16 IFR=IOB(I,2) (0617) IT1=IOB(I,3) (0618) IT2=IOB(I,4) (0619) IDEG=DOB(I,2) (0620) IMIN=DOB(I,3) (0621) SEC=DOB(I,4) (0622) IG=IOB(I,1) (0623) GOTO(17,18,21,22),IG (0624) 17 ADJ=DOB(I,3)+V(I)+ZER (0625) STD=DOBR(I,1) (0626) DOB(I,1)=FACV*STD (0627) WRITE(6 , 105)I,CNAM(IFR),CNAM(IFR),CNAM(IT1), DOB(I,3) , STD, (0628) @V(I),DOB(I,1),ADJ (0629) GOTO23 (0630) 18 J=1 (0631) 19 IDEG=DOB(I,2) (0632) IMIN=DOB(I,3) (0633) IFR=IOB(I,2) (0634) IT1=IOB(I,3) (0635) SEC=DOB(I,4) (0636) IF(J.NE.1)GOTO31 (0637) IDA=DOB(I,2) (0638) IMA=DOB(I,3) (0639) SA=DOB(I,4) (0640) V1=V(I) (0641) GOTO32 (0642) 31 ADJ=V(I)-V1 (0643) CALL DMSRAD(IDEG,IMIN,SEC,RA) (0644) RA=RA+ADJ/RO (0645) IF(RA.LT.0.D0)RA=RA+PI2 (0646) CALL RADMS(RA,IDA,IMA,SA) (0647) 32 CONTINUE (0648) STD=DOBR(I,1) (0649) DOB(I,1)=FACV*STD (0650) WRITE(6 ,106)I,J,CNAM(IFR),CNAM(IFR),CNAM(IT1),IDEG,IMIN,SEC, (0651) @STD,V(I),DOB(I,1),IDA,IMA,SA (0652) IF(IOB(I,1).EQ.-2)GOTO23 (0653) I=I+1 (0654) J=J+1 (0655) GOTO19 (0656) 21 ADJ=V(I) (0657) STD=DOBR(I,1) (0658) DOB(I,1)=FACV*STD (0659) CALL DMSRAD(IDEG,IMIN,SEC,RA) (0660) RA=RA+ADJ/RO (0661) IF(RA.LT.0.D0)RA=RA+PI2 (0662) CALL RADMS(RA,IDA,IMA,SA) (0663) WRITE(6 ,107)I,CNAM(IFR),CNAM(IT1),CNAM(IT2),IDEG,IMIN,SEC, (0664) @ STD,V(I),DOB(I,1),IDA,IMA,SA (0665) GOTO23 (0666) 22 ADJ=V(I) (0667) STD=DOBR(I,1) (0668) DOB(I,1)=FACV*STD (0669) CALL DMSRAD(IDEG,IMIN,SEC,RA) (0670) RA=RA+ADJ/RO (0671) IF(RA.LT.0.D0)RA=RA+PI2 (0672) CALL RADMS(RA,IDA,IMA,SA) (0673) WRITE(6 ,108)I,CNAM(IFR),CNAM(IFR),CNAM(IT1),IDEG,IMIN,SEC, (0674) @STD,V(I),DOB(I,1),IDA,IMA,SA (0675) 23 I=I+1 (0676) IF(I.LE.NO)GOTO16 (0677) 104 FORMAT(' ',20X,'AT',8X,'FROM',6X,'TO',9X,'REDUCED OBS',2X,'STD.DEV (0678) @',2X,'RESIDUAL',2X,'STD.DEV',3X,'ADJ.OBSERVATION',/) (0679) 105 FORMAT(' ',I4,2X,'DISTANCE',6X,A8,2X,A8,2X,A8,F12.4,F10.4,F10.4, (0680) @F9.4,F15.4,/) (0681) 106 FORMAT(' ',I4,2X,'DIRECTION',I3,2X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2, (0682) @ F9.2,F9.2,I9,I3,F6.2,/) (0683) 107 FORMAT(' ',I4,2X,'ANGLE',9X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2, (0684) @ F9.2,F9.2,I9,I3,F6.2,/) (0685) 108 FORMAT(' ',I4,2X,'AZIMUTH',7X,A8,2X,A8,2X,A8,I5,I3,F6.2,F8.2, (0686) @ F9.2,F9.2,I9,I3,F6.2,/) (0687) 109 FORMAT('1',21X,'SUMMARY OF REDUCED OBSERVATIONS, RESIDUALS AND ADJ (0688) @USTED OBSERVATIONS:',/,' ',21X,68('-'),//) (0689) RETURN (0690) END PROGRAM SIZE: PROCEDURE - 002610 LINKAGE - 000134 STACK - 000126 ADJ D LINKAGE 000472 0624M 0627 0642M 0644 0656M 0660 0666M 0670 CNAM D ARGUMENT 000072 0590S 0608S 0627 0650 0663 0673 DMSRAD D EXTERNAL 000000 0643 0659 0669 DOB D ARGUMENT 000056 0590S 0608S 0619 0620 0621 0624 0626M 0627 0631 0632 0635 0637 0638 0639 0649M 0650 0658M 0663 0668M 0673 DOBR D ARGUMENT 000100 0590S 0608S 0625 0648 0657 0667 DSQR$X D EXTERNAL 000000 0614 DSQRT D EXTERNAL 000000 0613 FACV D LINKAGE 000436 0612M 0613M 0626 0649 0658 0668 I J LINKAGE 000434 0611M 0616 0617 0618 0619 0620 0621 0622 0624 0625 0626 0627 0631 0632 0633 0634 0635 0637 0638 0639 0640 0642 0648 0649 0650 0652 0653M 0656 0657 0658 0663 0666 0667 0668 0673 0675M 0676 IDA J LINKAGE 000510 0637M 0646A 0650 0662A 0663 0672A 0673 IDEG J LINKAGE 000460 0619M 0631M 0643A 0650 0659A 0663 0669A 0673 IFR J LINKAGE 000452 0616M 0627 0633M 0650 0663 0673 IG J LINKAGE 000470 0622M 0623 IMA J LINKAGE 000512 0638M 0646A 0650 0662A 0663 0672A 0673 IMIN J LINKAGE 000462 0620M 0632M 0643A 0650 0659A 0663 0669A 0673 IOB J ARGUMENT 000053 0590S 0608S 0616 0617 0618 0622 0633 0634 0652 IT1 J LINKAGE 000454 0617M 0627 0634M 0650 0663 0673 IT2 J LINKAGE 000456 0618M 0663 J J LINKAGE 000506 0630M 0636 0650 0654M NO J ARGUMENT 000050 0590S 0613 0676 NSRES J ARGUMENT 000106 0590S 0613 PI2 D LINKAGE 000424 0609M 0610 0645 0661 0671 RA D LINKAGE 000526 0643A 0644M 0645M 0646A 0659A 0660M 0661M 0662A 0669A 0670M 0671M 0672A RADMS D EXTERNAL 000000 0646 0662 0672 RO D LINKAGE 000430 0610M 0644 0660 0670 S0 D ARGUMENT 000045 0590S 0613 SA D LINKAGE 000514 0639M 0646A 0650 0662A 0663 0672A 0673 SEC D LINKAGE 000464 0621M 0635M 0643A 0650 0659A 0663 0669A 0673 STD D LINKAGE 000476 0625M 0626 0627 0648M 0649 0650 0657M 0658 0663 0667M 0668 0673 V D ARGUMENT 000064 0590S 0608S 0624 0627 0640 0642 0650 0656 0663 0666 0673 V1 D LINKAGE 000520 0640M 0642 ZER D ARGUMENT 000061 0590S 0624 $104 002147 0615 0677D $105 002240 0627 0679D $106 002305 0650 0681D $107 002360 0663 0683D $108 002427 0673 0685D $109 002477 0614 0687D $16 000070 0616D 0676 $17 000257 0623 0624D $18 000534 0623 0630D $19 000540 0631D 0655 $21 001307 0623 0656D $22 001622 0623 0666D $23 002134 0629 0652 0665 0675D $31 000726 0636 0642D $32 001007 0641 0647D 0000 ERRORS [FTN-REV18.2] SUBROUTINE PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSRPRIT00 (0691) SUBROUTINE PRIT(TL,NCODE,NF,CNF,NP,CPX,NS,CNAM,AP,NP2R,NPR,NFR,NSR (0692) @,NFIX,NPROJ,NUNIT,NELPS,NSTAN,ALPH,NFAC,NZERO,NTEST,NCOV, (0693) @ NCORR,NMULT,NITER,NDELX,NCRIT,CONVG,NRED1,NRED2,NCENT,CENT, (0694) @ NRED3,I12,NB,CBH,NBR,ZER,NCOVB,IBH,IPX,AA,BB,RP,RL,XO,YO,X1,Y1, (0695) @Z1,RKO,IDF,NUTM,N3DIM) (0696) C*********************************************************************** (0697) C* (0698) C* PRIT PRINTS TITLE PAGE, INITIAL AND ADJUSTED COORDINATES. (0699) C* (0700) C* (0701) C* INPUT: (0702) C* -ALL DESCRIBED IN MAIN (0703) C* (0704) C* OUTPUT: (0705) C* -ALL DESCRIBED IN MAIN (0706) C* (0707) C* (0708) C* WRITTEN BY: (0709) C* R.R. STEEVES, JUNE, 1978 (0710) C* (0711) C*********************************************************************** (0712) IMPLICIT REAL*8(A-H,O-Z) (0713) C LOGICAL DATE(18),TIME(6) (0714) INTEGER*2 IDAT(3),ITIME(2),IUSER(3) (0715) DIMENSION TL(10),CNF(NFR),CPX(NPR),CNAM(NSR),AP(NSR,12), (0716) @ NFIX(NFR),CBH(NBR),IBH(NBR),CENT(4),IPX(NPR) (0717) DATA ADJ1,ADJ2,PRE1,PRE2,Z4,Z5,UF,UM,ALL1,ALL2,ABS1,ABS2,REL1,REL2 (0718) @,ANSY,ANSN,XTAU1,XTAU2,XNOR1,XNOR2/'.... AD','JUSTMENT','... PRE (0719) @','ANALYSIS','R ZONE 4','R ZONE 5','.. FOOT','. METRE','........ (0720) @','... ALL','. ABSOL','UTE ONLY','. RELAT','IVE ONLY',' YES',' (0721) @ NO',' MAX','IMUM TAU',' MAXIMU','M NORMAL'/ (0722) DATA RNON,BLNK/'NONE ',' '/ (0723) DATA TAU1,TAU2,RNOR1,RNOR2,ST1,ST2,XST1,XST2/' TAU (','NON-MAX)' (0724) @,'NORMAL (','NON-MAX)',' ST','UDENTS-T',' STUDEN','TS-T MAX' (0725) @/ (0726) IF(I12.EQ.2)GOTO50 (0727) WRITE(6 ,110) (0728) WRITE(6 ,101) (0729) WRITE(6 , 102) (0730) WRITE(6 , 103)(TL(I),I=1,10) (0731) WRITE(6 , 102) (0732) WRITE(6 , 101) (0733) C CALL GDATE(DATE,TIME) (0734) C WRITE(6,701)(DATE(I),I=1,18),(TIME(I),I=1,6) (0735) (0736) C PRINT DATE, TIME AND USERNAME (0737) CALL TIMREG(IDAT,ITIME,IUSER) (0738) WRITE(6,6001)IDAT,ITIME,IUSER (0739) 6001 FORMAT(' DATUM: ',A2,'. ',A2,'. ',A2,/' ZEIT : ',I2,'.',I2,/ (0740) 1' USER: ',3A2/) (0741) (0742) WRITE(6 , 153) (0743) WRITE(6 , 154) (0744) IF(NCODE.EQ.1)WRITE(6 , 155)PRE1,PRE2 (0745) IF(NCODE.EQ.2)WRITE(6 , 155)ADJ1,ADJ2 (0746) WRITE(6 ,503) (0747) WRITE(6 ,157) (0748) MAX=MAX0(NF,NP,NB) (0749) IF(NF.EQ.0)WRITE(6 ,501)RNON,BLNK,BLNK (0750) IF(NP.EQ.0)WRITE(6 ,501)BLNK,RNON,BLNK (0751) IF(NB.EQ.0)WRITE(6 ,501)BLNK,BLNK,RNON (0752) IF(MAX.EQ.0)GOTO208 (0753) DO 502 I=1,MAX (0754) IF(I.LE.NF)WRITE(6 ,501)CNF(I),BLNK,BLNK (0755) IF(I.LE.NP)WRITE(6 ,501)BLNK,CPX(I),BLNK (0756) IF(I.LE.NB)WRITE(6 ,501)BLNK,BLNK,CBH(I) (0757) WRITE(6 ,503) (0758) 502 CONTINUE (0759) 208 WRITE(6 ,503) (0760) IF(NCOV.EQ.1.AND.NP.NE.0)WRITE(6 ,173) (0761) IF(NCOV.EQ.0.AND.NP.NE.0)WRITE(6 ,172) (0762) IF(NCOVB.EQ.1.AND.NB.NE.0)WRITE(6 ,187) (0763) IF(NCOVB.EQ.0.AND.NB.NE.0)WRITE(6 ,188) (0764) IF(NPROJ.EQ.5.AND.NCODE.EQ.2)WRITE(6 ,159)Z5 (0765) IF(NPROJ.EQ.4.AND.NCODE.EQ.2)WRITE(6 ,159)Z4 (0766) IF(NPROJ.EQ.3.AND.NCODE.EQ.2)WRITE(6 ,156) (0767) IF(NPROJ.EQ.2.AND.NCODE.EQ.2)WRITE(6 ,161) (0768) IF(NPROJ.EQ.1.AND.NCODE.EQ.2)WRITE(6 ,162) (0769) IF(NUNIT.EQ.0)WRITE(6 ,163)UM (0770) IF(NUNIT.EQ.1)WRITE(6 ,163)UF (0771) IF(NZERO.EQ.1)WRITE(6 ,170)ANSY (0772) IF(NTEST.EQ.0.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)XTAU1,XTA (0773) @U2 (0774) IF(NTEST.EQ.1.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)TAU1,TAU2 (0775) IF(NTEST.EQ.2.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)XNOR1,XNO (0776) @R2 (0777) IF(NTEST.EQ.3.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)RNOR1,RNO (0778) @R2 (0779) IF(NTEST.EQ.4.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)ST1,ST2 (0780) IF(NTEST.EQ.5.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,171)XST1,XST2 (0781) IF(NMULT.EQ.0.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,175)ANSN (0782) IF(NMULT.EQ.1.AND.NCODE.EQ.2.AND.IDF.NE.0)WRITE(6 ,175)ANSY (0783) IF(NCODE.EQ.2)WRITE(6 ,176)NITER (0784) IF(NCODE.EQ.2)WRITE(6 ,179)CONVG (0785) IF(NRED1.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,180)ANSN (0786) IF(NRED1.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,180)ANSY (0787) IF(NRED2.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,181)ANSN (0788) IF(NRED2.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,181)ANSY (0789) IF(NRED3.EQ.0.AND.NCODE.EQ.2.AND.NPROJ.NE.3)WRITE(6 ,184)ANSN (0790) IF(NRED3.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3.AND.(NRED1.EQ.1.OR. (0791) @NRED2.EQ.1))WRITE(6 ,184)ANSY (0792) IF(NRED3.EQ.1.AND.NCODE.EQ.2.AND.NPROJ.NE.3.AND.NRED1.EQ.0.AND. (0793) @NRED2.EQ.0)WRITE(6 ,184)ANSN (0794) IF(NCENT.EQ.1)WRITE(6 ,183)(CENT(I),I=1,4) (0795) IF(N3DIM.NE.0) WRITE(6,191) ANSY (0796) IF(N3DIM.EQ.0) WRITE(6,191) ANSN (0797) IF(N3DIM.EQ.2) WRITE(6,192) ANSY (0798) 191 FORMAT(' ',15X,'3-DIM. ADJUSTMENT',58('.'),1X,A4,/) (0799) 192 FORMAT(' ',15X,'COV.-MATRIX OF HEIGHTS READ',48('.'),1X,A4/) (0800) IF(NPROJ.NE.3.AND.NCODE.EQ.2)CALL PROINF(NPROJ,AA,BB,RP,RL,XO, (0801) @YO,X1,Y1,Z1,RKO,NUNIT,NUTM) (0802) IF(I12.EQ.1)WRITE(6 ,107) (0803) 50 IF(I12.EQ.2)WRITE(6 ,207) (0804) WRITE(6 ,111) (0805) IF(NPROJ.NE.3)GOTO300 (0806) WRITE(6 ,108) (0807) DO 3 I=1,NS (0808) IF(NP.EQ.0)GOTO601 (0809) DO 602 K=1,NP (0810) IF(I.EQ.IPX(K))GOTO3 (0811) 602 CONTINUE (0812) 601 IF(NF.EQ.0)GOTO8 (0813) DO 5 K=1,NF (0814) IF(I.EQ.NFIX(K))GOTO3 (0815) 5 CONTINUE (0816) 8 IF(NB.EQ.0)GOTO4 (0817) DO 7 K=1,NB (0818) IF(I.EQ.IBH(K))GOTO3 (0819) 7 CONTINUE (0820) 4 WRITE(6 , 109)CNAM(I),(AP(I,J),J=1,2) (0821) 3 CONTINUE (0822) IF(NF.EQ.0.AND.NB.EQ.0.AND.NP.EQ.0)GOTO1 (0823) IF(NF.EQ.0)GOTO6 (0824) WRITE(6 ,104) (0825) WRITE(6 ,108) (0826) DO 2 I=1,NF (0827) WRITE(6 ,109)CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,2) (0828) 2 CONTINUE (0829) 6 IF(NP.EQ.0)GOTO603 (0830) WRITE(6 ,604) (0831) WRITE(6 ,108) (0832) DO 605 I=1,NP (0833) WRITE(6 ,109)CNAM(IPX(I)),(AP(IPX(I),J),J=1,2) (0834) 605 CONTINUE (0835) 603 IF(NB.EQ.0)GOTO1 (0836) WRITE(6 ,404) (0837) WRITE(6 ,108) (0838) DO 405 I=1,NB (0839) WRITE(6 ,109)CNAM(IBH(I)),(AP(IBH(I),J),J=1,2) (0840) 405 CONTINUE (0841) GOTO1 (0842) 300 IF(I12.EQ.1)WRITE(6 ,201) (0843) IF(I12.EQ.2)WRITE(6 ,202) (0844) DO 303 I=1,NS (0845) IF(NF.EQ.0)GOTO406 (0846) DO 305 K=1,NF (0847) IF(I.EQ.NFIX(K))GOTO303 (0848) 305 CONTINUE (0849) 406 IF(NP.EQ.0)GOTO606 (0850) DO 607 K=1,NP (0851) IF(I.EQ.IPX(K))GOTO303 (0852) 607 CONTINUE (0853) 606 IF(NB.EQ.0)GOTO304 (0854) DO 9 K=1,NB (0855) IF(I.EQ.IBH(K))GOTO303 (0856) 9 CONTINUE (0857) 304 CALL RADMS(AP(I,9),IDP,IMP,SP) (0858) CALL RADMS(AP(I,10),IDL,IML,SL) (0859) CALL RADMS(AP(I,12),IDC,IMC,SC) (0860) IF(I12.EQ.1)WRITE(6 ,209)CNAM(I),(AP(I,J),J=1,6),IDP,IMP,SP,IDL, (0861) @IML, (0862) @ SL,AP(I,11),IDC,IMC,SC (0863) IF(I12.EQ.2)WRITE(6 ,210)CNAM(I),(AP(I,J),J=1,2),IDP,IMP,SP,IDL, (0864) @IML, (0865) @ SL,AP(I,11),IDC,IMC,SC,AP(I,3) (0866) 303 CONTINUE (0867) IF(NF.EQ.0.AND.NB.EQ.0.AND.NP.EQ.0)GOTO1 (0868) IF(NF.EQ.0)GOTO10 (0869) WRITE(6 ,104) (0870) IF(I12.EQ.1)WRITE(6 ,201) (0871) IF(I12.EQ.2)WRITE(6 ,202) (0872) DO 302 I=1,NF (0873) CALL RADMS(AP(NFIX(I),9),IDP,IMP,SP) (0874) CALL RADMS(AP(NFIX(I),10),IDL,IML,SL) (0875) CALL RADMS(AP(NFIX(I),12),IDC,IMC,SC) (0876) IF(I12.EQ.1)WRITE(6 , 209)CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,6),ID (0877) @P,IMP, (0878) @ SP,IDL,IML,SL,AP(NFIX(I),11),IDC,IMC,SC (0879) IF(I12.EQ.2)WRITE(6 ,210)CNAM(NFIX(I)),(AP(NFIX(I),J),J=1,2),IDP (0880) @,IMP, (0881) @ SP,IDL,IML,SL,AP(NFIX(I),11),IDC,IMC,SC,AP(NFIX(I),3) (0882) 302 CONTINUE (0883) 10 IF(NP.EQ.0)GOTO608 (0884) WRITE(6 ,604) (0885) IF(I12.EQ.1)WRITE(6 ,201) (0886) IF(I12.EQ.2)WRITE(6 ,202) (0887) DO 609 I=1,NP (0888) CALL RADMS(AP(IPX(I),9),IDP,IMP,SP) (0889) CALL RADMS(AP(IPX(I),10),IDL,IML,SL) (0890) CALL RADMS(AP(IPX(I),12),IDC,IMC,SC) (0891) IF(I12.EQ.1)WRITE(6 ,209)CNAM(IPX(I)),(AP(IPX(I),J),J=1,6),IDP,I (0892) @MP, (0893) @ SP,IDL,IML,SL,AP(IPX(I),11),IDC,IMC,SC (0894) IF(I12.EQ.2)WRITE(6 ,210)CNAM(IPX(I)),(AP(IPX(I),J),J=1,2),IDP, (0895) @ IMP,SP,IDL,IML,SL,AP(IPX(I),11),IDC,IMC,SC (0896) 609 CONTINUE (0897) 608 IF(NB.EQ.0)GOTO1 (0898) WRITE(6 ,404) (0899) IF(I12.EQ.1)WRITE(6 ,201) (0900) IF(I12.EQ.2)WRITE(6 ,202) (0901) DO 11 I=1,NB (0902) CALL RADMS(AP(IBH(I),9),IDP,IMP,SP) (0903) CALL RADMS(AP(IBH(I),10),IDL,IML,SL) (0904) CALL RADMS(AP(IBH(I),12),IDC,IMC,SC) (0905) IF(I12.EQ.1)WRITE(6 ,209)CNAM(IBH(I)),(AP(IBH(I),J),J=1,6),IDP,I (0906) @MP, (0907) @ SP,IDL,IML,SL,AP(IBH(I),11),IDC,IMC,SC (0908) IF(I12.EQ.2)WRITE(6 ,210)CNAM(IBH(I)),(AP(IBH(I),J),J=1,2),IDP,I (0909) @MP, (0910) @ SP,IDL,IML,SL,AP(IBH(I),11),IDC,IMC,SC (0911) 11 CONTINUE (0912) 1 IF(I12.EQ.2.AND.NZERO.EQ.1)WRITE(6 ,211) ZER (0913) 101 FORMAT(' ',2X,106('*')) (0914) 102 FORMAT(' ',2X,'*',104X,'*') (0915) 103 FORMAT(' ',2X,'*',12X,10A8,12X,'*') (0916) 104 FORMAT(' ',/,' ',47X,'FIXED STATIONS:',/,' ',47X,14('-'),/) (0917) 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 (0918) @I N A T E S',/,' ',22X,61('-'),//) (0919) 108 FORMAT(' ',25X,' STATION ',13X,'X (E)',13X,'Y (N)',/) (0920) 109 FORMAT(' ',29X,A8,5X,F15.4,3X,F15.4,/) (0921) 110 FORMAT('1') (0922) 111 FORMAT(' ',47X,'FREE STATIONS:',/,' ',47X,13('-'),/) (0923) 211 FORMAT(' ',/,' ',40X,'ZERO ERROR=',F9.4) (0924) 153 FORMAT(' ',/) (0925) 154 FORMAT(' ',39X,'O P T I O N S I N E F F E C T',/' ',39X,31('-'), (0926) @ /) (0927) 155 FORMAT(' ',15X,'PREANALYSIS OR ADJUSTMENT ',38('.'),2A8,/) (0928) 156 FORMAT(' ',15X,'MAP PROJECTION ',59('.'), 2X,'NONE',/) (0929) 157 FORMAT(' ',15X,'FIXED STATIONS',18X,'WEIGHTED STATIONS',17X,'BLAHA (0930) @ STATIONS'//) (0931) 159 FORMAT(' ',15X,'MAP PROJECTION ',16('.'),2X, (0932) @ 'NOVA SCOTIA 3 DEGREE TRANSVERSE MERCATO',A8,/) (0933) 161 FORMAT(' ',15X,'MAP PROJECTION ',24('.'),'PRINCE EDWARD ISLAND DOU (0934) @BLE STEREOGRAPHIC',/) (0935) 162 FORMAT(' ',15X,'MAP PROJECTION ',31('.'),'NEW BRUNSWICK DOUBLE STE (0936) @REOGRAPHIC',/) (0937) 163 FORMAT(' ',15X,'CONVENTIONAL LINEAR UNIT ',47('.'),A8,/) (0938) 170 FORMAT(' ',15X,'ZERO ERROR ESTIMATED FOR DISTANCE OBSERVATIONS? ' (0939) @ ,27('.'),1X,A4,/) (0940) 171 FORMAT(' ',15X,'TEST USED FOR REJECTION OF RESIDUALS ',27('.'), (0941) @ 2A8,/) (0942) 172 FORMAT(' ',15X,'WEIGHTED WEIGHT OR COVARIANCE MATRIX READ?', (0943) @ 19('.'),2X,'COVARIANCE MATRIX',/) (0944) 173 FORMAT(' ',15X,'WEIGHTED WEIGHT OR COVARIANCE MATRIX READ',23('.') (0945) @ ,2X,'WEIGHT MATRIX',/) (0946) 175 FORMAT(' ',15X,'MULTIPLY INVERSE OF NORMAL EQUATIONS BY ESTIMATED (0947) @VARIANCE FACTOR? ',8('.'),1X,A4,/) (0948) 176 FORMAT(' ',15X,'MAXIMUM NUMBER OF ITERATIONS ALLOWED ',38('.'), (0949) @ 2X,I3,/) (0950) 179 FORMAT(' ',15X,'CRITERION FOR SOLUTION CONVERGENCE ',34('.'), (0951) @ F11.6,/) (0952) 180 FORMAT(' ',15X,'MAKE OBSERVATION REDUCTIONS (TERRAIN TO ELLIPSOID) (0953) @?' ,24('.'),1X,A4,/) (0954) 181 FORMAT(' ',15X,'MAKE OBSERVATION REDUCTIONS (ELLIPSOID TO MAPPING (0955) @PLANE)? ',17('.'),1X,A4,/) (0956) 183 FORMAT(' ',15X,'CENTERING ERROR FOR OBSERVATIONS ',11('.'), (0957) @ 4(2X,F7.4),/) (0958) 184 FORMAT(' ',15X,'REDUCTIONS FROM TERRIAN TO MAPPING PLANE MADE FOR (0959) @AZIMUTHS ',16('.'),1X,A4,/) (0960) 187 FORMAT(' ',15X,'BLAHA WEIGHT OR COVARIANCE MATRIX READ',27('.'), (0961) @ 2X,'WEIGHT MATRIX',/) (0962) 188 FORMAT(' ',15X,'BLAHA WEIGHT OR COVARIANCE MATRIX READ?',22('.'), (0963) @ 2X,'COVARIANCE MATRIX',/) (0964) 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 (0965) @S',/,' ',27X,51('-'),//) (0966) 201 FORMAT(' ',15X,'X',11X,'Y',5X,'ORTHOMETRIC GEOID DEFLECTION',28X (0967) @,'POINT',4X,'MERIDIAN',/,' ','STATION',4X,'(EASTING)',2X,'(NORTHIN (0968) @G)',3X,'HEIGHT',4X,'HEIGHT',2X,'COMPONENTS',2X,'LATITUDE',6X, (0969) @ 'LONGITUDE',3X,'SCALE',2X,'CONVERGENCE',/) (0970) 202 FORMAT(' ',22X,'X',12X,'Y',46X,'POINT',8X,'MERIDIAN',/,' ',7X, (0971) @ 'STATION',4X,'(EASTING)',4X,'(NORTHING)',6X,'LATITUDE',10X, (0972) @ 'LONGITUDE',8X,'SCALE',6X,'CONVERGENCE',6X,'HEIGHT'/) (0973) 209 FORMAT(' ',A8,2F12.3,F10.3,F9.3,2F6.1,I3,I3,F6.2,I5,I3,F6.2,F9.6, (0974) @ I3,I3,F5.1,/) (0975) 210 FORMAT(' ',7X,A8,2F13.4,I6,I3,F9.5,I7,I3,F9.5,F12.7,I5,I3,F6.2, (0976) @ 2X,F12.4/) (0977) 404 FORMAT(' ',/,' ',47X,'BLAHA STATIONS:',/,' ',47X,14('-'),/) (0978) 501 FORMAT('+',18X,A8,26X,A8,24X,A8) (0979) 503 FORMAT(' ') (0980) 604 FORMAT(' ',/,' ',45X,'WEIGHTED STATIONS:',/,' ',45X,17('-'),/) (0981) 701 FORMAT(' ',40X,18A1,4X,2A1,':',2A1,':',2A1) (0982) RETURN (0983) END PROGRAM SIZE: PROCEDURE - 012566 LINKAGE - 000310 STACK - 000320 AA D ARGUMENT 000244 0691S 0800A ABS1 D LINKAGE 000474 0717I ABS2 D LINKAGE 000500 0717I ADJ1 D LINKAGE 000424 0717I 0745 ADJ2 D LINKAGE 000430 0717I 0745 ALL1 D LINKAGE 000464 0717I ALL2 D LINKAGE 000470 0717I ANSN D LINKAGE 000520 0717I 0781 0785 0787 0789 0792 0796 ANSY D LINKAGE 000514 0717I 0771 0782 0786 0788 0790 0795 0797 AP D ARGUMENT 000076 0691S 0715S 0820 0827 0833 0839 0857A 0858A 0859A 0860 0863 0873A 0874A 0875A 0876 0879 0888A 0889A 0890A 0891 0894 0902A 0903A 0904A 0905 0908 BB D ARGUMENT 000247 0691S 0800A BLNK D LINKAGE 000550 0722I 0749 0750 0751 0754 0755 0756 CBH D ARGUMENT 000222 0691S 0715S 0756 CENT D ARGUMENT 000206 0691S 0715S 0794 CNAM D ARGUMENT 000073 0691S 0715S 0820 0827 0833 0839 0860 0863 0876 0879 0891 0894 0905 0908 CNF D ARGUMENT 000057 0691S 0715S 0754 CONVG D ARGUMENT 000172 0691S 0784 CPX D ARGUMENT 000065 0691S 0715S 0755 I J LINKAGE 000632 0730M 0753M 0754 0755 0756 0794M 0807M 0810 0814 0818 0820 0826M 0827 0832M 0833 0838M 0839 0844M 0847 0851 0855 0857 0858 0859 0860 0863 0872M 0873 0874 0875 0876 0879 0887M 0888 0889 0890 0891 0894 0901M 0902 0903 0904 0905 0908 I12 J ARGUMENT 000214 0691S 0726 0802 0803 0842 0843 0860 0863 0870 0871 0876 0879 0885 0886 0891 0894 0899 0900 0905 0908 0912 IBH J ARGUMENT 000236 0691S 0715S 0818 0839 0855 0902 0903 0904 0905 0908 IDAT I LINKAGE 000614 0714S 0737A 0738 IDC J LINKAGE 000700 0859A 0860 0863 0875A 0876 0879 0890A 0891 0894 0904A 0905 0908 IDF J ARGUMENT 000302 0691S 0772 0774 0775 0777 0779 0780 0781 0782 IDL J LINKAGE 000670 0858A 0860 0863 0874A 0876 0879 0889A 0891 0894 0903A 0905 0908 IDP J LINKAGE 000660 0857A 0860 0863 0873A 0876 0879 0888A 0891 0894 0902A 0905 0908 IMC J LINKAGE 000702 0859A 0860 0863 0875A 0876 0879 0890A 0891 0894 0904A 0905 0908 IML J LINKAGE 000672 0858A 0860 0863 0874A 0876 0879 0889A 0891 0894 0903A 0905 0908 IMP J LINKAGE 000662 0857A 0860 0863 0873A 0876 0879 0888A 0891 0894 0902A 0905 0908 IPX J ARGUMENT 000241 0691S 0715S 0810 0833 0851 0888 0889 0890 0891 0894 ITIME I LINKAGE 000620 0714S 0737A 0738 IUSER I LINKAGE 000622 0714S 0737A 0738 J J LINKAGE 000654 0820M 0827M 0833M 0839M 0860M 0863M 0876M 0879M 0891M 0894M 0905M 0908M K J LINKAGE 000652 0809M 0810 0813M 0814 0817M 0818 0846M 0847 0850M 0851 0854M 0855 MAX J LINKAGE 000644 0748M 0752 0753 MAX0 J EXTERNAL 000000 0748 N3DIM J ARGUMENT 000310 0691S 0795 0796 0797 NB J ARGUMENT 000217 0691S 0748 0751 0756 0762 0763 0816 0817 0822 0835 0838 0853 0854 0867 0897 0901 NCENT J ARGUMENT 000203 0691S 0794 NCODE J ARGUMENT 000051 0691S 0744 0745 0764 0765 0766 0767 0768 0772 0774 0775 0777 0779 0780 0781 0782 0783 0784 0785 0786 0787 0788 0789 0790 0792 0800 NCOV J ARGUMENT 000150 0691S 0760 0761 NCOVB J ARGUMENT 000233 0691S 0762 0763 NF J ARGUMENT 000054 0691S 0748 0749 0754 0812 0813 0822 0823 0826 0845 0846 0867 0868 0872 NFIX J ARGUMENT 000115 0691S 0715S 0814 0827 0847 0873 0874 0875 0876 0879 NITER J ARGUMENT 000161 0691S 0783 NMULT J ARGUMENT 000156 0691S 0781 0782 NP J ARGUMENT 000062 0691S 0748 0750 0755 0760 0761 0808 0809 0822 0829 0832 0849 0850 0867 0883 0887 NPROJ J ARGUMENT 000120 0691S 0764 0765 0766 0767 0768 0785 0786 0787 0788 0789 0790 0792 0800A 0805 NRED1 J ARGUMENT 000175 0691S 0785 0786 0790 0792 NRED2 J ARGUMENT 000200 0691S 0787 0788 0790 0792 NRED3 J ARGUMENT 000211 0691S 0789 0790 0792 NS J ARGUMENT 000070 0691S 0807 0844 NTEST J ARGUMENT 000145 0691S 0772 0774 0775 0777 0779 0780 NUNIT J ARGUMENT 000123 0691S 0769 0770 0800A NUTM J ARGUMENT 000305 0691S 0800A NZERO J ARGUMENT 000142 0691S 0771 0912 PRE1 D LINKAGE 000434 0717I 0744 PRE2 D LINKAGE 000440 0717I 0744 PROINF D EXTERNAL 000000 0800 RADMS D EXTERNAL 000000 0857 0858 0859 0873 0874 0875 0888 0889 0890 0902 0903 0904 REL1 D LINKAGE 000504 0717I REL2 D LINKAGE 000510 0717I RKO D ARGUMENT 000277 0691S 0800A RL D ARGUMENT 000255 0691S 0800A RNON D LINKAGE 000544 0722I 0749 0750 0751 RNOR1 D LINKAGE 000564 0723I 0777 RNOR2 D LINKAGE 000570 0723I 0777 RP D ARGUMENT 000252 0691S 0800A SC D LINKAGE 000704 0859A 0860 0863 0875A 0876 0879 0890A 0891 0894 0904A 0905 0908 SL D LINKAGE 000674 0858A 0860 0863 0874A 0876 0879 0889A 0891 0894 0903A 0905 0908 SP D LINKAGE 000664 0857A 0860 0863 0873A 0876 0879 0888A 0891 0894 0902A 0905 0908 ST1 D LINKAGE 000574 0723I 0779 ST2 D LINKAGE 000600 0723I 0779 TAU1 D LINKAGE 000554 0723I 0774 TAU2 D LINKAGE 000560 0723I 0774 TIMREG D EXTERNAL 000000 0737 TL D ARGUMENT 000046 0691S 0715S 0730 UF D LINKAGE 000454 0717I 0770 UM D LINKAGE 000460 0717I 0769 X1 D ARGUMENT 000266 0691S 0800A XNOR1 D LINKAGE 000534 0717I 0775 XNOR2 D LINKAGE 000540 0717I 0775 XO D ARGUMENT 000260 0691S 0800A XST1 D LINKAGE 000604 0723I 0780 XST2 D LINKAGE 000610 0723I 0780 XTAU1 D LINKAGE 000524 0717I 0772 XTAU2 D LINKAGE 000530 0717I 0772 Y1 D ARGUMENT 000271 0691S 0800A YO D ARGUMENT 000263 0691S 0800A Z1 D ARGUMENT 000274 0691S 0800A Z4 D LINKAGE 000444 0717I 0765 Z5 D LINKAGE 000450 0717I 0764 ZER D ARGUMENT 000230 0691S 0912 $1 007674 0822 0835 0841 0867 0897 0912D $10 006034 0868 0883D $101 007730 0728 0732 0913D $102 007742 0729 0731 0914D $103 007756 0730 0915D $104 007776 0824 0869 0916D $107 010032 0802 0917D $108 010112 0806 0825 0831 0837 0919D $109 010145 0820 0827 0833 0839 0920D $11 007663 0901 0911D $110 010166 0727 0921D $111 010172 0804 0922D $153 010244 0742 0924D $154 010251 0743 0925D $155 010311 0744 0745 0927D $156 010344 0766 0928D $157 010375 0747 0929D $159 010443 0764 0765 0931D $161 010517 0767 0933D $162 010571 0768 0935D $163 010637 0769 0770 0937D $170 010671 0771 0938D $171 010740 0772 0774 0775 0777 0779 0780 0940D $172 011001 0761 0942D $173 011056 0760 0944D $175 011130 0781 0782 0946D $176 011210 0783 0948D $179 011252 0784 0950D $180 011313 0785 0786 0952D $181 011364 0787 0788 0954D $183 011440 0794 0956D $184 011502 0789 0790 0792 0958D $187 011557 0762 0960D $188 011630 0763 0962D $191 002653 0795 0796 0798D $192 002703 0797 0799D $2 003520 0826 0828D $201 011756 0842 0870 0885 0899 0966D $202 012142 0843 0871 0886 0900 0970D $207 011703 0803 0964D $208 000745 0752 0759D $209 012267 0860 0876 0891 0905 0973D $210 012334 0863 0879 0894 0908 0975D $211 010222 0912 0923D $3 003324 0807 0810 0814 0818 0821D $300 004063 0805 0842D $302 006023 0872 0882D $303 005031 0844 0847 0851 0855 0866D $304 004257 0853 0857D $305 004152 0846 0848D $4 003234 0816 0820D $404 012377 0836 0898 0977D $405 004052 0838 0840D $406 004163 0845 0849D $5 003165 0813 0815D $50 003030 0726 0803D $501 012433 0749 0750 0751 0754 0755 0756 0978D $502 000734 0753 0758D $503 012451 0746 0757 0759 0979D $6 003531 0823 0829D $6001 000163 0738 0739D $601 003140 0808 0812D $602 003127 0809 0811D $603 003706 0829 0835D $604 012455 0830 0884 0980D $605 003675 0832 0834D $606 004221 0849 0853D $607 004210 0850 0852D $608 006754 0883 0897D $609 006743 0887 0896D $7 003223 0817 0819D $701 012512 0981D $8 003176 0812 0816D $9 004246 0854 0856D 0000 ERRORS [FTN-REV18.2] SUBROUTINE PROINF(NPROJ,AA,BB,RP,RL,XO,YO,X1,Y1,Z1,RKO,NUNIT,NUTM)PROINF (0984) SUBROUTINE PROINF(NPROJ,AA,BB,RP,RL,XO,YO,X1,Y1,Z1,RKO,NUNIT,NUTM) (0985) C*********************************************************************** (0986) C* (0987) C* PROINF PRINTS PROJECTION SPECIFICATIONS IF A SPECIFIC PROJECTION IS (0988) C* BEING USED. (0989) C* (0990) C* (0991) C* INPUT: (0992) C* -ALL DESCRIBED IN MAIN (0993) C* (0994) C* OUTPUT: (0995) C* -ALL DESCRIBED IN MAIN (0996) C* (0997) C* (0998) C* WRITTEN BY: (0999) C* R.R. STEEVES, AUG., 1978 (1000) C* (1001) C*********************************************************************** (1002) IMPLICIT REAL*8(A-H,O-Z) (1003) DATA UM,UF/' METRES ',' FEET '/ (1004) U=UM (1005) IF(NUNIT.EQ.1)U=UF (1006) WRITE(6 ,101) (1007) 101 FORMAT('1',42X,'SPECIFICATIONS OF THE MAP PROJECTION',/,' ',42X, (1008) @ 36('-'),///) (1009) WRITE(6 ,102) (1010) 102 FORMAT(' ',21X,'PROJECTION USED :') (1011) IF(NPROJ.EQ.6) GOTO 206 (1012) IF(NPROJ.EQ.7) GOTO 207 (1013) IF(NPROJ.GT.3)GOTO10 (1014) IF(NPROJ.EQ.1)WRITE(6 ,103) (1015) 103 FORMAT('+',40X,'NEW BRUNSWICK DOUBLE STEREOGRAPHIC',//) (1016) IF(NPROJ.EQ.2)WRITE(6 ,104) (1017) 104 FORMAT('+',40X,'PRINCE EDWARD ISLAND DOUBLE STEREOGRAPHIC',//) (1018) CALL RADMS(RP,IDP,IMP,SP) (1019) CALL RADMS(RL,IDL,IML,SL) (1020) WRITE(6 ,105)IDP,IMP,SP,IDL,IML,SL,XO,U,YO,U (1021) 105 FORMAT(' ',21X,'ORIGIN : LATITUDE=',I4,I3,F9.5,' ; LONGITUDE=', (1022) @ I5,I3,F9.5,/,' ',31X,'EASTING (X)=',F12.3,A8,' ; NORTHING (Y)= ', (1023) @ F12.3,A8,//) (1024) WRITE(6 ,106)RKO (1025) 106 FORMAT(' ',39X,'SCALE AT THE ORIGIN :',F11.7,//) (1026) GOTO20 (1027) 10 NZ=4 (1028) IF(NPROJ.EQ.5)NZ=5 (1029) WRITE(6 ,107)NZ (1030) 107 FORMAT('+',40X,'NOVA SCOTIA 3-DEGREE TRANSVERSE MERCATOR (ZONE', (1031) @ I2,')',//) (1032) CALL RADMS(RL,IDL,IML,SL) (1033) WRITE(6 ,108)IDL,IML,SL,XO,U (1034) 108 FORMAT(' ',32X,'CENTRAL MERIDIAN : LONGITUDE=',I6,I3,F9.5,/,' ', (1035) @ 51X,'EASTING (X)=',F12.3,A8,//) (1036) WRITE(6 ,109)RKO (1037) 109 FORMAT(' ',34X,'SCALE AT THE CENTRAL MERIDIAN :',F11.7,//) (1038) GOTO 20 (1039) 206 CONTINUE (1040) WRITE(6,111) NUTM (1041) 111 FORMAT('+',40X,'UTM - PROJECTION (ZONE',I2,')',//) (1042) CALL RADMS(RL,IDL,IML,SL) (1043) WRITE(6,108) IDL,IML,SL,XO,U (1044) WRITE(6,109) RKO (1045) GOTO 20 (1046) 207 CONTINUE (1047) WRITE(6,112) (1048) 112 FORMAT('+',40X,'SWISS CYLINDER PROJECTION'//'NOT IMPLEMENTED '//) (1049) 20 CONTINUE (1050) WRITE(6 ,110)AA,U,BB,U,X1,U,Y1,U,Z1,U (1051) 110 FORMAT(//,' ',21X,'REFERENCE ELLIPSOID : CLARK 1866',//,' ', (1052) @ 44X,'SEMI-MAJOR AXIS=',F14.3,A8,//,' ',44X,'SEMI-MINOR AXIS=', (1053) @ F14.3,A8,//,' ',44X,'TRANSLATION COMPONENTS (FROM GEOCENTRE) USED (1054) @:',//,' ',48X,'XO=',F10.3,A8,/,' ',48X,'YO=',F10.3,A8,//,' ',48X, (1055) @ 'ZO=',F10.3,A8,/) (1056) RETURN (1057) END PROGRAM SIZE: PROCEDURE - 001640 LINKAGE - 000074 STACK - 000112 AA D ARGUMENT 000045 0984S 1050 BB D ARGUMENT 000050 0984S 1050 IDL J LINKAGE 000456 1019A 1020 1032A 1033 1042A 1043 IDP J LINKAGE 000446 1018A 1020 IML J LINKAGE 000460 1019A 1020 1032A 1033 1042A 1043 IMP J LINKAGE 000450 1018A 1020 NPROJ J ARGUMENT 000042 0984S 1011 1012 1013 1014 1016 1028 NUNIT J ARGUMENT 000103 0984S 1005 NUTM J ARGUMENT 000106 0984S 1040 NZ J LINKAGE 000472 1027M 1028M 1029 RADMS D EXTERNAL 000000 1018 1019 1032 1042 RKO D ARGUMENT 000100 0984S 1024 1036 1044 RL D ARGUMENT 000056 0984S 1019A 1032A 1042A RP D ARGUMENT 000053 0984S 1018A SL D LINKAGE 000462 1019A 1020 1032A 1033 1042A 1043 SP D LINKAGE 000452 1018A 1020 U D LINKAGE 000434 1004M 1005M 1020 1033 1043 1050 UF D LINKAGE 000430 1003I 1005 UM D LINKAGE 000424 1003I 1004 X1 D ARGUMENT 000067 0984S 1050 XO D ARGUMENT 000061 0984S 1020 1033 1043 Y1 D ARGUMENT 000072 0984S 1050 YO D ARGUMENT 000064 0984S 1020 Z1 D ARGUMENT 000075 0984S 1050 $10 000567 1013 1027D $101 000030 1006 1007D $102 000104 1009 1010D $103 000157 1014 1015D $104 000230 1016 1017D $105 000415 1020 1021D $106 000540 1024 1025D $107 000622 1029 1030D $108 000745 1033 1034D 1043 $109 001041 1036 1037D 1044 $110 001414 1050 1051D $111 001113 1040 1041D $112 001251 1047 1048D $20 001310 1026 1038 1045 1049D $206 001075 1011 1039D $207 001241 1012 1046D 0000 ERRORS [FTN-REV18.2] SUBROUTINE QUMUL(A,RN,NR,I,J,ICA,RES) QUMUL0 (1058) SUBROUTINE QUMUL(A,RN,NR,I,J,ICA,RES) (1059) C*********************************************************************** (1060) C* (1061) C* QUMUL COMPUTES THE VALUE OF THE QUADRATIC FORM DEFINED BY THE SPECIF (1062) C* ROW OF THE DESIGN MATRIX A AND THE CORRESPONDING PART OF THE COVARIA (1063) C* MATRIX (INVERSE OF NORMAL EQUATIONS). USED IN COMPUTING STANDARD DEV (1064) C* TIONS OF ADJUSTED DISTANCES AND AZIMUTHS. (1065) C* (1066) C* (1067) C* INPUT: (1068) C* -ALL DESCRIBED IN MAIN (1069) C* (1070) C* OUTPUT: (1071) C* -ALL DESCRIBED IN MAIN (1072) C* (1073) C* (1074) C* WRITTEN BY: (1075) C* R.R. STEEVES, AUG., 1978 (1076) C* (1077) C*********************************************************************** (1078) IMPLICIT REAL*8(A-H,O-Z) (1079) DIMENSION A(4),RN(NR,NR),ICA(4) (1080) RES=0.D0 (1081) DO 1 K=1,4 (1082) DO 1 L=1,4 (1083) IF(ICA(K).EQ.0.OR.ICA(L).EQ.0)GOTO1 (1084) RES=RES+A(K)*A(L)*RN(ICA(K),ICA(L)) (1085) 1 CONTINUE (1086) RETURN (1087) END PROGRAM SIZE: PROCEDURE - 000166 LINKAGE - 000024 STACK - 000102 A D ARGUMENT 000044 1058S 1079S 1084 ICA J ARGUMENT 000063 1058S 1079S 1083 1084 K J LINKAGE 000420 1081M 1083 1084 L J LINKAGE 000422 1082M 1083 1084 RES D ARGUMENT 000066 1058S 1080M 1084M RN D ARGUMENT 000047 1058S 1079S 1084 $1 000126 1081 1082 1083 1085D 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE RADMS(RAD,IDEG,IMIN,SEC) RADMS0 (0001) SUBROUTINE RADMS(RAD,IDEG,IMIN,SEC) (0002) C*********************************************************************** (0003) C* (0004) C* THIS ROUTINE CONVERTS AN ANGLE FROM RADIANS TO DEGREES,MINUTES, (0005) C* SECONDS. (0006) C* (0007) C* INPUT: (0008) C* RAD - THE ANGLE IN RADIANS. (0009) C* (0010) C* OUTPUT: (0011) C* IDEG - DEGREES (0012) C* IMIN - MINUTES (0013) C* SEC - SECONDS (0014) C* (0015) C* (0016) C* WRITTEN BY: (0017) C* G. BOWIE, JUNE, 1977 (0018) C* MODIFIED BY: (0019) C* R.R. STEEVES, JUNE, 1978 (0020) C* (0021) C*********************************************************************** (0022) IMPLICIT REAL*8(A-H,O-Z) (0023) DEG=DABS(RAD)*18.D1/3.141592653589793D0 (0024) IDEG=DEG (0025) F=(DEG-IDEG)*60.0D0 (0026) IMIN=F (0027) SEC=(F-IMIN)*60.0D0 (0028) IF(DABS(SEC-60.0D0).GT.1D-6) GO TO 1 (0029) SEC=0.0D0 (0030) IMIN=IMIN+1 (0031) IF(IMIN.NE.60) GO TO 1 (0032) IMIN=0 (0033) IDEG=IDEG+1 (0034) 1 CONTINUE (0035) IDEG=IDEG*DSIGN(1.D0,RAD) (0036) IF(IDEG.EQ.0)IMIN=IMIN*DSIGN(1.D0,RAD) (0037) IF(IMIN.EQ.0.AND.IDEG.EQ.0)SEC=SEC*DSIGN(1.D0,RAD) (0038) RETURN (0039) END PROGRAM SIZE: PROCEDURE - 000226 LINKAGE - 000034 STACK - 000064 DABS D EXTERNAL 000000 0023 0028 DEG D LINKAGE 000422 0023M 0024 0025 DSIGN D EXTERNAL 000000 0035 0036 0037 F D LINKAGE 000426 0025M 0026 0027 IDEG J ARGUMENT 000047 0001S 0024M 0025 0033M 0035M 0036 0037 IMIN J ARGUMENT 000052 0001S 0026M 0027 0030M 0031 0032M 0036M 0037 RAD D ARGUMENT 000044 0001S 0023A 0035A 0036A 0037A SEC D ARGUMENT 000055 0001S 0027M 0028 0029M 0037M $1 000105 0028 0031 0034D 0000 ERRORS [FTN-REV18.2] SUBROUTINE READ(TL,NP2R,NCODE,NF,NP,NSTAN,NPROJ,NUNIT,NELPS, READ00 (0040) SUBROUTINE READ(TL,NP2R,NCODE,NF,NP,NSTAN,NPROJ,NUNIT,NELPS, (0041) @ NDELX,NFAC,NITER,NZERO,NTEST,NMULT,NCOV,CNF,NFR,NP2, (0042) @ NP3,CPX,NPR,PX,NPXR,ALPH,FAC,CNAM,NSR,AP,NS,X,D,NR,IOB,NOR, (0043) @ DOB,CIO,NO,ND,N,NCORR,CONVG,CENT,NCENT,NCRIT,NRED1,NRED2,NRED3, (0044) @ NB,CBH,BH,NBR,NBHR,NCOVB,N1,N2,N3,N4,CERR,NSIMU,NSRES,NPRA,NPRN, (0045) @NPRW,NPRU,NPRCX,NSQRT,NB2,NB3,NVARF,NDISK,NRCOD,WANGC,WDISC,NABST, (0046) @NUTM,N3DIM,NHF,CNHF) (0047) C*********************************************************************** (0048) C* (0049) C* READ READS ALL INPUT DATA WHETHER FROM PUNCHED CARDS OR FROM CARD IM (0050) C* ON DISK (NOT IMPLEMENTED AS OF THIS PRINTING). (0051) C* (0052) C* (0053) C* INPUT: (0054) C* -ALL DESCRIBED IN MAIN (0055) C* (0056) C* OUTPUT: (0057) C* -ALL DESCRIBED IN MAIN (0058) C* (0059) C* (0060) C* WRITTEN BY: (0061) C* R.R. STEEVES, JUNE, 1978 (0062) C* (0063) C*********************************************************************** (0064) IMPLICIT REAL*8(A-H,O-Z) (0065) DIMENSION TL(10),CNF(NFR),NC(37),CPX(NPR),PX(NPXR),FAC(5), (0066) @ CNAM(NSR), X(NR),D(NR),IOB(NOR,4),DOB(NOR,4),CIO(NOR,3), (0067) @ AP(NSR,12),CBH(NBR),BH(NBHR),CERR(NSR),SAV(7),CNHF(NFR) (0068) DIMENSION CENT(4) (0069) DATA FIXD,PXD,BLAHD,CRITR ,BLNK ,FACTD,STATD,OBSERD,SIMUD/ (0070) @'FIXED ','WEIGHTED','BLAHA ','CRITERIA',' ', (0071) @'FACTORS ','STATIONS','OBSERVAT','SIMULTAN'/ (0072) DATA FIXH/'FIXH '/ (0073) IF(NRCOD.EQ.2)GOTO240 (0074) READ(5,109,END=1215)(TL(I),I=1,10) (0075) (0076) WRITE(7,7021)TL (0077) 7021 FORMAT(10A8) (0078) (0079) READ(5,102,ERR=200)(NC(I),I=1,37) (0080) GOTO201 (0081) 200 WRITE(6 ,202) (0082) STOP (0083) 201 DO 1 I=1,37 (0084) IF(I.EQ.1)GOTO1 (0085) IF((I.EQ.2.OR.I.EQ.3.OR.I.EQ.4).AND.NC(I).GT.0)GOTO1 (0086) IF(I.EQ.24)GOTO1 (0087) IF(I.EQ.5.AND.NC(I).LE.7) GOTO 1 (0088) IF(I.EQ.35.AND.NC(I).LE.60) GOTO 1 (0089) IF(NC(I).LE.5.AND.NC(I).GE.0)GOTO1 (0090) WRITE(6 ,103)I (0091) STOP (0092) 1 CONTINUE (0093) NCODE=NC(1) (0094) NF=NC(2) (0095) WRITE(7,7000) NF (0096) 7000 FORMAT(I3) (0097) NP=NC(3) (0098) NB=NC(4) (0099) NPROJ=NC(5) (0100) NUNIT=NC(6) (0101) NELPS=NC(7) (0102) NSIMU=NC(8) (0103) NSTAN=NC(9) (0104) NFAC=NC(10) (0105) NZERO=NC(11) (0106) NTEST=NC(12) (0107) NSRES=NC(13) (0108) NCOV=NC(14) (0109) NCOVB=NC(15) (0110) NCORR=NC(16) (0111) NMULT=NC(17) (0112) NCENT=NC(18) (0113) NDELX=NC(19) (0114) NCRIT=NC(20) (0115) NRED1=NC(21) (0116) NRED2=NC(22) (0117) NRED3=NC(23) (0118) NITER=NC(24) (0119) NPRA=NC(25) (0120) NPRN=NC(26) (0121) NPRW=NC(27) (0122) NPRU=NC(28) (0123) NPRCX=NC(29) (0124) NSQRT=NC(30) (0125) NVARF=NC(31) (0126) NMISC=NC(32) (0127) NABST=NC(33) (0128) NDISK=NC(34) (0129) NUTM=NC(35) (0130) N3DIM=NC(36) (0131) IF(NCODE.NE.1)NCODE=2 (0132) IF(NCOV.NE.1)NCOV=0 (0133) IF(NCOVB.NE.1)NCOVB=0 (0134) IF(NSTAN.GT.2.OR.NSTAN.LT.0)NSTAN=0 (0135) IF(NZERO.NE.1)NZERO=0 (0136) IF(NFAC.NE.1)NFAC=0 (0137) IF(NPROJ.EQ.0)NPROJ=3 (0138) IF(NUNIT.NE.1)NUNIT=0 (0139) IF(NELPS.GT.3.OR.NELPS.LT.0)NELPS=0 (0140) IF(NDELX.NE.1)NDELX=0 (0141) IF(NMISC.NE.1)NMISC=0 (0142) IF(NABST.NE.1)NABST=0 (0143) IF(NITER.EQ.0)NITER=5 (0144) IF(NITER.LT.0)NITER=0 (0145) IF(NMULT.NE.1)NMULT=0 (0146) IF(NRED1.NE.1)NRED1=0 (0147) IF(NRED2.NE.1)NRED2=0 (0148) IF(NRED3.NE.1)NRED3=0 (0149) IF(NCENT.NE.1)NCENT=0 (0150) IF(NCORR.NE.1)NCORR=0 (0151) IF(NCRIT.NE.1)NCRIT=0 (0152) IF(NSIMU.GT.4.OR.NSIMU.LT.0)NSIMU=0 (0153) IF(NSRES.NE.1)NSRES=0 (0154) IF(NPRA.LT.1.AND.NPRA.GT.3)NPRA=0 (0155) IF(NPRN.LT.1.AND.NPRN.GT.3)NPRN=0 (0156) IF(NPRU.LT.1.AND.NPRU.GT.3)NPRU=0 (0157) IF(NPRCX.NE.1)NPRCX=0 (0158) IF(NPRW.LT.1.AND.NPRW.GT.3)NPRW=0 (0159) IF(NSQRT.NE.1.AND.NSQRT.NE.2)NSQRT=0 (0160) IF(NVARF.NE.1)NVARF=0 (0161) IF(NDISK.NE.1)NDISK=0 (0162) IF(N3DIM.NE.1.AND.N3DIM.NE.2) N3DIM=0 (0163) IF(NTEST.LT.0.OR.NTEST.GT.5)NTEST=0 (0164) IF(NF.EQ.0)GOTO2 (0165) READ(5,101,END=217)RCODE (0166) IF(RCODE.EQ.FIXD)GOTO203 (0167) WRITE(6 ,204)RCODE (0168) STOP (0169) 203 READ(5,101,END=216)(CNF(I),I=1,NF) (0170) 2 NP2=NP*2 (0171) NP3=NP+2*NP**2 (0172) NB2=NB*2 (0173) NB3=NB+2*NB**2 (0174) 401 IF(N3DIM.NE.1) GOTO 402 (0175) READ(5,101,END=217)RCODE (0176) 403 IF(RCODE.NE.FIXH) GOTO 404 (0177) READ(5,110,END=217) NHF (0178) 110 FORMAT(I4) (0179) READ(5,101,END=217) (CNHF(I),I=1,NHF) (0180) GOTO 402 (0181) 404 CONTINUE (0182) WRITE(6,251)RCODE (0183) 251 FORMAT(' ','*** INPUT ERROR: EXPECTING - FIXH - BUT FOUND', (0184) @ ,A8,'***'/) (0185) STOP (0186) 402 CONTINUE (0187) IF(NP.EQ.0)GOTO4 (0188) READ(5,101,END=217)RCODE (0189) IF(RCODE.EQ.PXD)GOTO205 (0190) WRITE(6 ,206)RCODE (0191) STOP (0192) 205 READ(5,101,END=219)(CPX(I),I=1,NP) (0193) L1=1 (0194) DO 41 I=1,NP2 (0195) L2=L1+NP2-I (0196) READ(5,104,ERR=207)(PX(J),J=L1,L2) (0197) GOTO208 (0198) 207 WRITE(6 ,209) (0199) STOP (0200) 208 L1=L2+1 (0201) 41 CONTINUE (0202) 4 IF(NB.EQ.0)GOTO3 (0203) READ(5,101,END=217)RCODE (0204) IF(RCODE.EQ.BLAHD)GOTO210 (0205) WRITE(6 ,211)RCODE (0206) STOP (0207) 210 READ(5,101,END=221)(CBH(I),I=1,NB) (0208) L1=1 (0209) DO 42 I=1,NB2 (0210) L2=L1+NB2-I (0211) READ(5,104,ERR=212)(BH(J),J=L1,L2) (0212) GOTO1213 (0213) 212 WRITE(6 ,1214) (0214) STOP (0215) 1213 L1=L2+1 (0216) 42 CONTINUE (0217) 3 READ(5,101,END=217)RCODE (0218) IF(RCODE.NE.CRITR .AND.(NCRIT.EQ.1.OR.NSTAN.EQ.1.OR.NCENT.EQ.1.OR. (0219) @NMISC.EQ.1))GOTO215 (0220) IF(RCODE.EQ.CRITR)READ(5,105,ERR=213)CONVG,ALPH,(CENT(I),I=1,4) (0221) @,WANGC,WDISC (0222) IF(RCODE.NE.CRITR)GOTO214 (0223) GOTO1216 (0224) 215 WRITE(6 ,1217) (0225) STOP (0226) 213 WRITE(6 ,220) (0227) STOP (0228) 1216 ALPH=DABS(ALPH) (0229) 214 IF(NSTAN.EQ.0)ALPH=95.D0 (0230) IF(NSTAN.EQ.2)ALPH=39.4D0 (0231) IF(ALPH.LT.39.4D0.OR.ALPH.GT.99.999D0)ALPH=95.0D0 (0232) IF(NCRIT.EQ.0)CONVG=1.D-3 (0233) IF(NCRIT.NE.0.AND.CONVG.LT.1.D-20)CONVG=1.D-3 (0234) CONVG=DABS(CONVG) (0235) FAK=1.D0 (0236) IF(NUNIT.EQ.1)FAK=0.3048D0 (0237) IF(NMISC.EQ.0)WANGC=36000.D0 (0238) IF(NMISC.EQ.0)WDISC=100.0D0/FAK (0239) WANGC=DABS(WANGC) (0240) WDISC=DABS(WDISC) (0241) IF(NCENT.EQ.1)GOTO27 (0242) DO 28 I=1,4 (0243) 28 CENT(I)=0.D0 (0244) 27 CONTINUE (0245) IF(RCODE.EQ.STATD)GOTO224 (0246) IF(RCODE.EQ.FACTD)GOTO1221 (0247) READ(5,101,END=217)RCODE (0248) IF(RCODE.NE.FACTD.AND.NFAC.EQ.1)GOTO222 (0249) 1221 IF(RCODE.EQ.FACTD)READ(5,105,ERR=223)(FAC(I),I=1,5) (0250) IF(RCODE.NE.FACTD)GOTO224 (0251) GOTO225 (0252) 222 WRITE(6 ,226) (0253) STOP (0254) 223 WRITE(6 ,227) (0255) STOP (0256) 225 IF(NFAC.NE.0)GOTO7 (0257) 224 DO 6 I=1,5 (0258) 6 FAC(I)=1.D0 (0259) GOTO8 (0260) 7 DO 20 I=1,5 (0261) IF(I.EQ.2.AND.FAC(I).GE.0.D0)GOTO20 (0262) IF(FAC(I).LE.0.D0)GOTO21 (0263) 20 CONTINUE (0264) XX=FAC(2) (0265) FAC(2)=FAC(3) (0266) FAC(3)=FAC(4) (0267) FAC(4)=FAC(5) (0268) FAC(5)=XX (0269) GOTO8 (0270) 21 WRITE(6 , 108) (0271) STOP (0272) 8 CONTINUE (0273) IF(RCODE.EQ.STATD)GOTO16 (0274) READ(5,101,END=217)RCODE (0275) IF(RCODE.NE.STATD)GOTO230 (0276) GOTO16 (0277) 230 WRITE(6 ,231)RCODE (0278) STOP (0279) 232 WRITE(6 ,233) (0280) STOP (0281) 16 J=1 (0282) 9 READ(5,106,ERR=232)I,CNAM(J),XX,YY,HH,HG,EXI,ETA (0283) IF(I.LT.0)GOTO10 (0284) WRITE(7,7001)CNAM(J),XX,YY (0285) 7001 FORMAT(A8,2F15.4) (0286) AP(J,1)=XX (0287) AP(J,2)=YY (0288) AP(J,3)=HH (0289) AP(J,4)=HG (0290) AP(J,5)=EXI (0291) AP(J,6)=ETA (0292) J=J+1 (0293) GOTO9 (0294) 10 NS=J-1 (0295) WRITE(7,7002) (0296) 7002 FORMAT('$$$$') (0297) IF(NB.EQ.0)GOTO23 (0298) NPOS=NS (0299) DO 22 J=1,NB (0300) DO 24 I=1,NS (0301) IF(I.GE.NPOS)GOTO22 (0302) IF(CNAM(I).EQ.CBH(J))GOTO25 (0303) 24 CONTINUE (0304) GOTO22 (0305) 25 SAV(7)=CNAM(NPOS) (0306) CNAM(NPOS)=CNAM(I) (0307) CNAM(I)=SAV(7) (0308) DO 26 L=1,6 (0309) SAV(L)=AP(NPOS,L) (0310) AP(NPOS,L)=AP(I,L) (0311) 26 AP(I,L)=SAV(L) (0312) NPOS=NPOS-1 (0313) 22 CONTINUE (0314) 23 J=1 (0315) READ(5,101,END=217)RCODE (0316) IF(RCODE.EQ.OBSERD)GOTO234 (0317) WRITE(6 ,235)RCODE (0318) STOP (0319) 236 WRITE(6 ,237) (0320) STOP (0321) 234 JD=0 (0322) N1=0 (0323) N2=0 (0324) N3=0 (0325) N4=0 (0326) 11 READ(5,107,ERR=236)K,(X(I),I=1,3),(D(I),I=1,4) (0327) IF(K.LT.-2)GOTO14 (0328) IF(K.EQ.-2)JD=JD+1 (0329) IF(K.EQ.1)N1=N1+1 (0330) IF(K.EQ.2.OR.K.EQ.-2)N2=N2+1 (0331) IF(K.EQ.3)N3=N3+1 (0332) IF(K.EQ.4)N4=N4+1 (0333) IOB(J,1)=K (0334) DO 12 I=1,3 (0335) 12 CIO(J,I)=X(I) (0336) DO 13 I=1,4 (0337) 13 DOB(J,I)=D(I) (0338) J=J+1 (0339) GOTO11 (0340) 14 NO=J-1 (0341) ND=JD (0342) N=NS*2-NF*2+NZERO-NB*2 (0343) IF(N3DIM.EQ.2) N = N + NS (0344) IF(N3DIM.EQ.1) N = N + NS - NHF (0345) IF(NRCOD.EQ.1)RETURN (0346) 240 READ(5,101,END=128)RCODE (0347) IF(RCODE.NE.SIMUD)GOTO242 (0348) DO 243 I=1,NSR (0349) 243 CERR(I)=BLNK (0350) J=1 (0351) DO 244 I=1,1000 (0352) J1=J+6 (0353) IF(J1.GT.NSR)J1=NSR (0354) READ(5,245,END=246)L,(CERR(K),K=J,J1) (0355) IF(J1.EQ.NSR)GOTO247 (0356) IF(L.LT.0 )GOTO247 (0357) J=J1+1 (0358) 244 CONTINUE (0359) 245 FORMAT(I5,5X,7(A8,2X)) (0360) 246 WRITE(6 ,248) (0361) STOP (0362) 242 WRITE(6 ,249)RCODE (0363) STOP (0364) 1215 WRITE(6 ,301) (0365) STOP (0366) 217 WRITE(6 ,302) (0367) STOP (0368) 216 WRITE(6 ,303) (0369) STOP (0370) 219 WRITE(6 ,304) (0371) STOP (0372) 221 WRITE(6 ,305) (0373) STOP (0374) 247 RETURN (0375) 128 NRCOD=3 (0376) 101 FORMAT(8(A8,2X)) (0377) 102 FORMAT(I2,3I4,33I2) (0378) 103 FORMAT(' ','*** INPUT ERROR #002 *** CODE # ',I3,' ON SECOND DATA (0379) @ CARD IS OUT OF ACCEPTABLE RANGE') (0380) 104 FORMAT(8F10.3) (0381) 105 FORMAT(8F10.3) (0382) 106 FORMAT(I2,A8,2F15.3,4F10.3) (0383) 107 FORMAT(I5,5X,3(A8,2X),4F10.3) (0384) 108 FORMAT(' ','*** INPUT ERROR #020 *** A FACTOR FOR STANDARD DEVIAT (0385) @IONS OF OBSERVATIONS IS ZERO OR NEGATIVE') (0386) 109 FORMAT(10A8) (0387) 202 FORMAT(' ','***INPUT ERROR #001 *** AN ERROR OCCURRED WHILE ATTEM (0388) @PTING TO READ THE CODES CARD',/,' ','PROBABLE CAUSE: MISSING TITLE (0389) @ OR CODES CARD OR A NON NUMERIC CHARACTER IS PUNCHED ON THIS CARD' (0390) @) (0391) 204 FORMAT(' ','*** INPUT ERROR #003 *** EXPECTING TO READ -FIXED- BU (0392) @T FOUND -',A8,'-') (0393) 206 FORMAT(' ','*** INPUT ERROR #004 *** EXPECTING TO READ -WEIGHTED- (0394) @ BUT FOUND -',A8,'-') (0395) 209 FORMAT(' ','*** INPUT ERROR #005 *** AN ERROR OCCURRED WHILE ATTE (0396) @MPTING TO READ PX MATRIX',/,' ','PROBABLE CAUSE: INCOMPLETE PX MAT (0397) @RIX DATA INPUT') (0398) 211 FORMAT(' ','*** INPUT ERROR #006 *** EXPECTING TO READ -BLAHA- BU (0399) @T FOUND -',A8,'-') (0400) 220 FORMAT(' ','*** INPUT ERROR #022 *** AN ERROR OCCURRED WHILE ATTEM (0401) @PTING TO READ THE SPECIFIC PARAMETERS FOR CONVERGENCE, CONFIDENCE (0402) @,',/,' ',10X,'CENTERING AND/OR MISCLOSURES PROBABLE CAUSE: IMPROPE (0403) @R SEQUENCE OF INPUT DATA') (0404) 226 FORMAT(' ','*** INPUT ERROR #023 *** OPTION TO READ FACTORS FOR OB (0405) @SERVATION STANDARD DEVIATIONS WAS SELECTED',/,' ',10X,'BUT DATA CA (0406) @RD WITH THESE VALUES WAS NOT FOUND') (0407) 227 FORMAT(' ','*** INPUT ERROR #024 *** AN ERROR OCCURRED WHILE ATTEM (0408) @PTING TO READ FACTORS FOR OBSERVATION STANDARD DEVIATIONS',/,' ', (0409) @10X,'PROBABLE CAUSE: IMPROPER SEQUENCE OF INPUT DATA') (0410) 231 FORMAT(' ','*** INPUT ERROR #025 *** EXPECTING TO READ -STATIONS- (0411) @ BUT FOUND -',A8,'- PROBABLE CAUSE: IMPROPER SEQUENCE OF INPUT DA (0412) @TA') (0413) 233 FORMAT(' ','*** INPUT ERROR #026 *** AN ERROR OCCURRED WHILE ATTE (0414) @MPTING TO READ APPROXIMATE COORDINATES',/,' ',10X,'PROBABLE CAUSE: (0415) @ IMPROPER SEQUENCE IN INPUT DATA') (0416) 235 FORMAT(' ','*** INPUT ERROR #027 *** EXPECTING TO READ -OBSERVAT( (0417) @IONS)- BUT FOUND -',A8,'- PROBABLE CAUSE: IMPROPER SEQUENCE OF INP (0418) @UT DATA') (0419) 237 FORMAT(' ','*** INPUT ERROR #028 *** AN ERROR OCCURRED WHILE ATTE (0420) @MPTING TO READ OBSERVATIONS',/,' ',10X,'PROBABLE CAUSE: IMPROPER S (0421) @EQUENCE OF INPUT DATA OR FORMAT') (0422) 248 FORMAT(' ','*** INPUT ERROR #029 *** END OF DATA ENCOUNTERED WHIL (0423) @E READING STATION NAMES FOR SIMULTANEOUS ELLIPSES') (0424) 249 FORMAT(' ','*** INPUT ERROR #030 *** EXPECTING TO READ -SIMULTAN(E (0425) @OUS)- BUT FOUND -',A8,'-') (0426) 301 FORMAT(' ','*** INPUT ERROR #037 *** NO INPUT DATA FOUND') (0427) 302 FORMAT(' ','*** INPUT ERROR #038 *** INCOMPLETE INPUT DATA') (0428) 303 FORMAT(' ','*** INPUT ERROR #039 *** END OF INPUT DATA FOUND WHILE (0429) @ ATTEMPTING TO READ FIXED STATION NAMES') (0430) 304 FORMAT(' ','*** INPUT ERROR #040 *** END OF INPUT DATA FOUND WHIL (0431) @E ATTEMPTING TO READ WEIGHTED STATION NAMES') (0432) 305 FORMAT(' ','*** INPUT ERROR #041 *** END OF INPUT DATA FOUND WHIL (0433) @E ATTEMPTING TO READ BLAHA STATION NAMES') (0434) 1214 FORMAT(' ','*** INPUT ERROR #007 *** AN ERROR OCCURRED WHILE ATTE (0435) @MPTING TO READ BLAHA MATRIX',/,' ','PROBABLE CAUSE: INCOMPLETE BLA (0436) @HA MATRIX DATA INPUT') (0437) 1217 FORMAT(' ','*** INPUT ERROR #021 *** SPECIFIC OPTIONS WERE REQUEST (0438) @ED FOR CONVERGENCE, CONFIDENCE, CENTERING OR MISCLOSURES',/,' ', (0439) @10X,'BUT DATA CARD WITH THESE VALUES WAS NOT FOUND') (0440) RETURN (0441) END PROGRAM SIZE: PROCEDURE - 011012 LINKAGE - 000350 STACK - 000434 ALPH D ARGUMENT 000156 0040S 0220M 0228M 0229M 0230M 0231M AP D ARGUMENT 000172 0040S 0065S 0286M 0287M 0288M 0289M 0290M 0291M 0309 0310M 0311M BH D ARGUMENT 000274 0040S 0065S 0211M BLAHD D LINKAGE 000440 0069I 0204 BLNK D LINKAGE 000450 0069I 0349 CBH D ARGUMENT 000271 0040S 0065S 0207M 0302 CENT D ARGUMENT 000244 0040S 0068S 0220M 0243M CERR D ARGUMENT 000324 0040S 0065S 0349M 0354M CIO D ARGUMENT 000222 0040S 0065S 0335M CNAM D ARGUMENT 000164 0040S 0065S 0282M 0284 0302 0305 0306M 0307M CNF D ARGUMENT 000126 0040S 0065S 0169M CNHF D ARGUMENT 000420 0040S 0065S 0179M CONVG D ARGUMENT 000241 0040S 0220M 0232M 0233M 0234M CPX D ARGUMENT 000142 0040S 0065S 0192M CRITR D LINKAGE 000444 0069I 0218 0220 0222 D D ARGUMENT 000203 0040S 0065S 0326M 0337 DABS D EXTERNAL 000000 0228 0234 0239 0240 DOB D ARGUMENT 000217 0040S 0065S 0337M ETA D LINKAGE 000732 0282M 0291 EXI D LINKAGE 000726 0282M 0290 FAC D ARGUMENT 000161 0040S 0065S 0249M 0258M 0261 0262 0264 0265M 0266M 0267M 0268M FACTD D LINKAGE 000454 0069I 0246 0248 0249 0250 FAK D LINKAGE 000702 0235M 0236M 0238 FIXD D LINKAGE 000430 0069I 0166 FIXH D LINKAGE 000474 0072I 0176 HG D LINKAGE 000722 0282M 0289 HH D LINKAGE 000716 0282M 0288 I J LINKAGE 000650 0074M 0079M 0083M 0084 0085 0086 0087 0088 0089 0090 0169M 0179M 0192M 0194M 0195 0207M 0209M 0210 0220M 0242M 0243 0249M 0257M 0258 0260M 0261 0262 0282M 0283 0300M 0301 0302 0306 0307 0310 0311 0326M 0334M 0335 0336M 0337 0348M 0349 0351M IOB J ARGUMENT 000211 0040S 0065S 0333M J J LINKAGE 000676 0196M 0211M 0281M 0282 0284 0286 0287 0288 0289 0290 0291 0292M 0294 0299M 0302 0314M 0333 0335 0337 0338M 0340 0350M 0352 0354 0357M J1 J LINKAGE 000746 0352M 0353M 0354 0355 0357 JD J LINKAGE 000742 0321M 0328M 0341 K J LINKAGE 000744 0326M 0327 0328 0329 0330 0331 0332 0333 0354M L J LINKAGE 000740 0308M 0309 0310 0311 0354M 0356 L1 J LINKAGE 000672 0193M 0195 0196 0200M 0208M 0210 0211 0215M L2 J LINKAGE 000674 0195M 0196 0200 0210M 0211 0215 N J ARGUMENT 000233 0040S 0342M 0343M 0344M N1 J ARGUMENT 000310 0040S 0322M 0329M N2 J ARGUMENT 000313 0040S 0323M 0330M N3 J ARGUMENT 000316 0040S 0324M 0331M N3DIM J ARGUMENT 000412 0040S 0130M 0162M 0174 0343 0344 N4 J ARGUMENT 000321 0040S 0325M 0332M NABST J ARGUMENT 000404 0040S 0127M 0142M NB J ARGUMENT 000266 0040S 0098M 0172 0173 0202 0207 0297 0299 0342 NB2 J ARGUMENT 000357 0040S 0172M 0209 0210 NB3 J ARGUMENT 000362 0040S 0173M NC J LINKAGE 000500 0065S 0079M 0085 0087 0088 0089 0093 0094 0097 0098 0099 0100 0101 0102 0103 0104 0105 0106 0107 0108 0109 0110 0111 0112 0113 0114 0115 0116 0117 0118 0119 0120 0121 0122 0123 0124 0125 0126 0127 0128 0129 0130 NCENT J ARGUMENT 000247 0040S 0112M 0149M 0218 0241 NCODE J ARGUMENT 000054 0040S 0093M 0131M NCORR J ARGUMENT 000236 0040S 0110M 0150M NCOV J ARGUMENT 000123 0040S 0108M 0132M NCOVB J ARGUMENT 000305 0040S 0109M 0133M NCRIT J ARGUMENT 000252 0040S 0114M 0151M 0218 0232 0233 ND J ARGUMENT 000230 0040S 0341M NDELX J ARGUMENT 000101 0040S 0113M 0140M NDISK J ARGUMENT 000370 0040S 0128M 0161M NELPS J ARGUMENT 000076 0040S 0101M 0139M NF J ARGUMENT 000057 0040S 0094M 0095 0164 0169 0342 NFAC J ARGUMENT 000104 0040S 0104M 0136M 0248 0256 NHF J ARGUMENT 000415 0040S 0177M 0179 0344 NITER J ARGUMENT 000107 0040S 0118M 0143M 0144M NMISC J LINKAGE 000664 0126M 0141M 0218 0237 0238 NMULT J ARGUMENT 000120 0040S 0111M 0145M NO J ARGUMENT 000225 0040S 0340M NP J ARGUMENT 000062 0040S 0097M 0170 0171 0187 0192 NP2 J ARGUMENT 000134 0040S 0170M 0194 0195 NP3 J ARGUMENT 000137 0040S 0171M NPOS J LINKAGE 000736 0298M 0301 0305 0306 0309 0310 0312M NPRA J ARGUMENT 000335 0040S 0119M 0154M NPRCX J ARGUMENT 000351 0040S 0123M 0157M NPRN J ARGUMENT 000340 0040S 0120M 0155M NPROJ J ARGUMENT 000070 0040S 0099M 0137M NPRU J ARGUMENT 000346 0040S 0122M 0156M NPRW J ARGUMENT 000343 0040S 0121M 0158M NRCOD J ARGUMENT 000373 0040S 0073 0345 0375M NRED1 J ARGUMENT 000255 0040S 0115M 0146M NRED2 J ARGUMENT 000260 0040S 0116M 0147M NRED3 J ARGUMENT 000263 0040S 0117M 0148M NS J ARGUMENT 000175 0040S 0294M 0298 0300 0342 0343 0344 NSIMU J ARGUMENT 000327 0040S 0102M 0152M NSQRT J ARGUMENT 000354 0040S 0124M 0159M NSR J ARGUMENT 000167 0040S 0065S 0348 0353 0355 NSRES J ARGUMENT 000332 0040S 0107M 0153M NSTAN J ARGUMENT 000065 0040S 0103M 0134M 0218 0229 0230 NTEST J ARGUMENT 000115 0040S 0106M 0163M NUNIT J ARGUMENT 000073 0040S 0100M 0138M 0236 NUTM J ARGUMENT 000407 0040S 0129M NVARF J ARGUMENT 000365 0040S 0125M 0160M NZERO J ARGUMENT 000112 0040S 0105M 0135M 0342 OBSERD D LINKAGE 000464 0069I 0316 PX D ARGUMENT 000150 0040S 0065S 0196M PXD D LINKAGE 000434 0069I 0189 RCODE D LINKAGE 000666 0165M 0166 0167 0175M 0176 0182 0188M 0189 0190 0203M 0204 0205 0217M 0218 0220 0222 0245 0246 0247M 0248 0249 0250 0273 0274M 0275 0277 0315M 0316 0317 0346M 0347 0362 SAV D LINKAGE 000612 0065S 0305M 0307 0309M 0311 SIMUD D LINKAGE 000470 0069I 0347 STATD D LINKAGE 000460 0069I 0245 0273 0275 TL D ARGUMENT 000046 0040S 0065S 0074M 0076 WANGC D ARGUMENT 000376 0040S 0220M 0237M 0239M WDISC D ARGUMENT 000401 0040S 0220M 0238M 0240M X D ARGUMENT 000200 0040S 0065S 0326M 0335 XX D LINKAGE 000706 0264M 0268 0282M 0284 0286 YY D LINKAGE 000712 0282M 0284 0287 $1 000331 0083 0084 0085 0086 0087 0088 0089 0092D $10 004216 0283 0294D $101 005717 0165 0169 0175 0179 0188 0192 0203 0207 0217 0247 0274 0315 0346 0376D $102 005725 0079 0377D $103 005735 0090 0378D $104 006015 0196 0211 0380D $105 006022 0220 0249 0381D $106 006027 0282 0382D $107 006043 0326 0383D $108 006060 0270 0384D $109 006144 0074 0386D $11 004622 0326D 0339 $110 001633 0177 0178D $12 005062 0334 0335D $1213 002466 0212 0215D $1214 010413 0213 0434D $1215 005604 0074 0364D $1216 002743 0223 0228D $1217 010526 0224 0437D $1221 003244 0246 0249D $128 005713 0346 0375D $13 005134 0336 0337D $14 005211 0327 0340D $16 003662 0273 0276 0281D $2 001513 0164 0170D $20 003454 0260 0261 0263D $200 000143 0079 0081D $201 000161 0080 0083D $202 006150 0081 0387D $203 001445 0166 0169D $204 006312 0167 0391D $205 002053 0189 0192D $206 006362 0190 0393D $207 002203 0196 0198D $208 002221 0197 0200D $209 006434 0198 0395D $21 003542 0262 0270D $210 002320 0204 0207D $211 006544 0205 0398D $212 002450 0211 0213D $213 002725 0220 0226D $214 002751 0222 0229D $215 002707 0218 0224D $216 005640 0169 0368D $217 005622 0165 0175 0177 0179 0188 0203 0217 0247 0274 0315 0366D $219 005656 0192 0370D $22 004500 0299 0301 0304 0313D $220 006614 0226 0400D $221 005674 0207 0372D $222 003327 0248 0252D $223 003345 0249 0254D $224 003367 0245 0250 0257D $225 003363 0251 0256D $226 006772 0252 0404D $227 007114 0254 0407D $23 004511 0297 0314D $230 003620 0275 0277D $231 007247 0277 0410D $232 003644 0279D 0282 $233 007351 0279 0413D $234 004607 0316 0321D $235 007472 0317 0416D $236 004571 0319D 0326 $237 007577 0319 0419D $24 004313 0300 0303D $240 005314 0073 0346D $242 005560 0347 0362D $243 005351 0348 0349D $244 005520 0351 0358D $245 005531 0354 0359D $246 005542 0354 0360D $247 005712 0355 0356 0374D $248 007720 0360 0422D $249 010011 0362 0424D $25 004324 0302 0305D $251 001723 0182 0183D $26 004433 0308 0311D $27 003172 0241 0244D $28 003144 0242 0243D $3 002505 0202 0217D $301 010065 0364 0426D $302 010120 0366 0427D $303 010155 0368 0428D $304 010241 0370 0430D $305 010327 0372 0432D $4 002240 0187 0202D $401 001551 0174D $402 001773 0174 0180 0186D $403 001602 0176D $404 001705 0176 0181D $41 002227 0194 0201D $42 002474 0209 0216D $6 003373 0257 0258D $7 003421 0256 0260D $7000 000370 0095 0096D $7001 004040 0284 0285D $7002 004234 0295 0296D $7021 000073 0076 0077D $8 003560 0259 0269 0272D $9 003666 0282D 0293 0000 ERRORS [FTN-REV18.2] SUBROUTINE REANG1(ANG,I,J,K,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) REANG1 (0442) SUBROUTINE REANG1(ANG,I,J,K,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) (0443) C*********************************************************************** (0444) C* (0445) C* REANG1 REDUCES ANGLE OBSERVATIONS FROM THE TERAIN TO THE ELLIPSOID. (0446) C* (0447) C* (0448) C* INPUT: (0449) C* ANG- ANGLE OBSERVATION ON TERRAIN (RADIANS) (0450) C* OTHERS- DESCRIBED IN MAIN (0451) C* (0452) C* OUTPUT: (0453) C* ANG- REDUCED ANGLE OBSERVATION (ON ELLIPSOID) (RADIANS) (0454) C* C1,C2,C3- CORRECTIONS TO OBSERVED ANGLE (RADIANS) (0455) C* (PRINTED IF REQUESTED) (0456) C* (0457) C* (0458) C* WRITTEN BY: (0459) C* R.R. STEEVES, JULY, 1978 (0460) C* (0461) C*********************************************************************** (0462) IMPLICIT REAL*8(A-H,O-Z) (0463) REAL*8 MIJ,MIK,NIJ,NIK (0464) DIMENSION AP(NSR,12) (0465) PI=3.141592653589793D0 (0466) RO=3600.D0*180.D0/PI (0467) HJ=AP(J,3)+AP(J,4) (0468) HK=AP(K,3)+AP(K,4) (0469) MIJ=(AP(I,8)+AP(J,8))/2.D0 (0470) MIK=(AP(I,8)+AP(K,8))/2.D0 (0471) NIJ=(AP(I,7)+AP(J,7))/2.D0 (0472) NIK=(AP(I,7)+AP(K,7))/2.D0 (0473) CALL ASAZ(AP,I,J,AIJ,NSR) (0474) CALL ASAZ(AP,I,K,AIK,NSR) (0475) SAIJ=DSIN(AIJ) (0476) CAIJ=DCOS(AIJ) (0477) SAIK=DSIN(AIK) (0478) CAIK=DCOS(AIK) (0479) CPJ=DCOS(AP(J,9)) (0480) CPK=DCOS(AP(K,9)) (0481) PIJ=(AP(I,9)+AP(J,9))/2.D0 (0482) CPIJ=DCOS(PIJ) (0483) PIK=(AP(I,9)+AP(K,9))/2.D0 (0484) CPIK=DCOS(PIK) (0485) SIJ=(AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2 (0486) SIK=(AP(K,1)-AP(I,1))**2+(AP(K,2)-AP(I,2))**2 (0487) ESQ=(AA**2-BB**2)/AA**2 (0488) C2=HJ/MIJ*ESQ*SAIJ*CAIJ*CPJ**2+HK/MIK*ESQ*SAIK*CAIK*CPK**2 (0489) C3=-ESQ*SIJ*CPIJ**2*DSIN(2.D0*AIJ)/12.D0/NIJ**2 (0490) @ -ESQ*SIK*CPIK**2*DSIN(2.D0*AIK)/12.D0/NIK**2 (0491) CALL GVERT(AP,NSR,AA,BB,XO,YO,ZO,VIJ,I,J) (0492) CALL GVERT(AP,NSR,AA,BB,XO,YO,ZO,VIK,I,K) (0493) C1=0.D0 (0494) IF(VIJ.EQ.0.D0)GOTO1 (0495) COT=1.D0/DTAN(VIJ) (0496) C1=C1-(AP(I,5)*SAIJ/RO-AP(I,6)*CAIJ/RO)*COT (0497) 1 IF(VIK.EQ.0.D0)GOTO2 (0498) COT=1.D0/DTAN(VIK) (0499) C1=C1-(AP(I,5)*SAIK/RO-AP(I,6)*CAIK/RO)*COT (0500) 2 ANG=ANG+C1+C2+C3 (0501) RETURN (0502) END PROGRAM SIZE: PROCEDURE - 001434 LINKAGE - 000202 STACK - 000140 AA D ARGUMENT 000056 0442S 0487 0491A 0492A AIJ D LINKAGE 000462 0473A 0475A 0476A 0489 AIK D LINKAGE 000466 0474A 0477A 0478A 0489 ANG D ARGUMENT 000042 0442S 0500M AP D ARGUMENT 000064 0442S 0464S 0467 0468 0469 0470 0471 0472 0473A 0474A 0479A 0480A 0481 0483 0485 0486 0491A 0492A 0496 0499 ASAZ D EXTERNAL 000000 0473 0474 BB D ARGUMENT 000061 0442S 0487 0491A 0492A C1 D ARGUMENT 000103 0442S 0493M 0496M 0499M 0500 C2 D ARGUMENT 000106 0442S 0488M 0500 C3 D ARGUMENT 000111 0442S 0489M 0500 CAIJ D LINKAGE 000502 0476M 0488 0496 CAIK D LINKAGE 000512 0478M 0488 0499 COT D LINKAGE 000576 0495M 0496 0498M 0499 CPIJ D LINKAGE 000532 0482M 0489 CPIK D LINKAGE 000542 0484M 0489 CPJ D LINKAGE 000516 0479M 0488 CPK D LINKAGE 000522 0480M 0488 DCOS D EXTERNAL 000000 0476 0478 0479 0480 0482 0484 DCOS$X D EXTERNAL 000000 0497 DSIN D EXTERNAL 000000 0475 0477 0489 DSIN$X J EXTERNAL 000000 0497 DTAN D EXTERNAL 000000 0495 0498 ESQ D LINKAGE 000556 0487M 0488 0489 GVERT D EXTERNAL 000000 0491 0492 HJ D LINKAGE 000430 0467M 0488 HK D LINKAGE 000434 0468M 0488 I J ARGUMENT 000045 0442S 0469 0470 0471 0472 0473A 0474A 0481 0483 0485 0486 0491A 0492A 0496 0499 J J ARGUMENT 000050 0442S 0467 0469 0471 0473A 0479 0481 0485 0491A K J ARGUMENT 000053 0442S 0468 0470 0472 0474A 0480 0483 0486 0492A MIJ D LINKAGE 000440 0463S 0469M 0488 MIK D LINKAGE 000444 0463S 0470M 0488 NIJ D LINKAGE 000450 0463S 0471M 0489 NIK D LINKAGE 000454 0463S 0472M 0489 NSR J ARGUMENT 000067 0442S 0464S 0473A 0474A 0491A 0492A PI D LINKAGE 000420 0465M 0466 PIJ D LINKAGE 000526 0481M 0482A PIK D LINKAGE 000536 0483M 0484A RO D LINKAGE 000424 0466M 0496 0499 SAIJ D LINKAGE 000474 0475M 0488 0496 SAIK D LINKAGE 000506 0477M 0488 0499 SIJ D LINKAGE 000546 0485M 0489 SIK D LINKAGE 000552 0486M 0489 VIJ D LINKAGE 000564 0491A 0494 0495A VIK D LINKAGE 000570 0492A 0497 0498A XO D ARGUMENT 000072 0442S 0491A 0492A YO D ARGUMENT 000075 0442S 0491A 0492A ZO D ARGUMENT 000100 0442S 0491A 0492A $1 001245 0494 0497D $2 001346 0497 0500D 0000 ERRORS [FTN-REV18.2] SUBROUTINE REDAZ1(AZ,I,J,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3,C4) REDAZ1 (0503) SUBROUTINE REDAZ1(AZ,I,J,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3,C4) (0504) C*********************************************************************** (0505) C* (0506) C* REDAZ1 REDUCES AZIMUTH OBSERVATIONS FROM THE TERRAIN TO THE ELLIPSOI (0507) C* (0508) C* (0509) C* INPUT (0510) C* AZ- OBSERVED DIRECTION ON THE TERRAIN (RADIANS) (0511) C* OTHERS- DESCRIBED IN MAIN. (0512) C* (0513) C* OUTPUT: (0514) C* AZ- REDUCED AZIMUTH (ON THE ELLIPSOID) (RADIANS) (0515) C* C1,C2,C3,C4- CORRECTIONS TO OBSERVED AZIMUTH (RADIANS) (0516) C* (0517) C* (0518) C* WRITTEN BY: (0519) C* R.R. STEEVES, JUNE, 1978 (0520) C* (0521) C*********************************************************************** (0522) IMPLICIT REAL*8(A-H,O-Z) (0523) REAL*8 MIJ,NIJ (0524) DIMENSION AP(NSR,12) (0525) PI=3.141592653589793D0 (0526) RO=3600.D0*180.D0/PI (0527) ESQ=(AA**2-BB**2)/AA**2 (0528) C4=-AP(I,6)/RO*DTAN(AP(I,9)) (0529) CALL GVERT(AP,NSR,AA,BB,XO,YO,ZO,V,I,J) (0530) AZ=AZ+C4 (0531) IF(V.EQ.0.D0)GOTO1 (0532) COT=1.D0/DTAN(V) (0533) C1=-(AP(I,5)/RO*DSIN(AZ)-AP(I,6)/RO*DCOS(AZ))*COT (0534) 1 IF(V.EQ.0.D0)C1=0.D0 (0535) AZ=AZ+C1 (0536) MIJ=(AP(I,8)+AP(J,8))/2.D0 (0537) NIJ=(AP(I,7)+AP(J,7))/2.D0 (0538) SIJ=(AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2 (0539) HJ=AP(J,3)+AP(J,4) (0540) CPJ=DCOS(AP(J,9)) (0541) CPIJ=DCOS((AP(I,9)+AP(J,9))/2.D0) (0542) C2=HJ/MIJ*ESQ*DSIN(AZ)*DCOS(AZ)*CPJ**2 (0543) AZ=AZ+C2 (0544) C3=-SIJ/NIJ**2/12.D0*ESQ*CPIJ**2*DSIN(2.D0*AZ) (0545) AZ=AZ+C3 (0546) RETURN (0547) END PROGRAM SIZE: PROCEDURE - 001000 LINKAGE - 000104 STACK - 000140 AA D ARGUMENT 000053 0503S 0527 0529A AP D ARGUMENT 000061 0503S 0524S 0528A 0529A 0533 0536 0537 0538 0539 0540A 0541 AZ D ARGUMENT 000042 0503S 0530M 0533A 0535M 0542A 0543M 0544 0545M BB D ARGUMENT 000056 0503S 0527 0529A C1 D ARGUMENT 000100 0503S 0533M 0534M 0535 C2 D ARGUMENT 000103 0503S 0542M 0543 C3 D ARGUMENT 000106 0503S 0544M 0545 C4 D ARGUMENT 000111 0503S 0528M 0530 COT D LINKAGE 000444 0532M 0533 CPIJ D LINKAGE 000500 0541M 0544 CPJ D LINKAGE 000474 0540M 0542 DCOS D EXTERNAL 000000 0533 0540 0541 0542 DCOS$X J EXTERNAL 000000 0534 0547 DSIN D EXTERNAL 000000 0533 0542 0544 DSIN$X D EXTERNAL 000000 0534 0547 DTAN D EXTERNAL 000000 0528 0532 ESQ D LINKAGE 000430 0527M 0542 0544 GVERT D EXTERNAL 000000 0529 HJ D LINKAGE 000470 0539M 0542 I J ARGUMENT 000045 0503S 0528 0529A 0533 0536 0537 0538 0541 J J ARGUMENT 000050 0503S 0529A 0536 0537 0538 0539 0540 0541 MIJ D LINKAGE 000454 0523S 0536M 0542 NIJ D LINKAGE 000460 0523S 0537M 0544 NSR J ARGUMENT 000064 0503S 0524S 0529A PI D LINKAGE 000420 0525M 0526 RO D LINKAGE 000424 0526M 0528 0533 SIJ D LINKAGE 000464 0538M 0544 V D LINKAGE 000440 0529A 0531 0532A 0534 XO D ARGUMENT 000067 0503S 0529A YO D ARGUMENT 000072 0503S 0529A ZO D ARGUMENT 000075 0503S 0529A $1 000254 0531 0534D 0000 ERRORS [FTN-REV18.2] SUBROUTINE REDIR1(DIJ,I,J,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) REDIR1 (0548) SUBROUTINE REDIR1(DIJ,I,J,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) (0549) C*********************************************************************** (0550) C* (0551) C* REDIR1 REDUCES DIRECTION OBSERVATIONS FROM THE TERRAIN TO THE ELLIPS (0552) C* (0553) C* (0554) C* INPUT: (0555) C* DIJ- OBSERVED DIRECTION ON THE TERRAIN (RADIANS) (0556) C* OTHERS- DESCRIBED IN MAIN (0557) C* (0558) C* OUTPUT: (0559) C* DIJ- REDUCED DIRECTION (ON THE ELLIPSOID) (RADIANS) (0560) C* C1,C2,C3- CORRECTIONS TO OBSERVED DIRECTION (RADIANS) (0561) C* (0562) C* (0563) C* WRITTEN BY: (0564) C* R.R. STEEVES, JUNE, 1978 (0565) C* (0566) C*********************************************************************** (0567) IMPLICIT REAL*8(A-H,O-Z) (0568) REAL*8 MIJ,NIJ (0569) DIMENSION AP(NSR,12) (0570) PI=3.141592653589793D0 (0571) RO=3600.D0*180.D0/PI (0572) HJ=AP(J,3)+AP(J,4) (0573) MIJ=(AP(I,8)+AP(J,8))/2.D0 (0574) NIJ=(AP(I,7)+AP(J,7))/2.D0 (0575) CALL ASAZ(AP,I,J,GAZ,NSR) (0576) SA=DSIN(GAZ) (0577) CA=DCOS(GAZ) (0578) PIJ=(AP(I,9)+AP(J,9))/2.D0 (0579) CPIJ=DCOS(PIJ) (0580) CPJ=DCOS(AP(J,9)) (0581) SIJ=(AP(J,1)-AP(I,1))**2+(AP(J,2)-AP(I,2))**2 (0582) ESQ=(AA**2-BB**2)/AA**2 (0583) C2=HJ/MIJ*ESQ*SA*CA*CPJ**2 (0584) C3=-ESQ*SIJ*CPIJ**2*DSIN(2.D0*GAZ)/12.D0/NIJ**2 (0585) CALL GVERT(AP,NSR,AA,BB,XO,YO,ZO,VERT,I,J) (0586) C1=0.D0 (0587) IF(VERT.EQ.0.D0)GOTO1 (0588) COT=1.D0/DTAN(VERT) (0589) C1=C1-(AP(I,5)*SA/RO-AP(I,6)*CA/RO)*COT (0590) 1 DIJ=DIJ+C1+C2+C3 (0591) RETURN (0592) END PROGRAM SIZE: PROCEDURE - 000710 LINKAGE - 000126 STACK - 000132 AA D ARGUMENT 000053 0548S 0582 0585A AP D ARGUMENT 000061 0548S 0569S 0572 0573 0574 0575A 0578 0580A 0581 0585A 0589 ASAZ D EXTERNAL 000000 0575 BB D ARGUMENT 000056 0548S 0582 0585A C1 D ARGUMENT 000100 0548S 0586M 0589M 0590 C2 D ARGUMENT 000103 0548S 0583M 0590 C3 D ARGUMENT 000106 0548S 0584M 0590 CA D LINKAGE 000462 0577M 0583 0589 COT D LINKAGE 000522 0588M 0589 CPIJ D LINKAGE 000472 0579M 0584 CPJ D LINKAGE 000476 0580M 0583 DCOS D EXTERNAL 000000 0577 0579 0580 DCOS$X D EXTERNAL 000000 0590 DIJ D ARGUMENT 000042 0548S 0590M DSIN D EXTERNAL 000000 0576 0584 DSIN$X J EXTERNAL 000000 0590 DTAN D EXTERNAL 000000 0588 ESQ D LINKAGE 000506 0582M 0583 0584 GAZ D LINKAGE 000446 0575A 0576A 0577A 0584 GVERT D EXTERNAL 000000 0585 HJ D LINKAGE 000430 0572M 0583 I J ARGUMENT 000045 0548S 0573 0574 0575A 0578 0581 0585A 0589 J J ARGUMENT 000050 0548S 0572 0573 0574 0575A 0578 0580 0581 0585A MIJ D LINKAGE 000434 0568S 0573M 0583 NIJ D LINKAGE 000440 0568S 0574M 0584 NSR J ARGUMENT 000064 0548S 0569S 0575A 0585A PI D LINKAGE 000420 0570M 0571 PIJ D LINKAGE 000466 0578M 0579A RO D LINKAGE 000424 0571M 0589 SA D LINKAGE 000454 0576M 0583 0589 SIJ D LINKAGE 000502 0581M 0584 VERT D LINKAGE 000514 0585A 0587 0588A XO D ARGUMENT 000067 0548S 0585A YO D ARGUMENT 000072 0548S 0585A ZO D ARGUMENT 000075 0548S 0585A $1 000626 0587 0590D 0000 ERRORS [FTN-REV18.2] SUBROUTINE REDIS1(DIS,I,J,AA,BB,AP,NSR,C5,C6,CNAM,DLDH1,DLDH2, REDIS1 (0593) SUBROUTINE REDIS1(DIS,I,J,AA,BB,AP,NSR,C5,C6,CNAM,DLDH1,DLDH2, (0594) @ LRED) (0595) C*********************************************************************** (0596) C* (0597) C* REDIS1 REDUCES OBSERVED SPATIAL DISTANCES (CORRECTED FOR REFRACTION) (0598) C* FROM THE TERRAIN TO THE REFERENCE ELLIPSOID. (0599) C* (0600) C* (0601) C* INPUT: (0602) C* DIS- OBSERVED SPATIAL DISTANCE (0603) C* I- STATION (SEQUENCE NUMBER) FROM WHICH DISTANCE WAS (0604) C* OBSERVED (0605) C* J- STATION (SEQUENCE NUMBER) TO WHICH DISTANCE WAS OBSERVED (0606) C* OTHERS- DESCRIBED IN MAIN (0607) C* (0608) C* OUTPUT: (0609) C* DIS- REDUCED DISTANCE (ON ELLIPSOID) (0610) C* C5- CORRECTION FROM SPATIAL TO CHORD (0611) C* C6- CORRECTION FROM CHORD TO ELLIPSOID (0612) C* (0613) C* (0614) C* WRITTEN BY: (0615) C* R.R. STEEVES, MAY, 1978 (0616) C* (0617) C*********************************************************************** (0618) IMPLICIT REAL*8(A-H,O-Z) (0619) REAL*8 MI,MJ,NI,NJ (0620) DIMENSION AP(NSR,12),CNAM(NSR) (0621) LOGICAL LRED (0622) RALPH(MI,NI,AIJ)=MI*NI/(MI*DSIN(AIJ)**2+NI*DCOS(AIJ)**2) (0623) CALL ASAZ(AP,I,J,AIJ,NSR) (0624) CALL ASAZ(AP,J,I,AJI,NSR) (0625) MI=AP(I,8) (0626) NI=AP(I,7) (0627) MJ=AP(J,8) (0628) NJ=AP(J,7) (0629) RIJ=RALPH(MI,NI,AIJ) (0630) RJI=RALPH(MJ,NJ,AJI) (0631) R=(RIJ+RJI)/2.D0 (0632) HI=AP(I,3)+AP(I,4) (0633) HJ=AP(J,3)+AP(J,4) (0634) DH=HJ-HI (0635) IF(DIS.LT.DABS(DH))WRITE(6 ,101)CNAM(I),CNAM(J) (0636) IF(DIS.LT.DABS(DH))STOP (0637) 101 FORMAT(' ','*** INPUT ERROR #015 *** OBSERVED SLOPE DISTANCE BETWE (0638) @EN STATIONS ',A8,' AND ',A8,/,' ',' IS LESS THAN THE HEIGHT ', (0639) @ 'DIFFERENCE BETWEEN THE TWO STATIONS') (0640) 1 IF(.NOT.LRED) GOTO 2 (0641) DIS2 = DIS*DIS - DH*DH (0642) RLO=DSQRT(DIS2/(1.D0+HI/R)/(1.D0+HJ/R)) (0643) C5=RLO-DIS (0644) DIS=2.D0*R*DARSIN(RLO/2.D0/R) (0645) C6=DIS-RLO (0646) 3 GOTO 4 (0647) (0648) 2 CONTINUE (0649) RLO = 2.D0 * R * DSIN(DIS/2.D0/R) (0650) C6 = DIS - RLO (0651) DIS2 = RLO*RLO * (1.D0+HI/R) * (1.D0+HJ/R) (0652) C5 = RLO - DSQRT(DIS2 + DH*DH) (0653) 4 CONTINUE (0654) (0655) C DERIVATIVES (0656) T1 = DH/DIS2 (0657) DLDH1 = DIS * (T1 - 1.D0/(2.D0 * (R + HI))) * 1.D3 (0658) DLDH2 = DIS * (-T1 - 1.D0/(2.D0 * (R + HJ))) * 1.D3 (0659) RETURN (0660) END PROGRAM SIZE: PROCEDURE - 001116 LINKAGE - 000144 STACK - 000152 AIJ D LINKAGE 000432 0622A 0623A 0629A AJI D LINKAGE 000436 0624A 0630A AP D ARGUMENT 000063 0593S 0620S 0623A 0624A 0625 0626 0627 0628 0632 0633 ASAZ D EXTERNAL 000000 0623 0624 C5 D ARGUMENT 000071 0593S 0643M 0652M C6 D ARGUMENT 000074 0593S 0645M 0650M CNAM D ARGUMENT 000077 0593S 0620S 0635 DABS D EXTERNAL 000000 0635 0636 DARSIN D EXTERNAL 000000 0644 DCOS D EXTERNAL 000000 0622 DCOS$X D EXTERNAL 000000 0622 DH D LINKAGE 000506 0634M 0635A 0636A 0641 0652 0656 DIS D ARGUMENT 000044 0593S 0635 0636 0641 0643 0644M 0645 0649 0650 0657 0658 DIS2 D LINKAGE 000524 0641M 0642 0651M 0652 0656 DLDH1 D ARGUMENT 000102 0593S 0657M DLDH2 D ARGUMENT 000105 0593S 0658M DSIN D EXTERNAL 000000 0622 0649 DSIN$X D EXTERNAL 000000 0622 0653 DSQR$X D EXTERNAL 000000 0646 0653 DSQRT D EXTERNAL 000000 0642 0652 HI D LINKAGE 000476 0632M 0634 0642 0651 0657 HJ D LINKAGE 000502 0633M 0634 0642 0651 0658 I J ARGUMENT 000047 0593S 0623A 0624A 0625 0626 0632 0635 J J ARGUMENT 000052 0593S 0623A 0624A 0627 0628 0633 0635 LRED L ARGUMENT 000110 0593S 0621S 0640 MI D LINKAGE 000442 0619S 0622 0625M 0629A MJ D LINKAGE 000452 0619S 0627M 0630A NI D LINKAGE 000446 0619S 0622 0626M 0629A NJ D LINKAGE 000456 0619S 0628M 0630A NSR J ARGUMENT 000066 0593S 0620S 0623A 0624A R D LINKAGE 000472 0631M 0642 0644 0649 0651 0657 0658 RALPH D 000000 0622S 0629 0630 RIJ D LINKAGE 000462 0629M 0631 RJI D LINKAGE 000466 0630M 0631 RLO D LINKAGE 000532 0642M 0643 0644 0645 0649M 0650 0651 0652 T1 D LINKAGE 000540 0656M 0657 0658 $1 000573 0640D $101 000452 0635 0637D $2 000706 0640 0648D $3 000705 0646D $4 001004 0646 0653D 0000 ERRORS [FTN-REV18.2] SUBROUTINE RESID(IOB,NO,A,X,W,WX,ICA,N,V,NV,ND,NP,ICP,SPX, RESID0 (0661) SUBROUTINE RESID(IOB,NO,A,X,W,WX,ICA,N,V,NV,ND,NP,ICP,SPX, (0662) @ NOR,NR,NP2R,CNAM,NSR,ZER,DOBR,IDF,S0) (0663) C*********************************************************************** (0664) C* (0665) C* RESID COMPUTES RESIDUALS FOR ALL OBSERVATIONS. ALSO COMPUTES THE (0666) C* QUADRATIC FORM OF WEIGHTED RESIDUALS (0667) C* (0668) C* (0669) C* INPUT: (0670) C* -ALL DESCRIBED IN MAIN (0671) C* (0672) C* OUTPUT: (0673) C* S0- VALUE OF THE QUADRATIC FORM OF WEIGHTED RESIDUALS (0674) C* V- RESIDUALS (0675) C* (0676) C* (0677) C* WRITTEN BY: (0678) C* R.R. STEEVES, (0679) C* (0680) C*********************************************************************** (0681) IMPLICIT REAL*8(A-H,O-Z) (0682) DIMENSION IOB(NOR,4),A(NOR,6),X(NR),W(NO),WX(NP2R), (0683) @ ICA(NOR,6),V(NV),ICP(NR),SPX(NP2R,NP2R),CNAM(NSR),DOBR(NOR,4) (0684) S0=0.D0 (0685) I=1 (0686) 10 IG=IOB(I,1) (0687) GOTO(1,3,1,1),IG (0688) C COMPUTE DISTANCE, ANGLE AND AZIMUTH RESIDUALS (0689) 1 W1=0.D0 (0690) DO 2 J=1,6 (0691) IF(ICA(I,J).EQ.0)GOTO2 (0692) W1=W1-A(I,J)*X(ICA(I,J)) (0693) 2 CONTINUE (0694) V(I)=W(I)+W1 (0695) S0=S0+V(I)**2/DOBR(I,1)**2 (0696) I=I+1 (0697) GOTO24 (0698) C COMPUTE DIRECTION RESIDUALS (0699) 3 II=I+20 (0700) DO 4 J=I,II (0701) M=J (0702) IF(IOB(J,1).EQ.-2)GOTO5 (0703) 4 CONTINUE (0704) 5 NUM=M-I+1 (0705) SUM=0.D0 (0706) DO 7 J=I,M (0707) SUM=SUM+1.D0/DOBR(J,1)**2 (0708) W1=0.D0 (0709) DO 6 K=1,4 (0710) IF(ICA(J,K).EQ.0)GOTO6 (0711) W1=W1-A(J,K)*X(ICA(J,K)) (0712) 6 CONTINUE (0713) V(J)=W(J)+W1 (0714) 7 CONTINUE (0715) SUM1=0.D0 (0716) DO 8 J=I,M (0717) W1=0.D0 (0718) DO 15 K=1,4 (0719) IF(ICA(J,K).EQ.0)GOTO15 (0720) W1=W1+A(J,K)*X(ICA(J,K)) (0721) 15 CONTINUE (0722) W1=(W1-W(J))/DOBR(J,1)**2 (0723) SUM1=SUM1+W1 (0724) 8 CONTINUE (0725) SUM2=SUM1/SUM (0726) DO 9 J=I,M (0727) 9 V(J)=V(J)+SUM2 (0728) DO 13 J=I,M (0729) 13 S0=S0+V(J)**2/DOBR(J,1)**2 (0730) I=I+NUM (0731) 24 IF(I.LE.NO)GOTO10 (0732) IF(NP.EQ.0)GOTO14 (0733) NP2=NP*2 (0734) DO 11 J=1,NP2 (0735) IF(ICP(J).EQ.0)GOTO20 (0736) V(NO+J)=WX(J)-X(ICP(J)) (0737) GOTO11 (0738) 20 V(NO+J)=WX(J) (0739) 11 CONTINUE (0740) DO 12 J=1,NP2 (0741) DO 12 K=1,NP2 (0742) 12 S0=S0+V(NO+J)*V(NO+K)*SPX(J,K) (0743) 14 RETURN (0744) END PROGRAM SIZE: PROCEDURE - 001304 LINKAGE - 000060 STACK - 000162 A D ARGUMENT 000050 0661S 0682S 0692 0711 0720 DOBR D ARGUMENT 000136 0661S 0682S 0695 0707 0722 0729 I J LINKAGE 000420 0685M 0686 0691 0692 0694 0695 0696M 0699 0700 0704 0706 0716 0726 0728 0730M 0731 ICA J ARGUMENT 000064 0661S 0682S 0691 0692 0710 0711 0719 0720 ICP J ARGUMENT 000106 0661S 0682S 0735 0736 IG J LINKAGE 000422 0686M 0687 II J LINKAGE 000432 0699M 0700 IOB J ARGUMENT 000042 0661S 0682S 0686 0702 J J LINKAGE 000430 0690M 0691 0692 0700M 0701 0702 0706M 0707 0710 0711 0713 0716M 0719 0720 0722 0726M 0727 0728M 0729 0734M 0735 0736 0738 0740M 0742 K J LINKAGE 000444 0709M 0710 0711 0718M 0719 0720 0741M 0742 M J LINKAGE 000434 0701M 0704 0706 0716 0726 0728 NO J ARGUMENT 000045 0661S 0682S 0731 0736 0738 0742 NP J ARGUMENT 000103 0661S 0732 0733 NP2 J LINKAGE 000456 0733M 0734 0740 0741 NUM J LINKAGE 000436 0704M 0730 S0 D ARGUMENT 000144 0661S 0684M 0695M 0729M 0742M SPX D ARGUMENT 000111 0661S 0682S 0742 SUM D LINKAGE 000440 0705M 0707M 0725 SUM1 D LINKAGE 000446 0715M 0723M 0725 SUM2 D LINKAGE 000452 0725M 0727 V D ARGUMENT 000072 0661S 0682S 0694M 0695 0713M 0727M 0729 0736M 0738M 0742 W D ARGUMENT 000056 0661S 0682S 0694 0713 0722 W1 D LINKAGE 000424 0689M 0692M 0694 0708M 0711M 0713 0717M 0720M 0722M 0723 WX D ARGUMENT 000061 0661S 0682S 0736 0738 X D ARGUMENT 000053 0661S 0682S 0692 0711 0720 0736 $1 000040 0687 0689D $10 000011 0686D 0731 $11 001134 0734 0737 0739D $12 001155 0740 0741 0742D $13 000724 0728 0729D $14 001257 0732 0743D $15 000571 0718 0719 0721D $2 000127 0690 0691 0693D $20 001104 0735 0738D $24 001004 0697 0731D $3 000224 0687 0699D $4 000255 0700 0703D $5 000266 0702 0704D $6 000422 0709 0710 0712D $7 000462 0706 0714D $8 000645 0716 0724D $9 000670 0726 0727D 0000 ERRORS [FTN-REV18.2] SUBROUTINE RESREJ(V,NV,DOB,IOB,NOR,NO,NTEST,ALPH,IDF,CNAM,NSR, RESREJ (0745) SUBROUTINE RESREJ(V,NV,DOB,IOB,NOR,NO,NTEST,ALPH,IDF,CNAM,NSR, (0746) @ NUMREJ) (0747) C*********************************************************************** (0748) C* (0749) C* RESREJ TESTS STANDARDIZED RESIDUALS FOR REJECTION AND PRINTS INFORMA (0750) C* CORRESPONDING TO RESIDUALS FLAGGED FOR REJECTION (0751) C* (0752) C* (0753) C* INPUT: (0754) C* -ALL DESCRIBED IN MAIN (0755) C* (0756) C* OUTPUT: (0757) C* -ALL DESCRIBED IN MAIN (0758) C* (0759) C* (0760) C* WRITTEN BY: (0761) C* R.R. STEEVES, AUG., 1978 (0762) C* (0763) C*********************************************************************** (0764) IMPLICIT REAL*8(A-H,O-Z) (0765) REAL*4 SRALPH,SNGL,FLOAT,SCR,SDF (0766) DIMENSION DOB(NOR,4),V(NV),IOB(NOR,4),CNAM(NSR) (0767) (0768) COMMON /STATIS/ NDF1 (0769) (0770) NUMREJ=0 (0771) SAVAL=ALPH (0772) IF(ALPH.LT.90.D0)ALPH=95.D0 (0773) WRITE(6 ,101)ALPH (0774) IF(NTEST.EQ.0)WRITE(6 ,102) (0775) IF(NTEST.EQ.1)WRITE(6 ,103) (0776) IF(NTEST.EQ.2)WRITE(6 ,104) (0777) IF(NTEST.EQ.3)WRITE(6 ,105) (0778) IF(NTEST.EQ.4)WRITE(6 ,106) (0779) IF(NTEST.EQ.5)WRITE(6 ,107) (0780) RALPH=ALPH/100.D0 (0781) RALPH1=1.D0-RALPH (0782) IF(NTEST.EQ.0.OR.NTEST.EQ.2.OR.NTEST.EQ.4)RALPH1=RALPH1/NO (0783) IF(NTEST.EQ.2.OR.NTEST.EQ.3)SRALPH=SNGL(1.D0-RALPH1/2.D0) (0784) IF(NTEST.EQ.4.OR.NTEST.EQ.5)SRALPH=SNGL(RALPH1) (0785) IF(NTEST.EQ.0.OR.NTEST.EQ.1)CALL TAURE(1,IDF,RALPH1,CR) (0786) IF(NTEST.LT.2)GOTO1 (0787) SDF=FLOAT(IDF) (0788) (0789) NDF1 = IDF (0790) DRALPH = DBLE(SRALPH) (0791) C IF(NTEST.EQ.4.OR.NTEST.EQ.5)CALL MDSTI(SRALPH,SDF,SCR,IER) (0792) IF(NTEST.EQ.4.OR.NTEST.EQ.5) CR = DICSTU(DRALPH) (0793) C IF(NTEST.EQ.2.OR.NTEST.EQ.3)CALL MDNRIS(SRALPH,SCR,IER) (0794) IF(NTEST.EQ.2.OR.NTEST.EQ.3) CR = DICNOR(DRALPH) (0795) C CR=DBLE(SCR) (0796) 1 WRITE(6 ,108)CR (0797) WRITE(6 ,109) (0798) WRITE(6 ,110) (0799) I=1 (0800) 2 IG=IOB(I,1) (0801) IA=IOB(I,2) (0802) IF=IOB(I,3) (0803) IT=IOB(I,4) (0804) GOTO(3,4,3,3),IG (0805) 3 CRPT=CR*DOB(I,1) (0806) IF(DABS(V(I)).LT.CRPT)GOTO7 (0807) NUMREJ=NUMREJ+1 (0808) IF(IG.EQ.1)WRITE(6 ,111)I,CNAM(IA),CNAM(IA),CNAM(IF) (0809) IF(IG.EQ.3)WRITE(6 ,112)I,CNAM(IA),CNAM(IF),CNAM(IT) (0810) IF(IG.EQ.4)WRITE(6 ,113)I,CNAM(IA),CNAM(IA),CNAM(IF) (0811) WRITE(6 ,114)V(I),DOB(I,1),CRPT (0812) 7 I=I+1 (0813) GOTO10 (0814) 4 J=1 (0815) 5 CRPT=CR*DOB(I,1) (0816) IA=IOB(I,2) (0817) IF=IOB(I,3) (0818) IF(DABS(V(I)).LT.CRPT)GOTO6 (0819) NUMREJ=NUMREJ+1 (0820) WRITE(6 ,115)I,J,CNAM(IA),CNAM(IA),CNAM(IF),V(I),DOB(I,1),CRPT (0821) 6 J=J+1 (0822) I=I+1 (0823) IF(IOB(I-1,1).NE.-2)GOTO5 (0824) 10 IF(I.LE.NO)GOTO2 (0825) IPC=(NUMREJ*100)/NO (0826) WRITE(6 ,116)NUMREJ,IPC (0827) IF(NUMREJ.GT.0)WRITE(6 ,117) (0828) DO 11 I=1,NO (0829) 11 V(I)=V(I)/DOB(I,1) (0830) ALPH=SAVAL (0831) 101 FORMAT('1',22X,'SUMMARY OF REJECTION OF RESIDUALS AT THE', (0832) @ F7.3,' % CONFIDENCE LEVEL',/,' ',22X,66('-'),/) (0833) 102 FORMAT(' ',42X,'(TAU MAX CRITERION USED)',/) (0834) 103 FORMAT(' ',41X,'(TAU NON-MAX CRITERION USED)',/) (0835) 104 FORMAT(' ',41X,'(NORMAL MAX CRITERION USED)',/) (0836) 105 FORMAT(' ',39X,'(NORMAL NON-MAX CRITERION USED)',/) (0837) 106 FORMAT(' ',39X,'(STUDENTS-T MAX CRITERION USED)',/) (0838) 107 FORMAT(' ',37X,'(STUDENTS-T NON-MAX CRITERION USED)',/) (0839) 108 FORMAT(' ',24X,'COMPUTED FACTOR FOR STANDARD DEVIATION OF RESIDUAL (0840) @ =',F9.4,//) (0841) 109 FORMAT(' ',45X,'REJECTED RESIDUALS:',/,' ',45X,19('-'),/) (0842) 110 FORMAT(' ',9X,57X,'STD.DEV',/,' ',9X,'OBSERVATION',3X,'AT',8X, (0843) @'FROM',6X,'TO',9X,'RESIDUAL',4X,'RESIDUAL',3X,'CRITICAL POINT',/) (0844) 111 FORMAT(' ',I7,2X,'DISTANCE',6X,3(A8,2X)) (0845) 112 FORMAT(' ',I7,2X,'ANGLE',9X,3(A8,2X)) (0846) 113 FORMAT(' ',I7,2X,'AZIMUTH',7X,3(A8,2X)) (0847) 114 FORMAT('+',52X,F8.4,F12.4,F13.4,11X,'REJECT',/) (0848) 115 FORMAT(' ',I7,2X,'DIRECTION',I3,3(2X,A8),1X,F8.4,F12.4,F13.4,11X, (0849) @ 'REJECT',/) (0850) 116 FORMAT(///,' ',17X,I5,' RESIDUALS (',I3,' % OF THE OBSERVATIONS) W (0851) @ERE FLAGGED FOR REJECTION',//) (0852) 117 FORMAT(' ',6X,'**** WARNING **** OBSERVATIONS CORRESPONDING TO REJ (0853) @ECTED RESIDUALS HAVE BEEN USED IN THIS ADJUSTMENT') (0854) RETURN (0855) END PROGRAM SIZE: PROCEDURE - 002742 LINKAGE - 000126 STACK - 000122 ALPH D ARGUMENT 000073 0745S 0771 0772M 0773 0780 0830M CNAM D ARGUMENT 000101 0745S 0766S 0808 0809 0810 0820 CR D LINKAGE 000456 0785A 0792M 0794M 0796 0805 0815 CRPT D LINKAGE 000512 0805M 0806 0811 0815M 0818 0820 DABS D EXTERNAL 000000 0806 0818 DBLE D EXTERNAL 000000 0790 DICNOR D EXTERNAL 000000 0794 DICSTU D EXTERNAL 000000 0792 DOB D ARGUMENT 000054 0745S 0766S 0805 0811 0815 0820 0829 DRALPH D LINKAGE 000470 0790M 0792A 0794A FLOAT R EXTERNAL 000000 0765S 0787 I J LINKAGE 000500 0799M 0800 0801 0802 0803 0805 0806 0808 0809 0810 0811 0812M 0815 0816 0817 0818 0820 0822M 0823 0824 0828M 0829 IA J LINKAGE 000504 0801M 0808 0809 0810 0816M 0820 IDF J ARGUMENT 000076 0745S 0785A 0787 0789 IF J LINKAGE 000506 0802M 0808 0809 0810 0817M 0820 IG J LINKAGE 000502 0800M 0804 0808 0809 0810 IOB J ARGUMENT 000057 0745S 0766S 0800 0801 0802 0803 0816 0817 0823 IPC J LINKAGE 000524 0825M 0826 IT J LINKAGE 000510 0803M 0809 J J LINKAGE 000522 0814M 0820 0821M NDF1 J /STATIS/ 000000 0768S 0789M NO J ARGUMENT 000065 0745S 0782 0824 0825 0828 NTEST J ARGUMENT 000070 0745S 0774 0775 0776 0777 0778 0779 0782 0783 0784 0785 0786 0792 0794 NUMREJ J ARGUMENT 000107 0745S 0770M 0807M 0819M 0825 0826 0827 RALPH D LINKAGE 000436 0780M 0781 RALPH1 D LINKAGE 000442 0781M 0782M 0783 0784A 0785A SAVAL D LINKAGE 000424 0771M 0830 SDF R LINKAGE 000462 0765S 0787M SNGL R EXTERNAL 000000 0765S 0783 0784 SRALPH R LINKAGE 000452 0765S 0783M 0784M 0790A TAURE D EXTERNAL 000000 0785 V D ARGUMENT 000046 0745S 0766S 0806A 0811 0818A 0820 0829M $1 000401 0786 0796D $10 001524 0813 0824D $101 001654 0773 0831D $102 001737 0774 0833D $103 001763 0775 0834D $104 002011 0776 0835D $105 002037 0777 0836D $106 002067 0778 0837D $107 002117 0779 0838D $108 002151 0796 0839D $109 002216 0797 0841D $11 001610 0828 0829D $110 002251 0798 0842D $111 002347 0808 0844D $112 002371 0809 0845D $113 002412 0810 0846D $114 002434 0811 0847D $115 002462 0820 0848D $116 002526 0826 0850D $117 002604 0827 0852D $2 000443 0800D 0824 $3 000555 0804 0805D $4 001214 0804 0814D $5 001220 0815D 0823 $6 001472 0818 0821D $7 001205 0806 0812D 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE SDAAZM(I,J,IC,NSR,RN,NR,SIJ,AP,STD) SDAAZM (0001) SUBROUTINE SDAAZM(I,J,IC,NSR,RN,NR,SIJ,AP,STD) (0002) C*********************************************************************** (0003) C* (0004) C* SDAAZM COMPUTES THE STANDARD DEVIATIONS OF THE ADJUSTED AZIMUTH FROM (0005) C* STATION I TO STATION J (SEQUENCE NUMBERS) (0006) C* (0007) C* (0008) C* INPUT: (0009) C* -ALL DESCRIBED IN MAIN (0010) C* (0011) C* OUTPUT: (0012) C* -ALL DESCRIBED IN MAIN (0013) C* (0014) C* (0015) C* WRITTEN BY: (0016) C* R.R. STEEVES, AUG., 1978 (0017) C* (0018) C*********************************************************************** (0019) IMPLICIT REAL*8(A-H,O-Z) (0020) DIMENSION IC(NSR,3),RN(NR,NR),A(4),AP(NSR,12),ICA(4) (0021) RO=3600.D0/3.141592653589793D0*180.D0 (0022) A(1)=(AP(I,2)-AP(J,2))/SIJ**2*RO (0023) A(2)=(AP(J,1)-AP(I,1))/SIJ**2*RO (0024) A(3)=-A(1) (0025) A(4)=-A(2) (0026) ICA(1)=IC(I,1) (0027) ICA(2)=IC(I,2) (0028) ICA(3)=IC(J,1) (0029) ICA(4)=IC(J,2) (0030) CALL QUMUL(A,RN,NR,I,J,ICA,RES) (0031) STD=DSQRT(RES) (0032) RETURN (0033) END PROGRAM SIZE: PROCEDURE - 000250 LINKAGE - 000064 STACK - 000112 A D LINKAGE 000420 0020S 0022M 0023M 0024M 0025M 0030A AP D ARGUMENT 000067 0001S 0020S 0022 0023 DSQR$X D EXTERNAL 000000 0033 DSQRT D EXTERNAL 000000 0031 I J ARGUMENT 000042 0001S 0022 0023 0026 0027 0030A IC J ARGUMENT 000050 0001S 0020S 0026 0027 0028 0029 ICA J LINKAGE 000440 0020S 0026M 0027M 0028M 0029M 0030A J J ARGUMENT 000045 0001S 0022 0023 0028 0029 0030A NR J ARGUMENT 000061 0001S 0020S 0030A QUMUL D EXTERNAL 000000 0030 RES D LINKAGE 000456 0030A 0031A RN D ARGUMENT 000056 0001S 0020S 0030A RO D LINKAGE 000450 0021M 0022 0023 SIJ D ARGUMENT 000064 0001S 0022 0023 STD D ARGUMENT 000072 0001S 0031M 0000 ERRORS [FTN-REV18.2] SUBROUTINE SDADIS(I,J,IC,NSR,RN,NR,SIJ,AP,STD) SDADIS (0034) SUBROUTINE SDADIS(I,J,IC,NSR,RN,NR,SIJ,AP,STD) (0035) C*********************************************************************** (0036) C* (0037) C* SDADIS COMPUTES THE STANDARD DEVIATION OF THE ADJUSTED DISTANCE FROM (0038) C* STATION I TO STATION J (SEQUENCE NUMBERS) (0039) C* (0040) C* (0041) C* INPUT: (0042) C* -ALL DESCRIBED IN MAIN (0043) C* (0044) C* OUTPUT: (0045) C* -ALL DESCRIBED IN MAIN (0046) C* (0047) C* (0048) C* WRITTEN BY: (0049) C* R.R. STEEVES, AUG., 1978 (0050) C* (0051) C*********************************************************************** (0052) IMPLICIT REAL*8(A-H,O-Z) (0053) DIMENSION IC(NSR,3),RN(NR,NR),A(4),AP(NSR,12),ICA(4) (0054) A(1)=(AP(I,1)-AP(J,1))/SIJ (0055) A(2)=(AP(I,2)-AP(J,2))/SIJ (0056) A(3)=-A(1) (0057) A(4)=-A(2) (0058) ICA(1)=IC(I,1) (0059) ICA(2)=IC(I,2) (0060) ICA(3)=IC(J,1) (0061) ICA(4)=IC(J,2) (0062) CALL QUMUL(A,RN,NR,I,J,ICA,RES) (0063) STD=DSQRT(RES) (0064) RETURN (0065) END PROGRAM SIZE: PROCEDURE - 000226 LINKAGE - 000060 STACK - 000106 A D LINKAGE 000420 0053S 0054M 0055M 0056M 0057M 0062A AP D ARGUMENT 000067 0034S 0053S 0054 0055 DSQR$X D EXTERNAL 000000 0065 DSQRT D EXTERNAL 000000 0063 I J ARGUMENT 000042 0034S 0054 0055 0058 0059 0062A IC J ARGUMENT 000050 0034S 0053S 0058 0059 0060 0061 ICA J LINKAGE 000440 0053S 0058M 0059M 0060M 0061M 0062A J J ARGUMENT 000045 0034S 0054 0055 0060 0061 0062A NR J ARGUMENT 000061 0034S 0053S 0062A QUMUL D EXTERNAL 000000 0062 RES D LINKAGE 000452 0062A 0063A RN D ARGUMENT 000056 0034S 0053S 0062A SIJ D ARGUMENT 000064 0034S 0054 0055 STD D ARGUMENT 000072 0034S 0063M 0000 ERRORS [FTN-REV18.2] SUBROUTINE SIGST(IOB,I,IVEC,NSS,NOR,NO) SIGST0 (0066) SUBROUTINE SIGST(IOB,I,IVEC,NSS,NOR,NO) (0067) C*********************************************************************** (0068) C* (0069) C* SIGST DETERMINES WHICH STATIONS ARE SIGHTED FROM STATION I (0070) C* (0071) C* (0072) C* INPUT: (0073) C* -ALL DESCRIBED IN MAIN (0074) C* (0075) C* OUTPUT: (0076) C* -ALL DESCRIBED IN MAIN (0077) C* (0078) C* (0079) C* WRITTEN BY: (0080) C* R.R. STEEVES, AUG., 1978 (0081) C* (0082) C*********************************************************************** (0083) IMPLICIT REAL*8(A-H,O-Z) (0084) DIMENSION IOB(NOR,4),IVEC(50) (0085) J=1 (0086) DO 1 K=1,NO (0087) IA=IOB(K,2) (0088) IF=IOB(K,3) (0089) IT=IOB(K,4) (0090) IF(I.NE.IA.AND.I.NE.IF.AND.I.NE.IT)GOTO1 (0091) IG=IABS(IOB(K,1)) (0092) GOTO(2,2,3,2),IG (0093) 2 IF(I.EQ.IA)L=IF (0094) IF(I.EQ.IF)L=IA (0095) 4 IF(J.EQ.1)GOTO5 (0096) M=J-1 (0097) DO 6 N=1,M (0098) IF(L.EQ.IVEC(N))GOTO1 (0099) 6 CONTINUE (0100) 5 IVEC(J)=L (0101) J=J+1 (0102) GOTO1 (0103) 3 DO 7 N=2,4 (0104) IF(IOB(K,N).EQ.I)GOTO1 (0105) IF(J.EQ.1)GOTO15 (0106) M=J-1 (0107) DO 16 NN=1,M (0108) IF(IOB(K,N).EQ.IVEC(NN))GOTO1 (0109) 16 CONTINUE (0110) 15 IVEC(J)=IOB(K,N) (0111) J=J+1 (0112) 7 CONTINUE (0113) 1 CONTINUE (0114) NSS=J-1 (0115) RETURN (0116) END PROGRAM SIZE: PROCEDURE - 000506 LINKAGE - 000044 STACK - 000072 I J ARGUMENT 000047 0066S 0090 0093 0094 0104 IA J LINKAGE 000424 0087M 0090 0093 0094 IABS J EXTERNAL 000000 0091 IF J LINKAGE 000426 0088M 0090 0093 0094 IG J LINKAGE 000432 0091M 0092 IOB J ARGUMENT 000044 0066S 0084S 0087 0088 0089 0091 0104 0108 0110 IT J LINKAGE 000430 0089M 0090 IVEC J ARGUMENT 000052 0066S 0084S 0098 0100M 0108 0110M J J LINKAGE 000420 0085M 0095 0096 0100 0101M 0105 0106 0110 0111M 0114 K J LINKAGE 000422 0086M 0087 0088 0089 0091 0104 0108 0110 L J LINKAGE 000434 0093M 0094M 0098 0100 M J LINKAGE 000436 0096M 0097 0106M 0107 N J LINKAGE 000440 0097M 0098 0103M 0104 0108 0110 NN J LINKAGE 000442 0107M 0108 NO J ARGUMENT 000063 0066S 0086 NSS J ARGUMENT 000055 0066S 0114M $1 000454 0086 0090 0098 0102 0104 0108 0113D $15 000400 0105 0110D $16 000367 0107 0109D $2 000142 0092 0093D $3 000261 0092 0103D $4 000170 0095D $5 000235 0095 0100D $6 000224 0097 0099D $7 000443 0103 0112D 0000 ERRORS [FTN-REV18.2] SUBROUTINE SINO(RN,NR,I,N,IC,CNAM,NS,NSR) SINO00 (0117) SUBROUTINE SINO(RN,NR,I,N,IC,CNAM,NS,NSR) (0118) C*********************************************************************** (0119) C* (0120) C* SINO ZEROS ROWS AND COLUMNS IN THE NORMAL EQUATIONS WHEN A SINGULARI (0121) C* IS ENCOUNTERED IN THE COMPUTATION OF THE CHOLESKI SQUARE ROOT. ALSO (0122) C* PRINTS INFORMATION ON THE LOCATION OF THE SINGULARITIES IF ANY. (0123) C* (0124) C* (0125) C* INPUT: (0126) C* I- POSITION (INTERSECTION OF THE ROW AND COLUMN TO BE ZEROE (0127) C* OF THE SINGULARITY. (0128) C* OTHERS- DESCRIBED IN MAIN (0129) C* (0130) C* (0131) C* WRITTEN BY: (0132) C* R.R. STEEVES, JULY, 1978 (0133) C* (0134) C*********************************************************************** (0135) IMPLICIT REAL*8(A-H,O-Z) (0136) DIMENSION RN(NR,NR),IC(NSR,3),CNAM(NSR) (0137) DO 1 J=1,I (0138) RN(J,I)=0.D0 (0139) 1 CONTINUE (0140) DO 2 J=I,N (0141) RN(I,J)=0.D0 (0142) 2 CONTINUE (0143) DO 3 J=1,NS (0144) DO 3 K=1,3 (0145) IF(I.EQ.IC(J,K))GOTO4 (0146) 3 CONTINUE (0147) WRITE(6 ,101)I,I (0148) WRITE(6 ,102) (0149) GOTO5 (0150) 4 WRITE(6 ,101)I,I (0151) IF(K.EQ.1)WRITE(6 ,103)CNAM(J) (0152) IF(K.EQ.2)WRITE(6 ,104)CNAM(J) (0153) IF(K.EQ.3)WRITE(6,105) CNAM(J) (0154) 101 FORMAT(' ','*** ERROR #010 *** SINGULARITY ENCOUNTERED IN NORMAL E (0155) @QUATIONS',/,' ','IN POSITION','(',I4,',',I4,')') (0156) 102 FORMAT('+',24X,'ZERO ERROR',/) (0157) 103 FORMAT('+',24X,'X-COORDINATE OF STATION',1X,A8,/) (0158) 104 FORMAT('+',24X,'Y-COORDINATE OF STATION',1X,A8,/) (0159) 105 FORMAT('+',24X,'HEIGHT OF STATION',1X,A8,/) (0160) 5 RETURN (0161) END PROGRAM SIZE: PROCEDURE - 000620 LINKAGE - 000040 STACK - 000074 CNAM D ARGUMENT 000061 0117S 0136S 0151 0152 0153 I J ARGUMENT 000050 0117S 0137 0138 0140 0141 0145 0147 0150 IC J ARGUMENT 000056 0117S 0136S 0145 J J LINKAGE 000424 0137M 0138 0140M 0141 0143M 0145 0151 0152 0153 K J LINKAGE 000426 0144M 0145 0151 0152 0153 N J ARGUMENT 000053 0117S 0140 NS J ARGUMENT 000064 0117S 0143 RN D ARGUMENT 000042 0117S 0136S 0138M 0141M $1 000031 0137 0139D $101 000372 0147 0150 0154D $102 000461 0148 0156D $103 000476 0151 0157D $104 000525 0152 0158D $105 000554 0153 0159D $2 000070 0140 0142D $3 000135 0143 0144 0146D $4 000214 0145 0150D $5 000600 0149 0160D 0000 ERRORS [FTN-REV18.2] SUBROUTINE SORT(VCLS,NOR,NRES) SORT00 (0162) SUBROUTINE SORT(VCLS,NOR,NRES) (0163) C*********************************************************************** (0164) C* (0165) C* SORT REARRANGES THE ELEMENTS OF VCLS IN ORDER OF INCREASING MAGNITUD (0166) C* FOR USE IN SEPARATING THESE ELEMENTS INTO CLASS INTERVALS FOR THE CH (0167) C* SQUARE GOODNESS OF FIT TEST AND HISTOGRAM PLOT. (0168) C* (0169) C* (0170) C* INPUT: (0171) C* NRES- NUMBER OF RESIDUALS IN VCLS (0172) C* (0173) C* (0174) C* WRITTEN BY: (0175) C* LAURIE PACH, JULY, 1978 (0176) C* (0177) C*********************************************************************** (0178) IMPLICIT REAL*8(A-H,O-Z) (0179) DIMENSION VCLS(NOR) (0180) NOUT=NRES*(NRES+1)/2 (0181) NINS=NRES-1 (0182) DO 12 J=1,NOUT (0183) IFLG=0 (0184) DO 11 I=1,NINS (0185) IF(VCLS(I).GT.VCLS(I+1))GOTO10 (0186) GOTO11 (0187) 10 IFLG=1 (0188) TEMP=VCLS(I) (0189) VCLS(I)=VCLS(I+1) (0190) VCLS(I+1)=TEMP (0191) 11 CONTINUE (0192) IF(IFLG.EQ.0)GOTO13 (0193) 12 CONTINUE (0194) 13 RETURN (0195) END PROGRAM SIZE: PROCEDURE - 000162 LINKAGE - 000036 STACK - 000060 I J LINKAGE 000430 0184M 0185 0188 0189 0190 IFLG J LINKAGE 000426 0183M 0187M 0192 J J LINKAGE 000424 0182M NINS J LINKAGE 000422 0181M 0184 NOUT J LINKAGE 000420 0180M 0182 NRES J ARGUMENT 000050 0162S 0180 0181 TEMP D LINKAGE 000432 0188M 0190 VCLS D ARGUMENT 000042 0162S 0179S 0185 0188 0189M 0190M $10 000064 0185 0187D $11 000125 0184 0186 0191D $12 000142 0182 0193D $13 000153 0192 0194D 0000 ERRORS [FTN-REV18.2] SUBROUTINE SPTEL(CHI,SLAM,C1,C2,E,PHI,ELAM) SPTEL0 (0196) SUBROUTINE SPTEL(CHI,SLAM,C1,C2,E,PHI,ELAM) (0197) C*********************************************************************** (0198) C* (0199) C* THIS ROUTINE TRANSFORMS SPHERICAL (CONFORMAL SPHERE) COORDINATE (0200) C* CHI,SLAM TO ELLIPSOIDAL COORDINATES PHI,ELAM USING A NEWTON- (0201) C* RAPHSON ITERATION. (0202) C* (0203) C* (0204) C* INPUT: (0205) C* CHI - SPHERICAL LATITUDE OF THE POINT, IN RADIANS. (0206) C* SLAM - SPHERICAL LONGITUDE OF THE POINT, IN RADIANS. (0207) C* E - FIRST ECCENTRICITY OF THE ELLIPSOID (COMPUTED IN (0208) C* SUBROUTINE STGINL). (0209) C* C1 - CONSTANT COMPUTED IN STGINL. (0210) C* C2 - CONSTANT COMPUTED IN STGINL. (0211) C* (0212) C* OUTPUT: (0213) C* PHI - ELLIPSOIDAL LATITUDE OF THE POINT, IN RADIANS. (0214) C* ELAM - ELLIPSOIDAL LONGITUDE OF THE POINT, IN RADIANS. (0215) C* (0216) C* (0217) C* WRITTEN BY: (0218) C* R.R. STEEVES, JULY, 1977 (0219) C* (0220) C*********************************************************************** (0221) IMPLICIT REAL*8(A-H,O-Z) (0222) PI4=3.141592653589793D0/4.D0 (0223) PHI=CHI (0224) 1 ESP=E*DSIN(PHI) (0225) P2=((1.D0-ESP)/(1.D0+ESP))**(E/2.D0) (0226) P1=DTAN(PI4+PHI/2.D0) (0227) F=C2*(P1*P2)**C1-DTAN(PI4+CHI/2.D0) (0228) FP=C1*C2*(P1*P2)**(C1-1.D0)*P2*(1.D0/2.D0/DCOS(PI4+PHI/2.D0)**2-E* (0229) 1 *2*DCOS (PHI)/(1.D0-ESP**2)*DTAN(PI4+PHI/2.D0)) (0230) DPHI=F/FP (0231) PHI=PHI-DPHI (0232) IF(DABS(DPHI).GT.1.D-11) GO TO 1 (0233) ELAM=SLAM/C1 (0234) RETURN (0235) END PROGRAM SIZE: PROCEDURE - 000310 LINKAGE - 000066 STACK - 000114 C1 D ARGUMENT 000050 0196S 0227 0228 0233 C2 D ARGUMENT 000053 0196S 0227 0228 CHI D ARGUMENT 000042 0196S 0223 0227 DABS D EXTERNAL 000000 0232 DCOS D EXTERNAL 000000 0228 DCOS$X D EXTERNAL 000000 0235 DPHI D LINKAGE 000460 0230M 0231 0232A DSIN D EXTERNAL 000000 0224 DSIN$X D EXTERNAL 000000 0235 DTAN D EXTERNAL 000000 0226 0227 0228 E D ARGUMENT 000056 0196S 0224 0225 0228 ELAM D ARGUMENT 000064 0196S 0233M ESP D LINKAGE 000426 0224M 0225 0228 F D LINKAGE 000446 0227M 0230 FP D LINKAGE 000454 0228M 0230 P1 D LINKAGE 000442 0226M 0227 0228 P2 D LINKAGE 000434 0225M 0227 0228 PHI D ARGUMENT 000061 0196S 0223M 0224A 0226 0228A 0231M PI4 D LINKAGE 000420 0222M 0226 0227 0228 SLAM D ARGUMENT 000045 0196S 0233 $1 000011 0224D 0232 0000 ERRORS [FTN-REV18.2] SUBROUTINE SPTPL(CHI,SLAM,XO,YO,KO,CHIO,SLAMO,R,X,Y,K,C) SPTPL0 (0236) SUBROUTINE SPTPL(CHI,SLAM,XO,YO,KO,CHIO,SLAMO,R,X,Y,K,C) (0237) C*********************************************************************** (0238) C* (0239) C* THIS ROUTINE TRANSFORMS SPHERICAL COORDINATES CHI,SLAM TO (0240) C* STEREOGRAPHIC GRID COORDINATES X,Y. (0241) C* (0242) C* (0243) C* INPUT: (0244) C* CHI - SPHERICAL LATITUDE OF THE POINT, IN RADIANS. (0245) C* SLAM - SPHERICAL LONGITUDE OF THE POINT, IN RADIANS. (0246) C* (POSITIVE EAST OF GREENWICH) (0247) C* XO - FALSE EASTING OF THE ORIGIN OF THE PROJECTION (0248) C* YO - FALSE NORTHING OF THE ORIGIN OF THE PROJECTION. (0249) C* KO - POINT SCALE FACTOR AT THE ORIGIN OF THE PROJECTION. (0250) C* (FROM SPHERE TO PLANE) (0251) C* CHIO - SPHERICAL LATITUDE OF THE ORIGIN, IN RADIANS. (0252) C* SLAMO - SPHERICAL LONGITUDE OF THE ORIGIN, IN RADIANS. (0253) C* R - RADIUS OF THE SPHERE. (0254) C* (0255) C* OUTPUT: (0256) C* X - STEREOGRAPHIC GRID EASTING. (0257) C* Y - STEREOGRAPHIC GRID NORTHING. (0258) C* K - POINT SCALE FACTOR AT THE POINT, GOING FROM THE SPHER (0259) C* TO THE PLANE. (0260) C* C - MERIDIAN CONVERGENCE AT THE POINT, IN RADIANS. (0261) C* (0262) C* (0263) C* WRITTEN BY: (0264) C* R.R. STEEVES, JULY, 1977 (0265) C* (0266) C*********************************************************************** (0267) IMPLICIT REAL*8(A-H,O-Z) (0268) REAL*8 KO,K (0269) RO=2.D0*KO*R (0270) DLAM=SLAM-SLAMO (0271) CC=DCOS(CHI) (0272) SC=DSIN(CHI) (0273) CCO=DCOS(CHIO) (0274) SCO=DSIN(CHIO) (0275) SDL=DSIN(DLAM) (0276) CDL=DCOS(DLAM) (0277) DEN=1.D0+SCO*SC+CCO*CC*CDL (0278) X=XO+RO*CC*SDL/DEN (0279) Y=YO+RO*(SC*CCO-CC*SCO*CDL)/DEN (0280) K=2.D0*KO/DEN (0281) C=DATAN((SDL*(SC+SCO))/(CC*CCO+(1.D0+SC*SCO)*CDL)) (0282) RETURN (0283) END PROGRAM SIZE: PROCEDURE - 000230 LINKAGE - 000072 STACK - 000116 C D ARGUMENT 000103 0236S 0281M CC D LINKAGE 000432 0271M 0277 0278 0279 0281 CCO D LINKAGE 000444 0273M 0277 0279 0281 CDL D LINKAGE 000460 0276M 0277 0279 0281 CHI D ARGUMENT 000042 0236S 0271A 0272A CHIO D ARGUMENT 000061 0236S 0273A 0274A DATAN D EXTERNAL 000000 0281 DATN$X D EXTERNAL 000000 0283 DCOS D EXTERNAL 000000 0271 0273 0276 DCOS$X D EXTERNAL 000000 0283 DEN D LINKAGE 000464 0277M 0278 0279 0280 DLAM D LINKAGE 000424 0270M 0275A 0276A DSIN D EXTERNAL 000000 0272 0274 0275 DSIN$X D EXTERNAL 000000 0283 K D ARGUMENT 000100 0236S 0268S 0280M KO D ARGUMENT 000056 0236S 0268S 0269 0280 R D ARGUMENT 000067 0236S 0269 RO D LINKAGE 000420 0269M 0278 0279 SC D LINKAGE 000440 0272M 0277 0279 0281 SCO D LINKAGE 000450 0274M 0277 0279 0281 SDL D LINKAGE 000454 0275M 0278 0281 SLAM D ARGUMENT 000045 0236S 0270 SLAMO D ARGUMENT 000064 0236S 0270 X D ARGUMENT 000072 0236S 0278M XO D ARGUMENT 000050 0236S 0278 Y D ARGUMENT 000075 0236S 0279M YO D ARGUMENT 000053 0236S 0279 0000 ERRORS [FTN-REV18.2] SUBROUTINE STATS(ITER,NITER,N1,N2,N3,N4,NP,NB,NZERO,ND,N,IDF,S0, STATS0 (0284) SUBROUTINE STATS(ITER,NITER,N1,N2,N3,N4,NP,NB,NZERO,ND,N,IDF,S0, (0285) @ NVARF,NUMREJ,NCODE,V,NV,DOB,NOR,NO,IOB,ALPH,VCLS,VARF,NH,NUH) (0286) C*********************************************************************** (0287) C* (0288) C* STATS PERFORMS AND PRINTS A STATISTICS SUMMARY OF THE COMPUTATION OF (0289) C* THE DEGREES OF FREEDOM, THE ESTIMATED VARIANCE FACTOR, THE CHI-SQUAR (0290) C* TEST ON THE VARIANCE FACTOR AND CONTROLS GOODNESS OF FIT TESTS AND T (0291) C* CORRESPONDING PLOTS. (0292) C* (0293) C* (0294) C* INPUT: (0295) C* -ALL DESCRIBED IN MAIN (0296) C* (0297) C* (0298) C* WRITTEN BY: (0299) C* R.R. STEEVES, AUG., 1978 (0300) C* (0301) C*********************************************************************** (0302) IMPLICIT REAL*8(A-H,O-Z) (0303) REAL*4 SALPH,SDF,FLOAT,SNGL,X (0304) DIMENSION V(NV),DOB(NOR,4),IOB(NOR,4),VCLS(NOR) (0305) (0306) COMMON /STATIS/ NDF1 (0307) (0308) WRITE(6 ,101) (0309) IF(NCODE.EQ.2)WRITE(6 ,102)ITER (0310) IF(NCODE.EQ.2)WRITE(6 ,103)NITER (0311) IF(NCODE.EQ.2.AND.ITER.EQ.NITER)WRITE(6 ,104) (0312) IF(NCODE.EQ.2.AND.ITER.NE.NITER)WRITE(6 ,112) (0313) NP2=NP*2 (0314) NN=N-NZERO-NUH (0315) NS1=N1+N2+N3+N4+NP2+NH (0316) NS2=NZERO+ND+NN+NUH (0317) WRITE(6 ,105)N1,NZERO,N2,ND,N3,N4,NP2,NN,NH,NUH,NS1,NS2 (0318) WRITE(6 ,106)IDF (0319) IF(IDF.EQ.0.OR.NCODE.EQ.1)GOTO9 (0320) VARF=S0/IDF (0321) WRITE(6 ,107)VARF (0322) WRITE(6 ,108) (0323) IF(NVARF.EQ.0)WRITE(6 ,114) (0324) IF(NVARF.EQ.1)WRITE(6 ,115) (0325) ALP2=(1.D0-ALPH/100.D0)/2.D0 (0326) SALPH=SNGL(1.D0-ALP2) (0327) SDF=FLOAT(IDF) (0328) C CALL MDCHI(SALPH,SDF,X,IER) (0329) (0330) NDF1 = IDF (0331) DSALPH = 1.D0 - ALP2 (0332) DX = DICCHI(DSALPH) (0333) X = SNGL(DX) (0334) (0335) RLOW=S0/DBLE(X) (0336) SALPH=SNGL(ALP2) (0337) C CALL MDCHI(SALPH,SDF,X,IER) (0338) (0339) DSALPH = ALP2 (0340) DX = DICCHI(DSALPH) (0341) X = SNGL(DX) (0342) (0343) HIGH=S0/DBLE(X) (0344) WRITE(6 ,109)RLOW,HIGH (0345) IF(RLOW.GT.1.D0.OR.HIGH.LT.1.D0)WRITE(6 ,110)ALPH (0346) IF(RLOW.LE.1.D0.AND.HIGH.GE.1.D0)WRITE(6 ,111)ALPH (0347) IF(IDF.GT.0)WRITE(6 ,113)NUMREJ (0348) IF(N1.GE.9)CALL GODFIT(V,NOR,VCLS,1,NO,IOB,NVARF,ALPH,NV) (0349) IF(N2+N3+N4.GE.9)CALL GODFIT(V,NOR,VCLS,2,NO,IOB,NVARF,ALPH, (0350) 1 NV) (0351) IF(N1.GT.0.AND.(N2+N3+N4+N1).GE.9)CALL GODFIT(V,NOR,VCLS,3, (0352) @ NO,IOB,NVARF,ALPH,NV) (0353) 101 FORMAT('1',46X,'STATISTICS SUMMARY',/,' ',46X,18('-'),//) (0354) 102 FORMAT(' ',28X,'NUMBER OF ITERATIONS REQUIRED FOR CONVERGENCE -->' (0355) @ ,I5) (0356) 103 FORMAT(' ',28X,'MAXIMUM NUMBER OF ITERATIONS ALLOWED ----------->' (0357) @ ,I5) (0358) 104 FORMAT(' ',1X,'**** WARNING **** MAXIMUM NUMBER OF ITERATIONS WAS (0359) @ REACHED. THE CONVERGENCE CRITERION MAY NOT BE SATISFIED.',//) (0360) 105 FORMAT(' ',29X,'NUMBER OF OBSERVATIONS',5X,'I',' NUMBER OF UNKNOWN (0361) @S',/,' ',29X,27('-'),'I',24('-'),/,' ',56X,'I',/,' ',29X,'DISTANCE (0362) @S',I13,5X,'I',' ZERO ERROR',I13,/,' ',29X,'DIRECTIONS',I12,5X,'I', (0363) @' ORIENTATION',I12,/,' ',29X,'ANGLES',I16,5X,'I',/,' ',29X,'AZIMUT (0364) @HS',I14,5X,'I',/,' ',29X,'COORDINATES',I11,5X,'I',' COORDINATES', (0365) @I12,/,' ',29X,'HEIGHTS',I15,5X,'I',' HEIGHTS',I16/ (0366) @ /,' ',46X,5('-'),25X,5('-'),/,' ',29X,'TOTALS',I16,I30,//) (0367) 106 FORMAT(' ',34X,'THE NUMBER OF DEGREES OF FREEDOM IS ',I6,////) (0368) 107 FORMAT(' ',34X,'ESTIMATED VARIANCE FACTOR= ',F15.6,//) (0369) 108 FORMAT(' ',36X,'CHI-SQUARE TEST ON THE VARIANCE FACTOR',/,' ',36X, (0370) @ 38('-'),/) (0371) 109 FORMAT(' ',28X,F12.6,6X,'< 1.000000 <',3X,F12.6,5X,'?',/) (0372) 110 FORMAT(' ',24X,'TEST ON VARIANCE FACTOR AT THE ',F7.3,' % CONFIDEN (0373) @CE LEVEL FAILS',/,' ',82X,5('-'),/) (0374) 111 FORMAT(' ',24X,'TEST ON VARIANCE FACTOR AT THE ',F7.3,' % CONFIDEN (0375) @CE LEVEL PASSES',/,' ',82X,6('-'),/) (0376) 112 FORMAT(/) (0377) 113 FORMAT(' ',32X,'(',I4,' RESIDUALS WERE FLAGGED FOR REJECTION )', (0378) @/) (0379) 114 FORMAT(' ',42X,'(VARIANCE FACTOR UNKNOWN)',/) (0380) 115 FORMAT(' ',43X,'(VARIANCE FACTOR KNOWN)',/) (0381) 9 RETURN (0382) END PROGRAM SIZE: PROCEDURE - 002356 LINKAGE - 000112 STACK - 000174 ALP2 D LINKAGE 000446 0325M 0326 0331 0336A 0339 ALPH D ARGUMENT 000146 0284S 0325 0345 0346 0348A 0349A 0351A DBLE D EXTERNAL 000000 0335 0343 DICCHI D EXTERNAL 000000 0332 0340 DSALPH D LINKAGE 000462 0331M 0332A 0339M 0340A DX D LINKAGE 000470 0332M 0333A 0340M 0341A FLOAT R EXTERNAL 000000 0303S 0327 GODFIT D EXTERNAL 000000 0348 0349 0351 HIGH D LINKAGE 000504 0343M 0344 0345 0346 IDF J ARGUMENT 000105 0284S 0318 0319 0320 0327 0330 0347 IOB J ARGUMENT 000143 0284S 0304S 0348A 0349A 0351A ITER J ARGUMENT 000044 0284S 0309 0311 0312 N J ARGUMENT 000102 0284S 0314 N1 J ARGUMENT 000052 0284S 0315 0317 0348 0351 N2 J ARGUMENT 000055 0284S 0315 0317 0349 0351 N3 J ARGUMENT 000060 0284S 0315 0317 0349 0351 N4 J ARGUMENT 000063 0284S 0315 0317 0349 0351 NCODE J ARGUMENT 000121 0284S 0309 0310 0311 0312 0319 ND J ARGUMENT 000077 0284S 0316 0317 NDF1 J /STATIS/ 000000 0306S 0330M NH J ARGUMENT 000157 0284S 0315 0317 NITER J ARGUMENT 000047 0284S 0310 0311 0312 NN J LINKAGE 000434 0314M 0316 0317 NO J ARGUMENT 000140 0284S 0348A 0349A 0351A NOR J ARGUMENT 000135 0284S 0304S 0348A 0349A 0351A NP J ARGUMENT 000066 0284S 0313 NP2 J LINKAGE 000432 0313M 0315 0317 NS1 J LINKAGE 000436 0315M 0317 NS2 J LINKAGE 000440 0316M 0317 NUH J ARGUMENT 000162 0284S 0314 0316 0317 NUMREJ J ARGUMENT 000116 0284S 0347 NV J ARGUMENT 000127 0284S 0304S 0348A 0349A 0351A NVARF J ARGUMENT 000113 0284S 0323 0324 0348A 0349A 0351A NZERO J ARGUMENT 000074 0284S 0314 0316 0317 RLOW D LINKAGE 000500 0335M 0344 0345 0346 S0 D ARGUMENT 000110 0284S 0320 0335 0343 SALPH R LINKAGE 000454 0303S 0326M 0336M SDF R LINKAGE 000456 0303S 0327M SNGL R EXTERNAL 000000 0303S 0326 0333 0336 0341 V D ARGUMENT 000124 0284S 0304S 0348A 0349A 0351A VARF D ARGUMENT 000154 0284S 0320M 0321 VCLS D ARGUMENT 000151 0284S 0304S 0348A 0349A 0351A X R LINKAGE 000474 0303S 0333M 0335A 0341M 0343A $101 001101 0308 0353D $102 001134 0309 0354D $103 001175 0310 0356D $104 001236 0311 0358D $105 001334 0317 0360D $106 001665 0318 0367D $107 001722 0321 0368D $108 001753 0322 0369D $109 002017 0344 0371D $110 002053 0345 0372D $111 002134 0346 0374D $112 002215 0312 0376D $113 002220 0347 0377D $114 002260 0323 0379D $115 002305 0324 0380D $9 002331 0319 0381D 0000 ERRORS [FTN-REV18.2] SUBROUTINE STGINL (PHIO,ELAMO,A,B,R,C1,C2,E,CHIO,SLAMO) STGINL (0383) SUBROUTINE STGINL (PHIO,ELAMO,A,B,R,C1,C2,E,CHIO,SLAMO) (0384) C*********************************************************************** (0385) C* (0386) C* THIS ROUTINE COMPUTES THE INITIAL VALUES TO BE USED IN (0387) C* THE STEREOGRAPHIC DOUBLE PROJECTION SUBROUTINES. (0388) C* (0389) C* (0390) C* INPUT: (0391) C* PHIO - ELLIPSOID LATITUDE OF THE ORIGIN OF THE PROJECTION (0392) C* IN RADIANS. (0393) C* ELAMO - ELLIPSOIDAL LNGITUDE (POSITIVE EAST OF GREENWICH) (0394) C* OF THE ORIGIN OF THE PROJECTION IN RADIANS. (0395) C* A,B - SEMI-MAJOR AND SEMI-MINOR AXES OF THE REFERENCE (0396) C* ELLIPSOID, IN METRES. (0397) C* (0398) C* OUTPUT: (0399) C* R - RADIUS OF THE CONFORMAL SPHERE, IN METRES. (0400) C* C1 - CONSTANT USED IN THE TRANSFORMATIONS BETWEEN THE (0401) C* ELLIPSOID AND THE CONFORMAL SPHERE. (0402) C* C2 - CONSTANT FOR THE SAME USE AS C1. (0403) C* E - FIRST ECCENTRICITY OF THE ELLIPSOID. (0404) C* CHIO - SPHERICAL LATITUDE OF THE ORIGIN OF THE PROJECTION (0405) C* IN RADIANS. (0406) C* SLAMO - SPERICAL LONGITUDE OF THE ORIGIN OF THE PROJECTIO (0407) C* IN RADIANS. (0408) C* (0409) C* (0410) C* WRITTEN BY: (0411) C* R.R. STEEVES, JULY, 1977 (0412) C* (0413) C*********************************************************************** (0414) IMPLICIT REAL*8(A-H,O-Z) (0415) E2=(A*A-B*B)/(A*A) (0416) E=DSQRT(E2) (0417) SP=DSIN(PHIO) (0418) R=A*DSQRT(1.D0-E2)/(1.D0-E2*SP**2) (0419) C1=DSQRT(1.D0+E2 /(1.D0-E2)*DCOS(PHIO)**4) (0420) CHIO=DARSIN(SP/C1) (0421) SLAMO=C1*ELAMO (0422) PI=3.141592653589793D0 (0423) C2=DTAN(PI/4.D0+CHIO/2.D0)/(DTAN(PI/4.D0+PHIO/2.D0)*((1.D0-E*SP)/ (0424) 1 (1.D0+E*SP))**(E/2.D0))**C1 (0425) RETURN (0426) END PROGRAM SIZE: PROCEDURE - 000302 LINKAGE - 000052 STACK - 000114 A D ARGUMENT 000050 0383S 0415 0418 B D ARGUMENT 000053 0383S 0415 C1 D ARGUMENT 000061 0383S 0419M 0420 0421 0423 C2 D ARGUMENT 000064 0383S 0423M CHIO D ARGUMENT 000072 0383S 0420M 0423 DARSIN D EXTERNAL 000000 0420 DCOS D EXTERNAL 000000 0419 DCOS$X D EXTERNAL 000000 0426 DSIN D EXTERNAL 000000 0417 DSIN$X D EXTERNAL 000000 0426 DSQR$X D EXTERNAL 000000 0426 DSQRT D EXTERNAL 000000 0416 0418 0419 DTAN D EXTERNAL 000000 0423 E D ARGUMENT 000067 0383S 0416M 0423 E2 D LINKAGE 000420 0415M 0416A 0418 0419 ELAMO D ARGUMENT 000045 0383S 0421 PHIO D ARGUMENT 000042 0383S 0417A 0419A 0423 PI D LINKAGE 000442 0422M 0423 R D ARGUMENT 000056 0383S 0418M SLAMO D ARGUMENT 000075 0383S 0421M SP D LINKAGE 000430 0417M 0418 0420 0423 0000 ERRORS [FTN-REV18.2] $$$ SUBROUTINE TAURE(NT,NU,ALPH,CRTAU) TAURE0 (0001) SUBROUTINE TAURE(NT,NU,ALPH,CRTAU) (0002) C*********************************************************************** (0003) C* (0004) C* TAURE COMPUTES THE CRITICAL VALUE FOR REJECTION OF STANDARDIZED (0005) C* RESIDUALS WITH CONTROL OF TYPE I ERROR. (0006) C* (0007) C* (0008) C* INPUT: (0009) C* NT- NUMBER OF OBSERVATIONS (0010) C* NU- DEGREES OF FREEDOM (0011) C* ALPH- DESIRED PROBABILITY OF TYPE I ERROR (0012) C* (0013) C* OUTPUT: (0014) C* CRTAU- CRITICAL VALUE (TAU-MAX) (0015) C* (0016) C* (0017) C* REFERENCE: (0018) C* A.J. POPE (1976)- THE STATIST (0019) C* OF RESIDUALS AND THE DETECTIO (0020) C* OF OUTLIERS; U.S. DEPT OR COM (0021) C* NOAA TECHNICAL REPORT (0022) C* NO. 65 NGS1. (0023) C* (0024) C*********************************************************************** (0025) IMPLICIT REAL*8(A-H,O-Z) (0026) DATA PI/ 3.1415926535898 / (0027) PD = 2. /PI (0028) S = 1. (0029) WNU = NU (0030) U = WNU -1. (0031) IF( U.EQ.0. ) GO TO 72 (0032) IF ( ALPH.EQ.0. ) GO TO 72 (0033) IF ( ALPH.LT.1. ) GO TO 10 (0034) CRTAU = 0. (0035) C (0036) RETURN (0037) C (0038) 10 Q = NT (0039) IF ( ALPH.GT.0.5 ) GO TO 19 (0040) AA = ALPH / Q (0041) DELT = AA (0042) DO 18 I = 1,100 (0043) XI = I (0044) DELT = DELT * ALPH * (( XI*Q - 1.)/(( XI+1.)*Q)) (0045) IF ( DELT.LT.1.D-14 ) GO TO 20 (0046) 18 AA = AA + DELT (0047) 19 AA = 1. - (1.-ALPH)**(1./Q) (0048) 20 P = 1. - AA (0049) IF(U.EQ.1. ) GO TO 71 (0050) F = 1.3862943611199 - 2.*DLOG(AA) (0051) G = DSQRT(F) (0052) X = G - (2.515517 + 0.802853*G + 0.010328*F) (0053) $ / (1. + 1.432788*G + F*(0.189269 + 0.001308*G)) (0054) Y = X*X (0055) A = X*(1. + Y)/4. (0056) B = X*(3. + Y*(16. + 5.*Y))/96. (0057) C = X*(-15. + Y*(17. + Y*(19. + 3.*Y)))/384. (0058) E = X*(-945. + Y*(-1920. + Y*(1482. + Y*(776. + 79.*Y))))/92160. (0059) V = 1./U (0060) T = X + V*(A + V*(B + V*(C + E*V))) (0061) S = T/DSQRT(U + T*T) (0062) UM = U - 1. (0063) DELL = 1. (0064) DO 70 M = 1,50 (0065) H = 1. - S*S (0066) R = 0.0 (0067) IF ( DMOD(U,2.D0).EQ.0.0 ) GO TO 49 (0068) DD = DSQRT(H) (0069) N = 0.5*UM (0070) DO 45 I = 1,N (0071) Z = 2*I (0072) R = R + DD (0073) D = DD (0074) 45 DD = DD * H * (Z/(Z+1.)) (0075) R = PD*(R*S + DARSIN(S)) (0076) D = PD*D*UM (0077) GO TO 61 (0078) 49 DD = 1. (0079) N = 0.5*U (0080) DO 55 I = 1,N (0081) Z = 2*I (0082) R = R + DD (0083) D = DD (0084) 55 DD = DD*H*((Z-1.)/Z) (0085) R = R*S (0086) D = D*UM (0087) 61 CONTINUE (0088) DEL = (P-R)/D (0089) IF( DABS( DEL/DELL ) .GT.0.5) GO TO 72 (0090) DELL = DEL (0091) S = S + DEL (0092) IF( DABS(DEL) .LT. 1.D-8 ) GO TO 72 (0093) 70 CONTINUE (0094) GO TO 72 (0095) 71 S =DSIN(P/PD) (0096) 72 CRTAU = S*DSQRT(WNU) (0097) RETURN (0098) END PROGRAM SIZE: PROCEDURE - 001234 LINKAGE - 000224 STACK - 000066 A D LINKAGE 000520 0055M 0060 AA D LINKAGE 000450 0040M 0041 0046M 0047M 0048 0050A ALPH D ARGUMENT 000050 0001S 0032 0033 0039 0040 0044 0047 B D LINKAGE 000524 0056M 0060 C D LINKAGE 000530 0057M 0060 CRTAU D ARGUMENT 000053 0001S 0034M 0096M D D LINKAGE 000606 0073M 0076M 0083M 0086M 0088 DABS D EXTERNAL 000000 0089 0092 DARSIN D EXTERNAL 000000 0075 DD D LINKAGE 000574 0068M 0072 0073 0074M 0078M 0082 0083 0084M DEL D LINKAGE 000614 0088M 0089 0090 0091 0092A DELL D LINKAGE 000554 0063M 0089 0090M DELT D LINKAGE 000454 0041M 0044M 0045 0046 DLOG D EXTERNAL 000000 0050 DLOG$X EXTERNAL 000000 0074 DMOD D EXTERNAL 000000 0067 DSIN D EXTERNAL 000000 0095 DSIN$X D EXTERNAL 000000 0096 DSQR$X D EXTERNAL 000000 0074 0098 DSQRT D EXTERNAL 000000 0051 0061 0068 0096 E D LINKAGE 000534 0058M 0060 F D LINKAGE 000476 0050M 0051A 0052 G D LINKAGE 000504 0051M 0052 H D LINKAGE 000562 0065M 0068A 0074 0084 I J LINKAGE 000460 0042M 0043 0070M 0071 0080M 0081 M J LINKAGE 000560 0064M N J LINKAGE 000600 0069M 0070 0079M 0080 NT J ARGUMENT 000042 0001S 0038 NU J ARGUMENT 000045 0001S 0029 P D LINKAGE 000470 0048M 0088 0095 PD D LINKAGE 000424 0027M 0075 0076 0095 PI D LINKAGE 000420 0026I 0027 Q D LINKAGE 000444 0038M 0040 0044 0047 R D LINKAGE 000566 0066M 0072M 0075M 0082M 0085M 0088 S D LINKAGE 000430 0028M 0061M 0065 0075A 0085 0091M 0095M 0096 T D LINKAGE 000544 0060M 0061 U D LINKAGE 000440 0030M 0031 0049 0059 0061 0062 0067A 0079 UM D LINKAGE 000550 0062M 0069 0076 0086 V D LINKAGE 000540 0059M 0060 WNU D LINKAGE 000434 0029M 0030 0096A X D LINKAGE 000510 0052M 0054 0055 0056 0057 0058 0060 XI D LINKAGE 000462 0043M 0044 Y D LINKAGE 000514 0054M 0055 0056 0057 0058 Z D LINKAGE 000602 0071M 0074 0081M 0084 $10 000045 0033 0038D $18 000130 0042 0046D $19 000147 0039 0047D $20 000172 0045 0048D $45 000563 0070 0074D $49 000645 0067 0078D $55 000703 0080 0084D $61 000744 0077 0087D $70 001011 0064 0093D $71 001022 0049 0095D $72 001036 0031 0032 0089 0092 0094 0096D 0000 ERRORS [FTN-REV18.2] SUBROUTINE TKSTER(I,J,AP,NSR,R1,XO,YO,RKO,TT,S) TKSTER (0099) SUBROUTINE TKSTER(I,J,AP,NSR,R1,XO,YO,RKO,TT,S) (0100) C*********************************************************************** (0101) C* (0102) C* TKSTER COMPUTES THE ARC TO CHORD CORRECTION AND LINE SCALE OF LINE I (0103) C* TO J (SEQUENCE NUMBERS) FOR THE DOUBLE STEREOGRAPHIC MAP PROJECTION. (0104) C* (0105) C* (0106) C* INPUT: (0107) C* I,J- SEQUENCE NUMBERS OF STATIONS FROM AND TO (0108) C* AP,NSR- DESCRIBED IN MAIN (0109) C* R1- RADIUS OF CONFORMAL SPHERE (0110) C* XO,YO- COORDINATES OF ORIGIN OF PROJECTION (0111) C* RKO- POINT SCALE AT THE ORIGIN (0112) C* (0113) C* OUTPUT: (0114) C* TT- ARC TO CHORD CORRECTION I TO J (0115) C* S- LINE SCALE I TO J (0116) C* (0117) C* (0118) C* WRITTEN BY: (0119) C* R.R. STEEVES, JULY, 1978 (0120) C* (0121) C*********************************************************************** (0122) IMPLICIT REAL*8(A-H,O-Z) (0123) DIMENSION AP(NSR,12) (0124) X1=AP(I,1)-XO (0125) Y1=AP(I,2)-YO (0126) X2=AP(J,1)-XO (0127) Y2=AP(J,2)-YO (0128) TT=DATAN2(X1*Y2-X2*Y1,X1*X2+Y1*Y2+(RKO*R1*2.D0)**2) (0129) RKI=AP(I,11) (0130) RKJ=AP(J,11) (0131) YM=(Y1+Y2)/2.0D0 (0132) XM=(X1+X2)/2.0D0 (0133) RKM=RKO+(XM**2+YM**2)/4.D0/RKO/R1**2 (0134) S=1.D0/((1.D0/RKI+4.D0/RKM+1.D0/RKJ)/6.D0) (0135) RETURN (0136) END PROGRAM SIZE: PROCEDURE - 000376 LINKAGE - 000066 STACK - 000114 AP D ARGUMENT 000050 0099S 0123S 0124 0125 0126 0127 0129 0130 DATAN2 D EXTERNAL 000000 0128 I J ARGUMENT 000042 0099S 0124 0125 0129 J J ARGUMENT 000045 0099S 0126 0127 0130 R1 D ARGUMENT 000056 0099S 0128 0133 RKI D LINKAGE 000442 0129M 0134 RKJ D LINKAGE 000446 0130M 0134 RKM D LINKAGE 000462 0133M 0134 RKO D ARGUMENT 000067 0099S 0128 0133 S D ARGUMENT 000075 0099S 0134M TT D ARGUMENT 000072 0099S 0128M X1 D LINKAGE 000420 0124M 0128 0132 X2 D LINKAGE 000430 0126M 0128 0132 XM D LINKAGE 000456 0132M 0133 XO D ARGUMENT 000061 0099S 0124 0126 Y1 D LINKAGE 000424 0125M 0128 0131 Y2 D LINKAGE 000434 0127M 0128 0131 YM D LINKAGE 000452 0131M 0133 YO D ARGUMENT 000064 0099S 0125 0127 0000 ERRORS [FTN-REV18.2] SUBROUTINE TKTM(I,J,AP,NSR,RKO,AA,BB,XO,TT,S) TKTM00 (0137) SUBROUTINE TKTM(I,J,AP,NSR,RKO,AA,BB,XO,TT,S) (0138) C*********************************************************************** (0139) C* (0140) C* TKTM COMPUTES THE ARC TO CHORD CORRECTION AND THE LINE SCALE FOR THE (0141) C* LINE I TO J, FOR THE TRANSVERSE MERCATOR PROJECTION. (0142) C* (0143) C* (0144) C* INPUT: (0145) C* I- SEQUENCE NUMBER OF STATION FROM (0146) C* J- SEQUENCE NUMBER OF STATION TO (0147) C* AP,NSR- DESCRIBED IN MAIN (0148) C* RKO- SCALE FACTOR AT THE CENTRAL MERIDIAN (0149) C* AA,BB- SEMI MAJOR AND SEMI MINOR AXES OF THE REFERENCE ELLIPSIO (0150) C* X0- FALSE EASTING OF THE CENTRAL MERIDIAN (0151) C* (0152) C* (0153) C* OUTPUT: (0154) C* TT- ARC TO CHORD CORRECTION IN RADIANS (0155) C* S- LINE SCALE (0156) C* (0157) C* (0158) C* WRITTEN BY: (0159) C* R.R. STEEVES, JUNE, 1978 (0160) C* (0161) C*********************************************************************** (0162) IMPLICIT REAL*8(A-H,O-Z) (0163) DIMENSION AP(NSR,12) (0164) PHI=(AP(I,9)+AP(J,9))/2.D0 (0165) ESQ=(AA**2-BB**2)/AA**2 (0166) R2=AA**2*(1.D0-ESQ)/(1.D0-ESQ*DSIN(PHI)**2)**2 (0167) X1=AP(I,1)-XO (0168) X2=AP(J,1)-XO (0169) XU2=X1**2+X1*X2+X2**2 (0170) S=RKO*(1.D0+XU2/6.D0/R2*(1.D0+XU2/36.D0/R2)) (0171) Y1=AP(I,2) (0172) Y2=AP(J,2) (0173) TT=(Y2-Y1)*(X2+2.D0*X1)/6.D0/R2*(1.D0-(2.D0*X1+X2)**2/27.D0/R2) (0174) RETURN (0175) END PROGRAM SIZE: PROCEDURE - 000362 LINKAGE - 000062 STACK - 000114 AA D ARGUMENT 000061 0137S 0165 0166 AP D ARGUMENT 000050 0137S 0163S 0164 0167 0168 0171 0172 BB D ARGUMENT 000064 0137S 0165 DSIN D EXTERNAL 000000 0166 DSIN$X D EXTERNAL 000000 0175 ESQ D LINKAGE 000424 0165M 0166 I J ARGUMENT 000042 0137S 0164 0167 0171 J J ARGUMENT 000045 0137S 0164 0168 0172 PHI D LINKAGE 000420 0164M 0166A R2 D LINKAGE 000432 0166M 0170 0173 RKO D ARGUMENT 000056 0137S 0170 S D ARGUMENT 000075 0137S 0170M TT D ARGUMENT 000072 0137S 0173M X1 D LINKAGE 000436 0167M 0169 0173 X2 D LINKAGE 000442 0168M 0169 0173 XO D ARGUMENT 000067 0137S 0167 0168 XU2 D LINKAGE 000446 0169M 0170 Y1 D LINKAGE 000452 0171M 0173 Y2 D LINKAGE 000456 0172M 0173 0000 ERRORS [FTN-REV18.2] SUBROUTINE TMSFMC(PHI,DLAM,SFO,A,B,SF,C) TMSFMC (0176) SUBROUTINE TMSFMC(PHI,DLAM,SFO,A,B,SF,C) (0177) C*********************************************************************** (0178) C* (0179) C* THIS ROUTINE COMPUTES THE POINT SCALE FACTOR AND MERIDIAN (0180) C* CONVERGENCE (FOR A POINT DEFINED BY PHI,DLAM) FOR A TRANSVERSE (0181) C* MERCATOR PROJECTION DEFINED BY THE SCALE FACTOR SFO AT THE (0182) C* CENTRAL MERIDIAN. (0183) C* (0184) C* (0185) C* INPUT: (0186) C* PHI - ELLIPSOIDAL LATITUDE OF THE POINT, IN RADIANS. (0187) C* DLAM - ELLIPSOIDAL LONITUDE OF THE POINT MINUS THE (0188) C* ELLIPSOIDAL LONGITUDE OF THE CENTRAL MERIDIAN OF (0189) C* PROJECTION, (LONGITUDE POSITIVE EAST), IN RADIANS. (0190) C* SFO - SCALE AT THE CENTRAL MERIDIAN. (0191) C* A,B - SEMI-MAJOR AND SEMI-MINOR AXES OF THE REFERENCE (0192) C* ELLIPSOID RESPECTIVELY, IN METRES. (0193) C* (0194) C* OUTPUT: (0195) C* SF - POINT SCALE AT THE POINT. (0196) C* C - MERIDIAN CONVERGENCE AT THE POINT, IN RADIANS. (0197) C* (0198) C* (0199) C* WRITTEN BY: (0200) C* R.R. STEEVES, AUG., 1977 (0201) C* (0202) C*********************************************************************** (0203) IMPLICIT REAL*8(A-Z) (0204) CP=DCOS(PHI) (0205) T=DTAN(PHI) (0206) ETA=DSQRT((A*A-B*B)/(B*B)*CP**2) (0207) C=DLAM*DSIN(PHI)*(1.D0+DLAM**2*CP**2/3.D0*(1.D0+3.D0*ETA**2+2.D0* (0208) 1 ETA**4)+DLAM**4*CP**4/15.D0*(2.D0-T**2)) (0209) SF=1.D0+DLAM**2*CP**2/2.D0*(1.D0+ETA**2)+DLAM**4*CP**4/24.D0*(5.D0 (0210) 1 -4.D0*T**2) (0211) SF=SF*SFO (0212) RETURN (0213) END PROGRAM SIZE: PROCEDURE - 000306 LINKAGE - 000046 STACK - 000120 A D ARGUMENT 000053 0176S 0206 B D ARGUMENT 000056 0176S 0206 C D ARGUMENT 000064 0176S 0207M CP D LINKAGE 000422 0204M 0206 0207 0209 DCOS D EXTERNAL 000000 0204 DCOS$X D EXTERNAL 000000 0213 DLAM D ARGUMENT 000045 0176S 0207 0209 DSIN D EXTERNAL 000000 0207 DSIN$X D EXTERNAL 000000 0213 DSQR$X D EXTERNAL 000000 0213 DSQRT D EXTERNAL 000000 0206 DTAN D EXTERNAL 000000 0205 ETA D LINKAGE 000436 0206M 0207 0209 PHI D ARGUMENT 000042 0176S 0204A 0205A 0207A SF D ARGUMENT 000061 0176S 0209M 0211M SFO D ARGUMENT 000050 0176S 0211 T D LINKAGE 000430 0205M 0207 0209 0000 ERRORS [FTN-REV18.2] SUBROUTINE TMXYPL(X,Y,A,B,SF,XO,CMRAD,PHI,OLAM) TMXYPL (0214) SUBROUTINE TMXYPL(X,Y,A,B,SF,XO,CMRAD,PHI,OLAM) (0215) C*********************************************************************** (0216) C* (0217) C* SUBROUTINE TMXYPL COMPUTES THE GEOGRAPHIC COORDINATES- LATITUDE (0218) C* AND LONGITUDE - GIVEN THE X,Y COORDINATES OF THE TRANSVERSE (0219) C* MERCATOR PROJECTION. THE EQUATIONS USED TO COMPUTE THE LONGITUDE (0220) C* AND LATITUDE ARE FROM THOMAS (1952). SUBROUTINE FPLAT IS USED (0221) C* TO COMPUTE THE FOOT-POINT LATITUDE. (0222) C* (0223) C* (0224) C* INPUT; (0225) C* X -EASTING COORDINATE OF THE TRANSVERSE MERCATOR (0226) C* PROJECTION. (0227) C* Y -NORTHING COORDINATE OF THE TRANSVERSE MERCATOR (0228) C* PROJECTION. (0229) C* A -SEMI-MAJOR AXES OF THE REFERENCE ELLIPSOID. (0230) C* B -SEMI-MINOR AXES OF THE REFERENCE ELLIPSOID. (0231) C* SF - SCALE OF THE CENTRAL MERIDIAN. (0232) C* XO - FALSE EASTING OF THE CENTRAL MERIDIAN. (0233) C* CMRAD - THE CENTRAL MERIDIAN,IN RADIANS. (0234) C* (0235) C* OUTPUT: (0236) C* PHI -LATITUDE OF THE POINT IN RADIANS (0237) C* OLAM-LONGITUDE OF THE POINT IN RADIANS (0238) C* (0239) C* (0240) C* WRITTEN BY: (0241) C* R.R. STEEVES, MAY, 1977 (0242) C* (0243) C*********************************************************************** (0244) IMPLICIT REAL*8(A-H,O-Z) (0245) X=(X-XO)/SF (0246) Y=Y/SF (0247) E=DSQRT((A**2-B**2)/A**2) (0248) CALL FPLAT(A,B,Y,PHI1) (0249) T=DTAN(PHI1) (0250) SP=DSIN(PHI1) (0251) CP=DCOS(PHI1) (0252) ETA=DSQRT((A**2-B**2)/B**2*CP**2) (0253) DN=A/DSQRT(1.0D0-E**2*SP**2) (0254) DM=A*(1.0D0-E**2)/DSQRT((1.0D0-E**2*SP**2)**3) (0255) PHI=PHI1-T*X**2/2.0D0/DM/DN+T*X**4/24.0D0/DM/DN**3*(5.0D0+3.0D0* (0256) 1 T**2+ETA**2-4.0D0*ETA**4-9.0D0*ETA**2*T**2)-T*X**6/720.0D0/DM/ (0257) 2 DN**5*(61.0D0+90.0D0*T**2+46.0D0*ETA**2+45.0D0*T**4-252.0D0*T** (0258) 3 2*ETA**2-3.0D0*ETA**4+100.0D0*ETA**6-66.0D0*T**2*ETA**4-90.0D0 (0259) 4 *T**4*ETA**2+88.0D0*ETA**8+225.0D0*T**4*ETA**4+84.0D0*T**2* (0260) 5 ETA**6-192.0D0*T**2*ETA**8) (0261) PHI=PHI+T*X**8/40320.0D0/DM/DN**7*(1385.0D0+3633.0D0*T**2+4095.0D0 (0262) 1 *T**4+1575.0D0*T**6) (0263) DLAM=(X/DN-(X/DN)**3/6.0D0*(1.0D0+2.0D0*T**2+ETA**2)+(X/DN)**5/ (0264) 1 120.0D0*(5.0D0+6.0D0*ETA**2+28.0D0*T**2-3.0D0*ETA**4+8.0D0*T**2 (0265) 2 *ETA**2+24.0D0*T**4-4.0D0*ETA**6+4.0D0*T**2*ETA**4+24.0D0*T**2* (0266) 3 ETA**6)-(X/DN)**7/5040.0D0*(61.0D0+662.0D0*T**2+1320.0D0*T**4+ (0267) 4 720.0D0*T**6))/CP (0268) OLAM=CMRAD+DLAM (0269) X=X*SF+XO (0270) Y=Y*SF (0271) RETURN (0272) END PROGRAM SIZE: PROCEDURE - 001426 LINKAGE - 000100 STACK - 000172 A D ARGUMENT 000050 0214S 0247 0248A 0252 0253 0254 B D ARGUMENT 000053 0214S 0247 0248A 0252 CMRAD D ARGUMENT 000064 0214S 0268 CP D LINKAGE 000452 0251M 0252 0263 DCOS D EXTERNAL 000000 0251 DCOS$X D EXTERNAL 000000 0272 DLAM D LINKAGE 000474 0263M 0268 DM D LINKAGE 000470 0254M 0255 0261 DN D LINKAGE 000462 0253M 0255 0261 0263 DSIN D EXTERNAL 000000 0250 DSIN$X D EXTERNAL 000000 0272 DSQR$X D EXTERNAL 000000 0272 DSQRT D EXTERNAL 000000 0247 0252 0253 0254 DTAN D EXTERNAL 000000 0249 E D LINKAGE 000422 0247M 0253 0254 ETA D LINKAGE 000456 0252M 0255 0263 FPLAT D EXTERNAL 000000 0248 OLAM D ARGUMENT 000072 0214S 0268M PHI D ARGUMENT 000067 0214S 0255M 0261M PHI1 D LINKAGE 000430 0248A 0249A 0250A 0251A 0255 SF D ARGUMENT 000056 0214S 0245 0246 0269 0270 SP D LINKAGE 000444 0250M 0253 0254 T D LINKAGE 000436 0249M 0255 0261 0263 X D ARGUMENT 000042 0214S 0245M 0255 0261 0263 0269M XO D ARGUMENT 000061 0214S 0245 0269 Y D ARGUMENT 000045 0214S 0246M 0248A 0270M 0000 ERRORS [FTN-REV18.2] SUBROUTINE TOELPS(IOB,DOB,DOBR,NOR,AA,BB,XO,YO,ZO,AP,NSR,NCORR,NO,TOELPS (0273) SUBROUTINE TOELPS(IOB,DOB,DOBR,NOR,AA,BB,XO,YO,ZO,AP,NSR,NCORR,NO, (0274) @ CNAM,NRED3,NCODE,NRED1,N3DIM,DLDH) (0275) C*********************************************************************** (0276) C* (0277) C* TOELPS COMPUTES CORRECTIONS AND MAKES REDUCTIONS TO OBSERVATIONS FRO (0278) C* THE TERRAIN TO THE ELLIPSOID. (0279) C* (0280) C* (0281) C* INPUT: (0282) C* -ALL DESCRIBED IN MAIN (0283) C* (0284) C* (0285) C* WRITTEN BY: (0286) C* R.R. STEEVES, JUNE, 1978 (0287) C* (0288) C*********************************************************************** (0289) IMPLICIT REAL*8(A-H,O-Z) (0290) DIMENSION IOB(NOR,4),DOB(NOR,4),DOBR(NOR,4),AP(NSR,12),CNAM(NSR), (0291) @ DLDH(NOR,2) (0292) LOGICAL LRED (0293) LRED = .FALSE. (0294) IF(NCODE.NE.1.AND.NRED1.NE.0) LRED = .TRUE. (0295) IF(.NOT.LRED.AND.N3DIM.EQ.0) RETURN (0296) IF(NCORR.EQ.1)WRITE(6 , 101) (0297) IF(.NOT.LRED) WRITE(6,107) (0298) 107 FORMAT(1H /25X,'INPUT OF REDUCED DISTANCES: NO REDUCTION'//) (0299) IF(NCORR.EQ.1)WRITE(6 , 102) (0300) PI=3.141592653589793D0 (0301) RO=3600.D0*180.D0/PI (0302) I=1 (0303) J=1 (0304) 1 ID=IOB(I,1) (0305) IF(.NOT.LRED.AND.ID.NE.1) GOTO 49 (0306) IA=IOB(I,2) (0307) IF=IOB(I,3) (0308) IT=IOB(I,4) (0309) GOTO(10,20,30,40),ID (0310) C REDUCE DISTANCES FROM TERRAIN TO ELLIPSOID (0311) 10 CALL REDIS1(DOB(I,3),IA,IF,AA,BB,AP,NSR,C5,C6,CNAM,DLDH1,DLDH2, (0312) @ LRED) (0313) IF(NCORR.EQ.1)WRITE(6 , 103)CNAM(IA),CNAM(IA),CNAM(IF),DOBR(I,3) (0314) @,C5, (0315) @C6,DOB(I,3),DLDH1,DLDH2 (0316) 61 IF(N3DIM.EQ.0) GOTO 62 (0317) DLDH(I,1) = DLDH1*1.D-3 (0318) DLDH(I,2) = DLDH2*1.D-3 (0319) 62 CONTINUE (0320) I=I+1 (0321) GOTO50 (0322) C REDUCE DIRECTIONS FROM TERRAIN TO ELLIPSOID (0323) 20 IA=IOB(I,2) (0324) IF=IOB(I,3) (0325) IDEG=DOB(I,2) (0326) IMIN=DOB(I,3) (0327) CALL DMSRAD(IDEG,IMIN,DOB(I,4),R) (0328) CALL REDIR1(R,IA,IF,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) (0329) IF(J.EQ.1)SR=C1+C2+C3 (0330) C1=C1*RO (0331) C2=C2*RO (0332) C3=C3*RO (0333) IF(J.NE.1)GOTO21 (0334) IF(NCORR.EQ.1)WRITE(6 , 104)J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IM (0335) @IN, (0336) @ DOB(I,4),C1,C2,C3,IDEG,IMIN,DOB(I,4) (0337) GOTO22 (0338) 21 R=R-SR (0339) IF(R.LT.0.D0)R=R+2.D0*PI (0340) CALL RADMS(R,IDE,IMI,SEC) (0341) IF(NCORR.EQ.1)WRITE(6 , 104)J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IM (0342) @IN, (0343) @ DOB(I,4),C1,C2,C3,IDE,IMI,SEC (0344) DOB(I,2)=IDE (0345) DOB(I,3)=IMI (0346) DOB(I,4)=SEC (0347) 22 I=I+1 (0348) IF(IOB(I-1,1).EQ.-2)J=1 (0349) IF(IOB(I-1,1).EQ.-2)GOTO50 (0350) J=J+1 (0351) GOTO20 (0352) C REDUCE ANGLES FROM TERRAIN TO ELLIPSOID (0353) 30 IDEG=DOB(I,2) (0354) IMIN=DOB(I,3) (0355) CALL DMSRAD(IDEG,IMIN,DOB(I,4),R) (0356) CALL REANG1(R,IA,IF,IT,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3) (0357) IF(R.LT.0.D0)R=R+2.D0*PI (0358) C1=C1*RO (0359) C2=C2*RO (0360) C3=C3*RO (0361) CALL RADMS(R,IDE,IMI,SEC) (0362) IF(NCORR.EQ.1)WRITE(6 , 105)CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN (0363) @, (0364) @ DOB(I,4),C1,C2,C3,IDE,IMI,SEC (0365) DOB(I,2)=IDE (0366) DOB(I,3)=IMI (0367) DOB(I,4)=SEC (0368) I=I+1 (0369) GOTO50 (0370) C REDUCE AZIMUTHS FROM TERRAIN TO ELLIPSOID (0371) 40 IF(NRED3.EQ.0)I=I+1 (0372) IF(NRED3.EQ.0)GOTO50 (0373) IDEG=DOB(I,2) (0374) IMIN=DOB(I,3) (0375) CALL DMSRAD(IDEG,IMIN,DOB(I,4),R) (0376) CALL REDAZ1(R ,IA,IF,AA,BB,AP,NSR,XO,YO,ZO,C1,C2,C3,C4) (0377) IF(R.LT.0.D0)R=R+2.D0*PI (0378) C1=C1*RO (0379) C2=C2*RO (0380) C3=C3*RO (0381) C4=C4*RO (0382) CALL RADMS(R,IDE,IMI,SEC) (0383) IF(NCORR.EQ.1)WRITE(6 , 106)CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN (0384) @, (0385) @ DOB(I,4),C1,C2,C3,C4,IDE,IMI,SEC (0386) DOB(I,2)=IDE (0387) DOB(I,3)=IMI (0388) DOB(I,4)=SEC (0389) 49 CONTINUE (0390) I=I+1 (0391) 50 IF(I.LE.NO)GOTO1 (0392) 101 FORMAT('1',24X,'SUMMARY OF REDUCTION OF OBSERVATIONS FROM TERRAIN (0393) @TO ELLIPSOID',/,' ',24X,62('-'),//) (0394) 102 FORMAT(' ',54X,'GRAVI-',2X,'SKEW',2X,'TO GE-',2X,'AZI- SPATIAL',2X (0395) @,'CHORD',3X,'REDUCED',4X,'DERIVATIVE [MM/M]'/ (0396) @, ,' ',13X,'AT',7X,'FROM',5X,'TO',9X,'OBSERVE (0397) @D',4X,'METRIC',1X,'NORMAL ODESIC',2X,'MUTH',1X,'TO CHORD TO EL',2X (0398) @,'OBSERVATION',1X,'DL/DHI',3X,'DL/DHJ'/) (0399) 103 FORMAT(' ','DISTANCE',5X,A8,1X,A8,1X,A8,F11.3,30X,2F8.3,F12.3, (0400) @ 1X,2F8.1/) (0401) 104 FORMAT(' ','DIRECTION',I2,2X,A8,1X,A8,1X,A8,I4,I3,4F7.3,21X,I4,I3, (0402) @ F7.3,/) (0403) 105 FORMAT(' ','ANGLE',8X,A8,1X,A8,1X,A8,I4,I3,4F7.3,21X,I4,I3,F7.3,/) (0404) 106 FORMAT(' ','AZIMUTH',6X,A8,1X,A8,1X,A8,I4,I3,5F7.3,14X,I4,I3,F7.3, (0405) @ /) (0406) RETURN (0407) END PROGRAM SIZE: PROCEDURE - 003632 LINKAGE - 000160 STACK - 000144 AA D ARGUMENT 000060 0273S 0311A 0328A 0356A 0376A AP D ARGUMENT 000077 0273S 0290S 0311A 0328A 0356A 0376A BB D ARGUMENT 000063 0273S 0311A 0328A 0356A 0376A C1 D LINKAGE 000514 0328A 0329 0330M 0334 0341 0356A 0358M 0362 0376A 0378M 0383 C2 D LINKAGE 000520 0328A 0329 0331M 0334 0341 0356A 0359M 0362 0376A 0379M 0383 C3 D LINKAGE 000524 0328A 0329 0332M 0334 0341 0356A 0360M 0362 0376A 0380M 0383 C4 D LINKAGE 000554 0376A 0381M 0383 C5 D LINKAGE 000456 0311A 0313 C6 D LINKAGE 000462 0311A 0313 CNAM D ARGUMENT 000113 0273S 0290S 0311A 0313 0334 0341 0362 0383 DLDH D ARGUMENT 000132 0273S 0290S 0317M 0318M DLDH1 D LINKAGE 000466 0311A 0313 0317 DLDH2 D LINKAGE 000472 0311A 0313 0318 DMSRAD D EXTERNAL 000000 0327 0355 0375 DOB D ARGUMENT 000047 0273S 0290S 0311A 0313 0325 0326 0327A 0334 0341 0344M 0345M 0346M 0353 0354 0355A 0362 0365M 0366M 0367M 0373 0374 0375A 0383 0386M 0387M 0388M DOBR D ARGUMENT 000052 0273S 0290S 0313 I J LINKAGE 000440 0302M 0304 0306 0307 0308 0311 0313 0317 0318 0320M 0323 0324 0325 0326 0327 0334 0341 0344 0345 0346 0347M 0348 0349 0353 0354 0355 0362 0365 0366 0367 0368M 0371M 0373 0374 0375 0383 0386 0387 0388 0390M 0391 IA J LINKAGE 000446 0306M 0311A 0313 0323M 0328A 0334 0341 0356A 0362 0376A 0383 ID J LINKAGE 000444 0304M 0305 0309 IDE J LINKAGE 000540 0340A 0341 0344 0361A 0362 0365 0382A 0383 0386 IDEG J LINKAGE 000500 0325M 0327A 0334 0341 0353M 0355A 0362 0373M 0375A 0383 IF J LINKAGE 000450 0307M 0311A 0313 0324M 0328A 0334 0341 0356A 0362 0376A 0383 IMI J LINKAGE 000542 0340A 0341 0345 0361A 0362 0366 0382A 0383 0387 IMIN J LINKAGE 000502 0326M 0327A 0334 0341 0354M 0355A 0362 0374M 0375A 0383 IOB J ARGUMENT 000044 0273S 0290S 0304 0306 0307 0308 0323 0324 0348 0349 IT J LINKAGE 000452 0308M 0356A 0362 J J LINKAGE 000442 0303M 0329 0333 0334 0341 0348M 0350M LRED L LINKAGE 000400 0292S 0293M 0294M 0295 0297 0305 0311A N3DIM J ARGUMENT 000127 0273S 0295 0316 NCODE J ARGUMENT 000121 0273S 0294 NCORR J ARGUMENT 000105 0273S 0296 0299 0313 0334 0341 0362 0383 NO J ARGUMENT 000110 0273S 0391 NRED1 J ARGUMENT 000124 0273S 0294 NRED3 J ARGUMENT 000116 0273S 0371 0372 NSR J ARGUMENT 000102 0273S 0290S 0311A 0328A 0356A 0376A PI D LINKAGE 000430 0300M 0301 0339 0357 0377 R D LINKAGE 000506 0327A 0328A 0338M 0339M 0340A 0355A 0356A 0357M 0361A 0375A 0376A 0377M 0382A RADMS D EXTERNAL 000000 0340 0361 0382 REANG1 D EXTERNAL 000000 0356 REDAZ1 D EXTERNAL 000000 0376 REDIR1 D EXTERNAL 000000 0328 REDIS1 D EXTERNAL 000000 0311 RO D LINKAGE 000434 0301M 0330 0331 0332 0358 0359 0360 0378 0379 0380 0381 SEC D LINKAGE 000544 0340A 0341 0346 0361A 0362 0367 0382A 0383 0388 SR D LINKAGE 000530 0329M 0338 XO D ARGUMENT 000066 0273S 0328A 0356A 0376A YO D ARGUMENT 000071 0273S 0328A 0356A 0376A ZO D ARGUMENT 000074 0273S 0328A 0356A 0376A $1 000160 0304D 0391 $10 000303 0309 0311D $101 003113 0296 0392D $102 003174 0299 0394D $103 003375 0313 0399D $104 003437 0334 0341 0401D $105 003502 0362 0403D $106 003541 0383 0404D $107 000064 0297 0298D $20 000616 0309 0323D 0351 $21 001274 0333 0338D $22 001621 0337 0347D $30 001666 0309 0353D $40 002361 0309 0371D $49 003077 0305 0389D $50 003105 0321 0349 0369 0372 0391D $61 000543 0316D $62 000607 0316 0319D 0000 ERRORS [FTN-REV18.2] SUBROUTINE TOPLAN(IOB,DOB,NOR,XO,YO,RKO,AP,NSR,NCORR,NO,CNAM, TOPLAN (0408) SUBROUTINE TOPLAN(IOB,DOB,NOR,XO,YO,RKO,AP,NSR,NCORR,NO,CNAM, (0409) @ NRED3,NPROJ,AA,BB,R1,DOBR,NRED1) (0410) C*********************************************************************** (0411) C* (0412) C* TOPLAN COMPUTES CORRECTIONS AND MAKES REDUCTIONS TO OBSERVATIONS FRO (0413) C* THE ELLIPSOID TO THE MAPPING PLANE (0414) C* (0415) C* (0416) C* INPUT: (0417) C* -ALL DESCRIBED IN MAIN (0418) C* (0419) C* (0420) C* WRITTEN BY: (0421) C* R.R. STEEVES, JUNE, 1978 (0422) C* (0423) C*********************************************************************** (0424) IMPLICIT REAL*8(A-H,O-Z) (0425) DIMENSION IOB(NOR,4),DOB(NOR,4),AP(NSR,12),CNAM(NSR),DOBR(NOR,4) (0426) IF(NCORR.EQ.1)WRITE(6 ,101) (0427) IF(NCORR.EQ.1)WRITE(6 ,102) (0428) I=1 (0429) PI=3.141592653589793D0 (0430) 1 ID=IOB(I,1) (0431) IA=IOB(I,2) (0432) IF=IOB(I,3) (0433) IT=IOB(I,4) (0434) GOTO(10,20,30,40),ID (0435) C REDUCE DISTANCES FROM ELLIPSOID TO PLANE (0436) 10 SIJ=DOB(I,3) (0437) IF(NPROJ.EQ.1.OR.NPROJ.EQ.2)GOTO11 (0438) CALL TKTM(IA,IF,AP,NSR,RKO,AA,BB,XO,TT,S) (0439) GOTO12 (0440) 11 CALL TKSTER(IA,IF,AP,NSR,R1,XO,YO,RKO,TT,S) (0441) 12 DOB(I,3)=DOB(I,3)*S (0442) IF(NCORR.EQ.1)WRITE(6 ,103)CNAM(IA),CNAM(IA),CNAM(IF),SIJ,S,DOB( (0443) @I,3) (0444) I=I+1 (0445) GOTO50 (0446) C REUCE DIRECTIONS FROM ELLIPSOID TO PLANE (0447) 20 J=0 (0448) 21 J=J+1 (0449) IA=IOB(I,2) (0450) IF=IOB(I,3) (0451) IDEG=DOB(I,2) (0452) IMIN=DOB(I,3) (0453) SEC=DOB(I,4) (0454) IF(NPROJ.EQ.1.OR.NPROJ.EQ.2)GOTO22 (0455) CALL TKTM(IA,IF,AP,NSR,RKO,AA,BB,XO,TT,S) (0456) GOTO23 (0457) 22 CALL TKSTER(IA,IF,AP,NSR,R1,XO,YO,RKO,TT,S) (0458) 23 IF(J.NE.1)GOTO24 (0459) TT1=TT (0460) CALL RADMS(TT,IDT,IMT,ST) (0461) IF(NCORR.EQ.1)WRITE(6 ,104)J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMI (0462) @N,SEC, (0463) @ IDT,IMT,ST,IDEG,IMIN,SEC (0464) I=I+1 (0465) GOTO21 (0466) 24 CALL DMSRAD(IDEG,IMIN,SEC,R) (0467) R=R-TT+TT1 (0468) IF(R.LT.0.D0)R=R+2.D0*PI (0469) CALL RADMS(R,IDR,IMR,SR) (0470) CALL RADMS(TT,IDT,IMT,ST) (0471) DOB(I,2)=IDR (0472) DOB(I,3)=IMR (0473) DOB(I,4)=SR (0474) IF(NCORR.EQ.1)WRITE(6 ,104)J,CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMI (0475) @N,SEC, (0476) @IDT,IMT,ST,IDR,IMR,SR (0477) I=I+1 (0478) IF(IOB(I-1,1).EQ.-2)GOTO50 (0479) GOTO21 (0480) C REDUCE ANGLES FROM ELLIPSOID TO PLANE (0481) 30 IDEG=DOB(I,2) (0482) IMIN=DOB(I,3) (0483) SEC=DOB(I,4) (0484) IF(NPROJ.EQ.1.OR.NPROJ.EQ.2)GOTO31 (0485) CALL TKTM(IA,IF,AP,NSR,RKO,AA,BB,XO,TT1,S) (0486) CALL TKTM(IA,IT,AP,NSR,RKO,AA,BB,XO,TT2,S) (0487) GOTO32 (0488) 31 CALL TKSTER(IA,IF,AP,NSR,R1,XO,YO,RKO,TT1,S) (0489) CALL TKSTER(IA,IT,AP,NSR,R1,XO,YO,RKO,TT2,S) (0490) 32 TT=TT1-TT2 (0491) CALL DMSRAD(IDEG,IMIN,SEC,R) (0492) R=R+TT (0493) IF(R.LT.0.D0)R=R+2.D0*PI (0494) CALL RADMS(TT,IDT,IMT,ST) (0495) CALL RADMS(R,IDR,IMR,SR) (0496) DOB(I,2)=IDR (0497) DOB(I,3)=IMR (0498) DOB(I,4)=SR (0499) IF(NCORR.EQ.1)WRITE(6 ,105)CNAM(IA),CNAM(IF),CNAM(IT),IDEG,IMIN, (0500) @SEC, (0501) @ IDT,IMT,ST,IDR,IMR,SR (0502) I=I+1 (0503) GOTO50 (0504) C REDUCE AZIMUTHS FROM ELLIPSOID TO PLANE (0505) 40 IF(NRED3.EQ.0)I=I+1 (0506) IF(NRED3.EQ.0)GOTO50 (0507) IDEG=DOB(I,2) (0508) IMIN=DOB(I,3) (0509) SEC=DOB(I,4) (0510) IF(NPROJ.EQ.1.OR.NPROJ.EQ.2)GOTO41 (0511) CALL TKTM(IA,IF,AP,NSR,RKO,AA,BB,XO,TT,S) (0512) GOTO42 (0513) 41 CALL TKSTER(IA,IF,AP,NSR,R1,XO,YO,RKO,TT,S) (0514) 42 CALL DMSRAD(IDEG,IMIN,SEC,R) (0515) R=R-TT-AP(IA,12) (0516) IF(R.LT.0.D0)R=R+2.D0*PI (0517) CALL RADMS(TT,IDT,IMT,ST) (0518) CALL RADMS(AP(IA,12),IDM,IMM,SM) (0519) CALL RADMS(R,IDR,IMR,SR) (0520) DOB(I,2)=IDR (0521) DOB(I,3)=IMR (0522) DOB(I,4)=SR (0523) IF(NCORR.EQ.1)WRITE(6 ,106)CNAM(IA),CNAM(IA),CNAM(IF),IDEG,IMIN, (0524) @SEC, (0525) @ IDM,IMM,SM,IDT,IMT,ST,IDR,IMR,SR (0526) I=I+1 (0527) 50 IF(I.LE.NO)GOTO1 (0528) 101 FORMAT('1',21X,'SUMMARY OF REDUCTION OF OBSERVATIONS FROM ELLIPSOI (0529) @D TO MAPPING PLANE',/,' ',21X,68('-'),//) (0530) 102 FORMAT(' ',45X,'OBSERVATION MERIDIAN',8X,'ARC',8X,'LINE',7X,'RED (0531) @UCED',/,' ',16X,'AT',7X,'FROM',5X,'TO',7X,'(ON ELLIPSOID) CONVERGE (0532) @NCE',3X,'TO CHORD',5X,'SCALE',6X,'OBSERVATION',/) (0533) 103 FORMAT(' ',' DISTANCE',6X,A8,1X,A8,1X,A8,F12.3,28X,F11.7,F12.3,/) (0534) 104 FORMAT(' ',' DIRECTION',I3,2X,A8,1X,A8,1X,A8,I5,I3,F6.2,13X,I4,I3 (0535) @,F6.2,11X,I5,I3,F6.2,/) (0536) 105 FORMAT(' ',' ANGLE',9X,A8,1X,A8,1X,A8,I5,I3,F6.2,13X,I4,I3,F6.2, (0537) @ 11X,I5,I3,F6.2,/) (0538) 106 FORMAT(' ',' AZIMUTH',7X,A8,1X,A8,1X,A8,I5,I3,F6.2,I4,I3,F6.2,I4, (0539) @ I3,F6.2,11X,I5,I3,F6.2,/) (0540) RETURN (0541) END PROGRAM SIZE: PROCEDURE - 003622 LINKAGE - 000154 STACK - 000140 AA D ARGUMENT 000113 0408S 0438A 0455A 0485A 0486A 0511A AP D ARGUMENT 000066 0408S 0425S 0438A 0440A 0455A 0457A 0485A 0486A 0488A 0489A 0511A 0513A 0515 0518A BB D ARGUMENT 000116 0408S 0438A 0455A 0485A 0486A 0511A CNAM D ARGUMENT 000102 0408S 0425S 0442 0461 0474 0499 0523 DMSRAD D EXTERNAL 000000 0466 0491 0514 DOB D ARGUMENT 000047 0408S 0425S 0436 0441M 0442 0451 0452 0453 0471M 0472M 0473M 0481 0482 0483 0496M 0497M 0498M 0507 0508 0509 0520M 0521M 0522M I J LINKAGE 000430 0428M 0430 0431 0432 0433 0436 0441 0442 0444M 0449 0450 0451 0452 0453 0464M 0471 0472 0473 0477M 0478 0481 0482 0483 0496 0497 0498 0502M 0505M 0507 0508 0509 0520 0521 0522 0526M 0527 IA J LINKAGE 000440 0431M 0438A 0440A 0442 0449M 0455A 0457A 0461 0474 0485A 0486A 0488A 0489A 0499 0511A 0513A 0515 0518 0523 ID J LINKAGE 000436 0430M 0434 IDEG J LINKAGE 000472 0451M 0461 0466A 0474 0481M 0491A 0499 0507M 0514A 0523 IDM J LINKAGE 000544 0518A 0523 IDR J LINKAGE 000530 0469A 0471 0474 0495A 0496 0499 0519A 0520 0523 IDT J LINKAGE 000510 0460A 0461 0470A 0474 0494A 0499 0517A 0523 IF J LINKAGE 000442 0432M 0438A 0440A 0442 0450M 0455A 0457A 0461 0474 0485A 0488A 0499 0511A 0513A 0523 IMIN J LINKAGE 000474 0452M 0461 0466A 0474 0482M 0491A 0499 0508M 0514A 0523 IMM J LINKAGE 000546 0518A 0523 IMR J LINKAGE 000532 0469A 0472 0474 0495A 0497 0499 0519A 0521 0523 IMT J LINKAGE 000512 0460A 0461 0470A 0474 0494A 0499 0517A 0523 IOB J ARGUMENT 000044 0408S 0425S 0430 0431 0432 0433 0449 0450 0478 IT J LINKAGE 000444 0433M 0486A 0489A 0499 J J LINKAGE 000470 0447M 0448M 0458 0461 0474 NCORR J ARGUMENT 000074 0408S 0426 0427 0442 0461 0474 0499 0523 NO J ARGUMENT 000077 0408S 0527 NPROJ J ARGUMENT 000110 0408S 0437 0454 0484 0510 NRED3 J ARGUMENT 000105 0408S 0505 0506 NSR J ARGUMENT 000071 0408S 0425S 0438A 0440A 0455A 0457A 0485A 0486A 0488A 0489A 0511A 0513A PI D LINKAGE 000432 0429M 0468 0493 0516 R D LINKAGE 000524 0466A 0467M 0468M 0469A 0491A 0492M 0493M 0495A 0514A 0515M 0516M 0519A R1 D ARGUMENT 000121 0408S 0440A 0457A 0488A 0489A 0513A RADMS D EXTERNAL 000000 0460 0469 0470 0494 0495 0517 0518 0519 RKO D ARGUMENT 000063 0408S 0438A 0440A 0455A 0457A 0485A 0486A 0488A 0489A 0511A 0513A S D LINKAGE 000460 0438A 0440A 0441 0442 0455A 0457A 0485A 0486A 0488A 0489A 0511A 0513A SEC D LINKAGE 000476 0453M 0461 0466A 0474 0483M 0491A 0499 0509M 0514A 0523 SIJ D LINKAGE 000446 0436M 0442 SM D LINKAGE 000550 0518A 0523 SR D LINKAGE 000534 0469A 0473 0474 0495A 0498 0499 0519A 0522 0523 ST D LINKAGE 000514 0460A 0461 0470A 0474 0494A 0499 0517A 0523 TKSTER D EXTERNAL 000000 0440 0457 0488 0489 0513 TKTM D EXTERNAL 000000 0438 0455 0485 0486 0511 TT D LINKAGE 000454 0438A 0440A 0455A 0457A 0459 0460A 0467 0470A 0490M 0492 0494A 0511A 0513A 0515 0517A TT1 D LINKAGE 000502 0459M 0467 0485A 0488A 0490 TT2 D LINKAGE 000540 0486A 0489A 0490 XO D ARGUMENT 000055 0408S 0438A 0440A 0455A 0457A 0485A 0486A 0488A 0489A 0511A 0513A YO D ARGUMENT 000060 0408S 0440A 0457A 0488A 0489A 0513A $1 000047 0430D 0527 $10 000161 0434 0436D $101 003122 0426 0528D $102 003206 0427 0530D $103 003337 0442 0533D $104 003376 0461 0474 0534D $105 003451 0499 0536D $106 003520 0523 0538D $11 000247 0437 0440D $12 000275 0439 0441D $20 000460 0434 0447D $21 000463 0448D 0465 0479 $22 000660 0454 0457D $23 000706 0456 0458D $24 001132 0458 0466D $30 001513 0434 0481D $31 001672 0484 0488D $32 001746 0487 0490D $40 002310 0434 0505D $41 002457 0510 0513D $42 002505 0512 0514D $50 003114 0445 0478 0503 0506 0527D 0000 ERRORS [FTN-REV18.2] SUBROUTINE UPDAT(NS,ITER,NF,NFIX,AP,X,NZERO,ZER,N,NSR,CNAM,NFR, UPDAT0 (0542) SUBROUTINE UPDAT(NS,ITER,NF,NFIX,AP,X,NZERO,ZER,N,NSR,CNAM,NFR, (0543) @ NDELX,NB,IBH,NBR,N3DIM,IC,ZZ) (0544) C*********************************************************************** (0545) C* (0546) C* UPDAT ADDS COMPUTED ITERATIVE CORRECTIONS TO THE PARAMETERS AND PRIN (0547) C* THEM IF REQUESTED. (0548) C* (0549) C* (0550) C* INPUT: (0551) C* -ALL DESCRIBED IN MAIN (0552) C* (0553) C* (0554) C* WRITTEN BY: (0555) C* R.R. STEEVES, MAY, 1976 (0556) C* REVISED, JUNE,1978 (0557) C* (0558) C*********************************************************************** (0559) IMPLICIT REAL*8(A-H,O-Z) (0560) DIMENSION NFIX(NFR),AP(NSR,12),X(N),CNAM(NSR),IBH(NBR),IC(NSR,3), (0561) @ ZZ(NSR) (0562) IF(ITER.EQ.0)WRITE(6 ,159) (0563) IF(ITER.GT.0.AND.NDELX.EQ.1)GOTO5 (0564) WRITE(6 , 101)ITER (0565) WRITE(6 , 102) (0566) 5 J=1 (0567) DO 3 I=1,NS (0568) IF(NF.EQ.0)GOTO8 (0569) DO 1 K=1,NF (0570) IF(I.EQ.NFIX(K))GOTO 31 (0571) 1 CONTINUE (0572) 8 IF(NB.EQ.0)GOTO2 (0573) DO 7 K=1,NB (0574) IF(I.EQ.IBH(K))GOTO 31 (0575) 7 CONTINUE (0576) 2 OLDX=AP(I,1) (0577) OLDY=AP(I,2) (0578) AP(I,1)=AP(I,1)-X(J) (0579) AP(I,2)=AP(I,2)-X(J+1) (0580) XX=-X(J) (0581) YY=-X(J+1) (0582) IF(ITER.GT.0.AND.NDELX.EQ.1)GOTO6 (0583) WRITE(6 , 103)CNAM(I),OLDX,OLDY,XX,YY,AP(I,1),AP(I,2) (0584) 6 J=J+2 (0585) 35 GOTO 36 (0586) 31 CONTINUE (0587) WRITE(6,103) CNAM(I) (0588) 36 CONTINUE (0589) 33 IF(N3DIM.EQ.0) GOTO 34 (0590) 11 IF(N3DIM.EQ.1.AND.IC(I,3).EQ.0) GOTO 12 (0591) AP(I,3) = AP(I,3) - ZZ(I) (0592) ZZ(I) = X(IC(I,3)) (0593) AP(I,3) = AP(I,3) + ZZ(I) (0594) 12 CONTINUE (0595) WRITE(6,105) ZZ(I),AP(I,3) (0596) 105 FORMAT(1H+,T98,F12.3,2X,F12.3) (0597) 34 CONTINUE (0598) 3 CONTINUE (0599) IF(NZERO.EQ.0)GOTO4 (0600) ZER=ZER-X(N) (0601) IF(ITER.GT.0.AND.NDELX.EQ.1)GOTO4 (0602) WRITE(6 , 104)ZER (0603) 101 FORMAT(' ',///,' ',45X,'ITERATION #',I3,/) (0604) 102 FORMAT(' ',10X,'STATION',8X,'OLD X',8X,'OLD Y',7X,'DX',11X,'DY', (0605) @ 11X,'NEW X',8X,'NEW Y',10X,'DH',10X,'NEW H'/) (0606) 103 FORMAT(' ',10X,A8,2F13.3,F12.5,F13.5,2F13.3,/) (0607) 104 FORMAT(' ',/,' ',40X,'ZERO ERROR= ',F9.3) (0608) 159 FORMAT('1',21X,'SUMMARY OF ITERATIVE CORRECTIONS TO INITIAL APPROX (0609) @IMATE COORDINATES:',/,' ',21X,67('-'),//) (0610) 4 RETURN (0611) END PROGRAM SIZE: PROCEDURE - 001216 LINKAGE - 000062 STACK - 000146 AP D ARGUMENT 000060 0542S 0560S 0576 0577 0578M 0579M 0583 0591M 0593M 0595 CNAM D ARGUMENT 000102 0542S 0560S 0583 0587 I J LINKAGE 000434 0567M 0570 0574 0576 0577 0578 0579 0583 0587 0590 0591 0592 0593 0595 IBH J ARGUMENT 000116 0542S 0560S 0574 IC J ARGUMENT 000127 0542S 0560S 0590 0592 ITER J ARGUMENT 000047 0542S 0562 0563 0564 0582 0601 J J LINKAGE 000432 0566M 0578 0579 0580 0581 0584M K J LINKAGE 000436 0569M 0570 0573M 0574 N J ARGUMENT 000074 0542S 0560S 0600 N3DIM J ARGUMENT 000124 0542S 0589 0590 NB J ARGUMENT 000113 0542S 0572 0573 NDELX J ARGUMENT 000110 0542S 0563 0582 0601 NF J ARGUMENT 000052 0542S 0568 0569 NFIX J ARGUMENT 000055 0542S 0560S 0570 NS J ARGUMENT 000044 0542S 0567 NZERO J ARGUMENT 000066 0542S 0599 OLDX D LINKAGE 000440 0576M 0583 OLDY D LINKAGE 000444 0577M 0583 X D ARGUMENT 000063 0542S 0560S 0578 0579 0580 0581 0592 0600 XX D LINKAGE 000450 0580M 0583 YY D LINKAGE 000454 0581M 0583 ZER D ARGUMENT 000071 0542S 0600M 0602 ZZ D ARGUMENT 000132 0542S 0560S 0591 0592M 0593 0595 $1 000112 0569 0571D $101 000740 0564 0603D $102 000763 0565 0604D $103 001050 0583 0587 0606D $104 001075 0602 0607D $105 000635 0595 0596D $11 000461 0590D $12 000564 0590 0594D $159 001120 0562 0608D $2 000161 0572 0576D $3 000652 0567 0598D $31 000426 0570 0574 0586D $33 000455 0589D $34 000652 0589 0597D $35 000425 0585D $36 000455 0585 0588D $4 001204 0599 0601 0610D $5 000057 0563 0566D $6 000417 0582 0584D $7 000150 0573 0575D $8 000123 0568 0572D 0000 ERRORS [FTN-REV18.2] SUBROUTINE WVEC(ICA,A,RU,W,P,N,NO,I,NOR) WVEC00 (0612) SUBROUTINE WVEC(ICA,A,RU,W,P,N,NO,I,NOR) (0613) C*********************************************************************** (0614) C* (0615) C* WVEC SEQUENTIALLY ADDS CONTRIBUTION OF DISTANCE, ANGLE OR AZIMUTH (0616) C* OBSERVATIONS TO THE CONSTANT VECTOR (0617) C* (0618) C* (0619) C* INPUT: (0620) C* -ALL DESCRIBED IN MAIN (0621) C* (0622) C* (0623) C* WRITTEN BY: (0624) C* R.R. STEEVES, MAY, 1976 (0625) C* (0626) C*********************************************************************** (0627) IMPLICIT REAL*8(A-H,O-Z) (0628) DIMENSION ICA(NOR,6),A(NOR,6),RU(N) (0629) DO 1 K=1,6 (0630) IF(ICA(I,K).EQ.0)GOTO1 (0631) RU(ICA(I,K))=RU(ICA(I,K))+A(I,K)*P*W (0632) 1 CONTINUE (0633) RETURN (0634) END PROGRAM SIZE: PROCEDURE - 000106 LINKAGE - 000022 STACK - 000102 A D ARGUMENT 000045 0612S 0628S 0631 I J ARGUMENT 000067 0612S 0630 0631 ICA J ARGUMENT 000042 0612S 0628S 0630 0631 K J LINKAGE 000420 0629M 0630 0631 P D ARGUMENT 000056 0612S 0631 RU D ARGUMENT 000050 0612S 0628S 0631M W D ARGUMENT 000053 0612S 0631 $1 000063 0629 0630 0632D 0000 ERRORS [FTN-REV18.2] SUBROUTINE XOBS(NCODE,RN,RU,N,SPX,NP,IPX,ICP,AP,OX,IB,NS,IC,WX XOBS00 (0635) SUBROUTINE XOBS(NCODE,RN,RU,N,SPX,NP,IPX,ICP,AP,OX,IB,NS,IC,WX (0636) @ ,NR,NP2R,NB2R,NSR,CNAM,NPR,NBR) (0637) C*********************************************************************** (0638) C* (0639) C* XOBS ADDS THE CONTRIBUTION OF WEIGHTED STATIONS TO THE NORMAL EQUATI (0640) C* AND CONSTANT VECTOR (0641) C* (0642) C* (0643) C* INPUT: (0644) C* -ALL DESCRIBED IN MAIN (0645) C* (0646) C* (0647) C* WRITTEN BY: (0648) C* R.R.STEEVES, JUNE, 1978 (0649) C* (0650) C*********************************************************************** (0651) IMPLICIT REAL*8(A-H,O-Z) (0652) DIMENSION RN(NR,NR),RU(NR),SPX(NB2R,NB2R),IPX(NBR),ICP(NR), (0653) @ OX(NPR,2),IB(NR),IC(NSR,3),WX(NP2R),CNAM(NSR),AP(NSR,12) (0654) J=1 (0655) DO 1 I=1,NP (0656) ICP(J)=IC(IPX(I),1) (0657) ICP(J+1)=IC(IPX(I),2) (0658) 1 J=J+2 (0659) NP2=NP*2 (0660) DO 2 I=1,NP2 (0661) DO 2 J=1,NP2 (0662) IF(ICP(I).EQ.0.OR.ICP(J).EQ.0)GOTO2 (0663) IF(ICP(I).GT.ICP(J))GOTO2 (0664) IF(ICP(I).LT.IB(ICP(J)))IB(ICP(J))=ICP(I) (0665) RN(ICP(I),ICP(J))=RN(ICP(I),ICP(J))+SPX(I,J) (0666) 2 CONTINUE (0667) IF(NCODE.EQ.1)GOTO6 (0668) J=1 (0669) DO 4 I=1,NP (0670) WX(J)=AP(IPX(I),1)-OX(I,1) (0671) WX(J+1)=AP(IPX(I),2)-OX(I,2) (0672) 4 J=J+2 (0673) DO 5 I=1,NP2 (0674) DO 5 J=1,NP2 (0675) IF(ICP(J).EQ.0)GOTO5 (0676) RU(ICP(J))=RU(ICP(J))+WX(I)*SPX(I,J) (0677) 5 CONTINUE (0678) 6 RETURN (0679) END PROGRAM SIZE: PROCEDURE - 000602 LINKAGE - 000026 STACK - 000156 AP D ARGUMENT 000074 0635S 0652S 0670 0671 I J LINKAGE 000422 0655M 0656 0657 0660M 0662 0663 0664 0665 0669M 0670 0671 0673M 0676 IB J ARGUMENT 000102 0635S 0652S 0664M IC J ARGUMENT 000110 0635S 0652S 0656 0657 ICP J ARGUMENT 000071 0635S 0652S 0656M 0657M 0662 0663 0664 0665 0675 0676 IPX J ARGUMENT 000066 0635S 0652S 0656 0657 0670 0671 J J LINKAGE 000420 0654M 0656 0657 0658M 0661M 0662 0663 0664 0665 0668M 0670 0671 0672M 0674M 0675 0676 NCODE J ARGUMENT 000044 0635S 0667 NP J ARGUMENT 000063 0635S 0655 0659 0669 NP2 J LINKAGE 000424 0659M 0660 0661 0673 0674 OX D ARGUMENT 000077 0635S 0652S 0670 0671 RN D ARGUMENT 000047 0635S 0652S 0665M RU D ARGUMENT 000052 0635S 0652S 0676M SPX D ARGUMENT 000060 0635S 0652S 0665 0676 WX D ARGUMENT 000113 0635S 0652S 0670M 0671M 0676 $1 000075 0655 0658D $2 000262 0660 0661 0662 0663 0666D $4 000434 0669 0672D $5 000546 0673 0674 0675 0677D $6 000570 0667 0678D 0000 ERRORS [FTN-REV18.2] SUBROUTINE XSIN(T,N,NCODE,NN,B,D,IID,IB,X,NR,CONVG,NSQRT,ITER, XSIN00 (0680) SUBROUTINE XSIN(T,N,NCODE,NN,B,D,IID,IB,X,NR,CONVG,NSQRT,ITER, (0681) @CNAM,NS,IOB,NOR,IC,NSR,ICA,RU,W,CPX,NP,WX,NP2R,NPR,NO,JCD,NITER, (0682) @INCQ,NUH) (0683) C*********************************************************************** (0684) C* (0685) C* XSIN COMPUTES THE CHOLESKI SQUARE ROOT OF A VARIABLE BANDED SYMMETRI (0686) C* MATRIX T. IT ALSO COMPUTES THE SOLUTION VECTOR OF THE LINEAR EQUATI (0687) C* T*X=B BY BACKWARD AND FORWARD SUBSTITUTIONS. THE INVERSE OF T IS CO (0688) C* PUTED IF THE SOLUTION VECTOR ELEMENTS ARE SMALLER THAN CONVG. SINGU (0689) C* ARITIES EXISTING IN T ARE DETECTED WHEN COMPUTING THE CHOLESKI SQUAR (0690) C* ROOT. XSIN IS USED FOR COMPUTING THE INVERSE OF THE INPUT (IF ANY) (0691) C* A PRIORI COVARIANCE MATRIX. (0692) C* (0693) C* (0694) C* WRITTEN BY: (0695) C* R.R. STEEVES, MAY, 1976 (0696) C* MODIFIED: MAY, 1978 (0697) C* MODIFIED: JULY,1978 (0698) C* MODIFIED: AUG., 1978 (0699) C* (0700) C*********************************************************************** (0701) IMPLICIT REAL*8(A-H,O-Z) (0702) DIMENSION T(NR,NR),D(NR),B(NR),X(NR),IB(NR),CNAM(NSR),IOB(NOR,4), (0703) @ IC(NSR,3),ICA(NOR,6),RU(NR),W(NOR),CPX(NPR),WX(NP2R) (0704) CRIT=1.D-16 (0705) DO 4 J=1,N (0706) DO 4 I=1,J (0707) IF(I.LT.IB(J))GOTO4 (0708) IF(I.EQ.1)GOTO2 (0709) M=I-1 (0710) SUM=0.0D0 (0711) IF(IB(I).LE.IB(J))L=IB(J) (0712) IF(IB(J).LT.IB(I))L=IB(I) (0713) IF(L.GT.M)GOTO2 (0714) DO 1 K=L,M (0715) 1 SUM=SUM+T(K,I)*T(K,J) (0716) IF(I.NE.J)GOTO5 (0717) IF(JCD.EQ.0)GOTO5 (0718) C2=(T(I,J)-SUM)**2 (0719) GI=C2/T(I,I) (0720) IF(GI.LE.CRIT.AND.INCQ.GT.0)GOTO23 (0721) IF(GI.LE.CRIT)CALL SINO(T,NR,I,N,IC,CNAM,NS,NSR) (0722) IF(GI.LE.CRIT)JCD=JCD+1 (0723) IF(GI.LE.CRIT)GOTO2 (0724) 5 T(I,J)=T(I,J)-SUM (0725) 2 IF(I.EQ.J)GOTO3 (0726) IF(T(I,I).EQ.0.D0)GOTO4 (0727) T(I,J)=T(I,J)/T(I,I) (0728) GOTO4 (0729) 3 IF(T(I,I).LE.0.D0)GOTO4 (0730) T(I,I)=DSQRT(T(I,I)) (0731) 4 CONTINUE (0732) IF(JCD.GT.1)STOP (0733) IF(NSQRT.NE.0.AND.((NSQRT.EQ.1.AND.ITER.EQ.0).OR.(NSQRT.EQ.2))) (0734) @ CALL PRAR(T,NR,NR,N,N,22,CNAM,NS,ITER,IOB,NOR,IC,NSR,ICA,RU,W, (0735) @ CPX,NP,WX,NR,NP2R,NPR,NO) (0736) IF(NCODE.EQ.1)GOTO10 (0737) D(1)=B(1)/T(1,1) (0738) DO 6 I=2,N (0739) SUM=0.0D0 (0740) K=I-1 (0741) DO 22 J=1,K (0742) 22 SUM=SUM+T(J,I)*D(J) (0743) 6 D(I)=(B(I)-SUM)/T(I,I) (0744) X(N)=D(N)/T(N,N) (0745) M=N-1 (0746) DO 8 I=1,M (0747) SUM=0.0D0 (0748) J=N-I+1 (0749) L=N-I (0750) DO 7 K=J,N (0751) 7 SUM=SUM+T(L,K)*X(K) (0752) 8 X(L)=(D(L)-SUM)/T(L,L) (0753) IID=0 (0754) NNH = NN - NUH (0755) DO 9 I=1,NNH (0756) IF(DABS(X(I)).GT.CONVG )IID=1 (0757) IF(IID.EQ.1.AND.ITER.LT.NITER)GOTO20 (0758) 9 CONTINUE (0759) 10 DO 17 J=1,N (0760) DO 17 I=1,J (0761) IF(I.LT.J)GOTO15 (0762) T(J,J)=1.0D0/T(J,J) (0763) GOTO17 (0764) 15 SUM=0.0D0 (0765) M=J-1 (0766) DO 16 K=I,M (0767) 16 SUM=SUM-T(I,K)*T(K,J) (0768) T(I,J)=SUM/T(J,J) (0769) 17 CONTINUE (0770) DO 19 J=1,N (0771) DO 19 I=1,J (0772) SUM=0.0D0 (0773) DO 18 K=J,N (0774) 18 SUM=SUM+T(I,K)*T(J,K) (0775) T(I,J)=SUM (0776) T(J,I)=SUM (0777) 19 CONTINUE (0778) 20 RETURN (0779) 23 IF(INCQ.EQ.1)WRITE(6 ,101)I,I (0780) 101 FORMAT(' ','*** INPUT ERROR #051 *** SINGULARITY ENCOUNTERED IN T (0781) @HE INPUT MATRIX FOR WEIGHTED STATIONS; POSITION (',I4,' ,',I4, (0782) @' )') (0783) IF(INCQ.EQ.2)WRITE(6 ,102)I,I (0784) 102 FORMAT(' ','*** INPUT ERROR #052 *** SINGULARITY ENCOUNTERED IN T (0785) @HE INPUT MATRIX FOR BLAHA STATIONS; POSITION (',I4,' ,',I4,' )') (0786) STOP (0787) END PROGRAM SIZE: PROCEDURE - 002346 LINKAGE - 000100 STACK - 000220 B D ARGUMENT 000060 0680S 0702S 0737 0743 C2 D LINKAGE 000446 0718M 0719 CNAM D ARGUMENT 000113 0680S 0702S 0721A 0733A CONVG D ARGUMENT 000102 0680S 0756 CPX D ARGUMENT 000146 0680S 0702S 0733A CRIT D LINKAGE 000424 0704M 0720 0721 0722 0723 D D ARGUMENT 000063 0680S 0702S 0737M 0742 0743M 0744 0752 DABS D EXTERNAL 000000 0756 DSQR$X EXTERNAL 000000 0731 DSQRT D EXTERNAL 000000 0730 GI D LINKAGE 000452 0719M 0720 0721 0722 0723 I J LINKAGE 000432 0706M 0707 0708 0709 0711 0712 0715 0716 0718 0719 0721A 0724 0725 0726 0727 0729 0730 0738M 0740 0742 0743 0746M 0748 0749 0755M 0756 0760M 0761 0766 0767 0768 0771M 0774 0775 0776 0779 0783 IB J ARGUMENT 000071 0680S 0702S 0707 0711 0712 IC J ARGUMENT 000127 0680S 0702S 0721A 0733A ICA J ARGUMENT 000135 0680S 0702S 0733A IID J ARGUMENT 000066 0680S 0753M 0756M 0757 INCQ J ARGUMENT 000176 0680S 0720 0779 0783 IOB J ARGUMENT 000121 0680S 0702S 0733A ITER J ARGUMENT 000110 0680S 0733A 0757 J J LINKAGE 000430 0705M 0706 0707 0711 0712 0715 0716 0718 0724 0725 0727 0741M 0742 0748M 0750 0759M 0760 0761 0762 0765 0767 0768 0770M 0771 0773 0774 0775 0776 JCD J ARGUMENT 000170 0680S 0717 0722M 0732 K J LINKAGE 000444 0714M 0715 0740M 0741 0750M 0751 0766M 0767 0773M 0774 L J LINKAGE 000442 0711M 0712M 0713 0714 0749M 0751 0752 M J LINKAGE 000434 0709M 0713 0714 0745M 0746 0765M 0766 N J ARGUMENT 000047 0680S 0705 0721A 0733A 0738 0744 0745 0748 0749 0750 0759 0770 0773 NCODE J ARGUMENT 000052 0680S 0736 NITER J ARGUMENT 000173 0680S 0757 NN J ARGUMENT 000055 0680S 0754 NNH J LINKAGE 000466 0754M 0755 NO J ARGUMENT 000165 0680S 0733A NOR J ARGUMENT 000124 0680S 0702S 0733A NP J ARGUMENT 000151 0680S 0733A NP2R J ARGUMENT 000157 0680S 0702S 0733A NPR J ARGUMENT 000162 0680S 0702S 0733A NR J ARGUMENT 000077 0680S 0702S 0721A 0733A NS J ARGUMENT 000116 0680S 0721A 0733A NSQRT J ARGUMENT 000105 0680S 0733 NSR J ARGUMENT 000132 0680S 0702S 0721A 0733A NUH J ARGUMENT 000201 0680S 0754 PRAR D EXTERNAL 000000 0733 RU D ARGUMENT 000140 0680S 0702S 0733A SINO D EXTERNAL 000000 0721 SUM D LINKAGE 000436 0710M 0715M 0718 0724 0739M 0742M 0743 0747M 0751M 0752 0764M 0767M 0768 0772M 0774M 0775 0776 T D ARGUMENT 000044 0680S 0702S 0715 0718 0719 0721A 0724M 0726 0727M 0729 0730M 0733A 0737 0742 0743 0744 0751 0752 0762M 0767 0768M 0774 0775M 0776M W D ARGUMENT 000143 0680S 0702S 0733A WX D ARGUMENT 000154 0680S 0702S 0733A X D ARGUMENT 000074 0680S 0702S 0744M 0751 0752M 0756A $1 000114 0714 0715D $10 001401 0736 0759D $101 002056 0779 0780D $102 002212 0783 0784D $15 001445 0761 0764D $16 001463 0766 0767D $17 001610 0759 0760 0763 0769D $18 001652 0773 0774D $19 002000 0770 0771 0777D $2 000374 0708 0713 0723 0725D $20 002022 0757 0778D $22 000712 0741 0742D $23 002023 0720 0779D $3 000453 0725 0729D $4 000505 0705 0706 0707 0726 0728 0729 0731D $5 000346 0716 0717 0724D $6 000764 0738 0743D $7 001155 0750 0751D $8 001227 0746 0752D $9 001370 0755 0758D 0000 ERRORS [FTN-REV18.2] SUBROUTINE ZERON(RN,RU,IB,N,NR) ZERON0 (0788) SUBROUTINE ZERON(RN,RU,IB,N,NR) (0789) C*********************************************************************** (0790) C* (0791) C* ZERON SETS ELEMENTS OF THE NORMAL EQUATIONS AND CONSTANT VECTOR TO Z (0792) C* ALSO INITIALIZES VARIABLE BANDING CONTROL VECTOR TO NUMBERS CORRESPO (0793) C* ING TO THE DIAGONAL OF THE NORMAL EQUATIONS. (0794) C* (0795) C* (0796) C* INPUT: (0797) C* -ALL DESCRIBED IN MAIN (0798) C* (0799) C* OUTPUT: (0800) C* -ALL DESCRIBED IN MAIN (0801) C* (0802) C* (0803) C* WRITTEN BY: (0804) C* R.R. STEEVES, AUG., 1978 (0805) C* (0806) C*********************************************************************** (0807) IMPLICIT REAL*8(A-H,O-Z) (0808) DIMENSION RN(NR,NR),RU(NR),IB(NR) (0809) DO 22 I=1,N (0810) IB(I)=I (0811) RU(I)=0.0D0 (0812) DO 22 J=1,N (0813) 22 RN(I,J)=0.0D0 (0814) RETURN (0815) END PROGRAM SIZE: PROCEDURE - 000120 LINKAGE - 000024 STACK - 000064 I J LINKAGE 000420 0809M 0810 0811 0813 IB J ARGUMENT 000050 0788S 0808S 0810M J J LINKAGE 000422 0812M 0813 N J ARGUMENT 000053 0788S 0809 0812 RN D ARGUMENT 000042 0788S 0808S 0813M RU D ARGUMENT 000045 0788S 0808S 0811M $22 000037 0809 0812 0813D 0000 ERRORS [FTN-REV18.2] (0816) (0817) (0818) $$$ REAL*8 FUNCTION DCHISQ(X) (0001) REAL*8 FUNCTION DCHISQ(X) (0002) (0003) C DENSITY FUNCTION OF THE CHI-SQUARE PROBABILITY DISTRIBUTION (0004) (0005) REAL*8 (0006) C C, (0007) D DGAMMA, (0008) X X /* ARGUMENT OF FUNCTION (0009) (0010) INTEGER*4 (0011) N NDF1, /* DEGREES OF FREEDOM (0012) N NDF2 /* DEGREES OF FREEDOM (0013) (0014) COMMON /STATIS/ NDF1 (0015) (0016) 1 IF(X.LE.0.D0) GOTO 2 (0017) C = 2.D0**(NDF1/2.D0)* DGAMMA(NDF1) (0018) IF(X.GT.3.D4) X = 3.D4 (0019) DCHISQ = X**(NDF1/2.D0 - 1.D0) * DEXP(-X/2.D0) / C (0020) RETURN (0021) 2 CONTINUE (0022) DCHISQ = 0.D0 (0023) RETURN (0024) END PROGRAM SIZE: PROCEDURE - 000146 LINKAGE - 000040 STACK - 000056 C D LINKAGE 000426 0005S 0017M 0019 DCHISQ D LINKAGE 000434 0001S 0019M 0022M DEXP D EXTERNAL 000000 0019 DEXP$X D EXTERNAL 000000 0021 DGAMMA D EXTERNAL 000000 0005S 0017 NDF1 J /STATIS/ 000000 0010S 0014S 0017A 0019 X D ARGUMENT 000042 0001S 0005S 0016 0018M 0019 $1 000001 0016D $2 000110 0016 0021D 0000 ERRORS [FTN-REV18.2] (0025) (0026) REAL*8 FUNCTION DGAMMA(N) (0027) (0028) C GAMMA FUNCTION FOR BETA = 2 (0029) C GAMMA = C(ALFA) = C(N/BETA) = C(N/2) (0030) (0031) INTEGER*4 N,N2 (0032) (0033) REAL*8 PI (0034) (0035) 900 IF(N.LE.0) GOTO 901 (0036) PI = 4.D0*DATAN(1.D0) (0037) DGAMMA = 1.D0 (0038) IF(MOD(N,2).EQ.1) DGAMMA = DSQRT(PI) (0039) (0040) 11 IF(N.LE.2) GOTO 12 (0041) N2 = (N+1)/2 - 1 (0042) 1 DO 2 I=1,N2 (0043) DGAMMA = DGAMMA * (N/2.D0 - I) (0044) 2 CONTINUE (0045) 12 CONTINUE (0046) RETURN (0047) (0048) C ERROR MESSAGE (0049) 901 CONTINUE (0050) WRITE(1,1901) (0051) 1901 FORMAT(' ***ILLEGAL ARGUMENT N<=0 IN FUNCTION DGAMMA***'/) (0052) DGAMMA = 0.D0 (0053) RETURN (0054) END PROGRAM SIZE: PROCEDURE - 000222 LINKAGE - 000046 STACK - 000052 DATAN D EXTERNAL 000000 0036 DATN$X EXTERNAL 000000 0040 DGAMMA D LINKAGE 000430 0026S 0037M 0038M 0043M 0052M DSQR$X J EXTERNAL 000000 0040 DSQRT D EXTERNAL 000000 0038 I J LINKAGE 000440 0042M 0043 MOD J EXTERNAL 000000 0038 N J ARGUMENT 000042 0026S 0031S 0035 0038 0040 0041 0043 N2 J LINKAGE 000436 0031S 0041M 0042 PI D LINKAGE 000424 0033S 0036M 0038A $1 000062 0042D $11 000042 0040D $12 000122 0040 0045D $1901 000135 0050 0051D $2 000111 0042 0044D $900 000001 0035D $901 000125 0035 0049D 0000 ERRORS [FTN-REV18.2] (0055) (0056) REAL*8 FUNCTION DNORM(X) (0057) REAL*8 X (0058) C (0059) C WAHRSCHEINLICHKEITSDICHTE DER NORMALVERTEILUNG (0060) C (0061) REAL *8 ZPI (0062) DATA ZPI /2.506628275D0/ (0063) DNORM = DEXP(-X*X/2.D0)/ZPI (0064) RETURN (0065) END PROGRAM SIZE: PROCEDURE - 000026 LINKAGE - 000032 STACK - 000052 DEXP D EXTERNAL 000000 0063 DEXP$X D EXTERNAL 000000 0065 DNORM D LINKAGE 000426 0056S 0063M X D ARGUMENT 000042 0056S 0057S 0063 ZPI D LINKAGE 000420 0061S 0062I 0063 0000 ERRORS [FTN-REV18.2] (0066) (0067) REAL*8 FUNCTION DNEWTO(F,F1,F0,X) (0068) C NEWTONS ITERATIVE METHOD TO SOLVE THE EQUATION: F(X) = F0 (0069) (0070) REAL*8 (0071) D DF, (0072) F F, (0073) F F0, (0074) F F1, (0075) F F1X, (0076) X X (0077) (0078) EXTERNAL F,F1 (0079) (0080) 1 DO 2 I=1,20 (0081) F1X = F1(X) (0082) IF(DABS(F1X).LT.1.D-24) F1X=1.D-24 (0083) DF = F(X) - F0 (0084) 3 IF(DABS(DF).LT.1.D-4) GOTO 4 (0085) X = X - DF/F1X (0086) 2 CONTINUE (0087) 4 CONTINUE (0088) DNEWTO = X (0089) RETURN (0090) END PROGRAM SIZE: PROCEDURE - 000112 LINKAGE - 000040 STACK - 000056 DABS D EXTERNAL 000000 0082 0084 DF D LINKAGE 000430 0070S 0083M 0084A 0085 DNEWTO D LINKAGE 000434 0067S 0088M F D ARGUMENT 000042 0067S 0070S 0078S 0083 F0 D ARGUMENT 000050 0067S 0070S 0083 F1 D ARGUMENT 000045 0067S 0070S 0078S 0081 F1X D LINKAGE 000422 0070S 0081M 0082M 0085 I J LINKAGE 000420 0080M X D ARGUMENT 000053 0067S 0070S 0081A 0083A 0085M 0088 $1 000001 0080D $2 000061 0080 0086D $3 000037 0084D $4 000072 0084 0087D 0000 ERRORS [FTN-REV18.2] (0091) (0092) REAL*8 FUNCTION DCNORM(X) (0093) C NORMAL CUMULATIVE PROBABILITY DISTRIBUTION FUNCTION (0094) (0095) INTEGER*4 K (0096) (0097) REAL*8 (0098) D DNORM, (0099) D DSIMPS, (0100) X X (0101) (0102) LOGICAL KONVER (0103) (0104) EXTERNAL DNORM (0105) (0106) DCNORM = -ROMINT(DNORM,X,0.D0,1.D-5,K,KONVER) (0107) RETURN (0108) END PROGRAM SIZE: PROCEDURE - 000034 LINKAGE - 000034 STACK - 000046 DCNORM D LINKAGE 000430 0092S 0106M DNORM D EXTERNAL 000000 0097S 0104S 0106A K J LINKAGE 000426 0095S 0106A KONVER L LINKAGE 000400 0102S 0106A ROMINT R EXTERNAL 000000 0106 X D ARGUMENT 000042 0092S 0097S 0106A 0000 ERRORS [FTN-REV18.2] (0109) (0110) REAL*8 FUNCTION DSTUD(X) (0111) (0112) C DENSITY FUNCTION OF THE T (STUDENT) DISTRIBUTION (0113) (0114) INTEGER*4 (0115) N NDF1, /* DEGREES OF FREEDOM (0116) N NDF2 /* DEGREES OF FREEDOM (0117) (0118) REAL*8 (0119) C C, (0120) D DGAMMA, /* GAMMA FUNCTION C(N/2) (0121) P PI, (0122) X X (0123) (0124) COMMON /STATIS/ NDF1 (0125) (0126) PI = 4.D0 * DATAN(1.D0) (0127) (0128) C = DSQRT(NDF1*PI) * DGAMMA(NDF1) (0129) 1 * (1.D0 + X*X/NDF1)**((NDF1+1)/2.D0) (0130) DSTUD = DGAMMA(NDF1+1) / C (0131) RETURN (0132) END PROGRAM SIZE: PROCEDURE - 000130 LINKAGE - 000050 STACK - 000064 C D LINKAGE 000440 0118S 0128M 0130 DATAN D EXTERNAL 000000 0126 DATN$X R EXTERNAL 000000 0132 DGAMMA D EXTERNAL 000000 0118S 0128 0130 DSQR$X D EXTERNAL 000000 0132 DSQRT D EXTERNAL 000000 0128 DSTUD D LINKAGE 000444 0110S 0130M NDF1 J /STATIS/ 000000 0114S 0124S 0128A 0130 PI D LINKAGE 000422 0118S 0126M 0128 X D ARGUMENT 000042 0110S 0118S 0128 0000 ERRORS [FTN-REV18.2] (0133) (0134) REAL*8 FUNCTION DCSTUD(X) (0135) (0136) C CUMULATIVE T (STUDENT) PROBABILITY DISTRIBUTION FUNCTION (0137) (0138) INTEGER*4 K (0139) (0140) REAL*8 (0141) D DSIMPS, (0142) D DSTUD, (0143) X X (0144) (0145) LOGICAL KONVER (0146) (0147) EXTERNAL DSTUD (0148) (0149) DCSTUD = - ROMINT(DSTUD,X,0.D0,1.D-5,K,KONVER) (0150) RETURN (0151) END PROGRAM SIZE: PROCEDURE - 000034 LINKAGE - 000034 STACK - 000046 DCSTUD D LINKAGE 000430 0134S 0149M DSTUD D EXTERNAL 000000 0140S 0147S 0149A K J LINKAGE 000426 0138S 0149A KONVER L LINKAGE 000400 0145S 0149A ROMINT R EXTERNAL 000000 0149 X D ARGUMENT 000042 0134S 0140S 0149A 0000 ERRORS [FTN-REV18.2] (0152) (0153) REAL*8 FUNCTION DICCHI(F) (0154) (0155) C INVERSE CHI-SQUARED CUMULATIVE PDF (FOR X < 10000.) (0156) (0157) INTEGER*4 (0158) N NDF1, /* DEGREES OF FREEDOM (0159) N NDF2 /* DEGREES OF FREEDOM (0160) (0161) REAL*8 (0162) D DF, (0163) D DFALSI, (0164) D DCCHIS, (0165) D DX, (0166) F F, (0167) X X(3) (0168) (0169) COMMON /STATIS/ NDF1 (0170) (0171) EXTERNAL DCCHIS (0172) (0173) X(1) = 0.D0 (0174) IF(F.GE.0.75D0) X(1) = NDF1 (0175) DX = 1.D-2 (0176) IF(NDF1.GT.50) DX = 0.2D0 (0177) IF(NDF1.GT.100) DX = 0.5D0 (0178) IF(NDF1.GT.500) DX = 0.7D0 (0179) (0180) C CHECK INTERVAL OF ARGUMENT (0181) IF(F.GE.1.D0) GOTO 901 (0182) (0183) C APPROX. VALUES X(1),X(2) (0184) 1 DO 2 I=1,20 (0185) X(2) = X(1) + DX (0186) DF = DCCHIS(X(2)) - F (0187) 11 IF(DF.GT.0.D0) GOTO 12 (0188) X(1) = X(2) (0189) DX = 2.D0*DX (0190) 2 CONTINUE (0191) GOTO 902 (0192) 12 CONTINUE (0193) (0194) C REGULA FALSI (0195) DICCHI = DFALSI(DCCHIS,F,X) (0196) RETURN (0197) 901 CONTINUE (0198) WRITE(1,1901) (0199) 1901 FORMAT(' *** F>= 1. ***'/) (0200) RETURN (0201) 902 CONTINUE (0202) WRITE(1,1902) X(2) (0203) 1902 FORMAT(' *** X> ',F8.2,'***'/) (0204) RETURN (0205) END PROGRAM SIZE: PROCEDURE - 000310 LINKAGE - 000070 STACK - 000046 DCCHIS D EXTERNAL 000000 0161S 0171S 0186 0195A DF D LINKAGE 000450 0161S 0186M 0187 DFALSI D EXTERNAL 000000 0161S 0195 DICCHI D LINKAGE 000456 0153S 0195M DX D LINKAGE 000440 0161S 0175M 0176M 0177M 0178M 0185 0189M F D ARGUMENT 000042 0153S 0161S 0174 0181 0186 0195A I J LINKAGE 000444 0184M NDF1 J /STATIS/ 000000 0157S 0169S 0174 0176 0177 0178 X D LINKAGE 000422 0161S 0173M 0174M 0185M 0186A 0188M 0195A 0202 $1 000071 0184D $11 000113 0187D $12 000142 0187 0192D $1901 000165 0198 0199D $1902 000221 0202 0203D $2 000131 0184 0190D $901 000155 0181 0197D $902 000203 0191 0201D 0000 ERRORS [FTN-REV18.2] (0206) (0207) REAL*8 FUNCTION DFALSI(FCT,F0,X) (0208) (0209) C SOLVE THE EQUATION FCT(X) = F0 , FOR FCT MONOTON INSCREASING (0210) C USING THE REGULA FALSI (0211) (0212) REAL*8 (0213) D DCRIT, (0214) D DF, (0215) F F(3), (0216) F F0, (0217) F FCT, (0218) X X(3) (0219) (0220) EXTERNAL FCT (0221) (0222) DATA DCRIT/5.D-4/ (0223) (0224) 1 DO 2 I=1,2 (0225) F(I) = FCT(X(I)) (0226) 2 CONTINUE (0227) (0228) C CHECK MONOTONITY (0229) IF ((F(2)-F(1)).EQ.0.D0) GOTO 901 (0230) (0231) C ITERATION (0232) 3 DO 4 I=1,100 (0233) X(3) = X(1) + (X(2)-X(1)) / (F(2)-F(1)) * (F0-F(1)) (0234) F(3) = FCT(X(3)) (0235) DF = F(3) - F0 (0236) (0237) C TEST FOR ITERATION TERMINATION (0238) IF(DABS(DF).LT.DCRIT) GOTO 12 (0239) (0240) C NEW APPROX. VALUES X(1), X(2) (0241) 13 IF(DF.LT.0.D0) GOTO 14 (0242) X(1) = X(3) (0243) F(1) = F(3) (0244) 15 GOTO 16 (0245) 14 CONTINUE (0246) X(2) = X(3) (0247) F(2) = F(3) (0248) 16 CONTINUE (0249) C WRITE(1,1999) X,F (0250) 1999 FORMAT(6D12.3) (0251) 4 CONTINUE (0252) (0253) 12 CONTINUE (0254) DFALSI = X(3) (0255) RETURN (0256) (0257) 901 CONTINUE (0258) WRITE(1,1901) (0259) 1901 FORMAT(' *** FCT NOT MONOTONE INCREASING IN DFALSI **'/) (0260) RETURN (0261) END PROGRAM SIZE: PROCEDURE - 000316 LINKAGE - 000062 STACK - 000070 DABS D EXTERNAL 000000 0238 DCRIT D LINKAGE 000422 0212S 0222I 0238 DF D LINKAGE 000444 0212S 0235M 0238A 0241 DFALSI D LINKAGE 000452 0207S 0254M F D LINKAGE 000426 0212S 0225M 0229 0233 0234M 0235 0243M 0247M F0 D ARGUMENT 000045 0207S 0212S 0233 0235 FCT D ARGUMENT 000042 0207S 0212S 0220S 0225 0234 I J LINKAGE 000442 0224M 0225 0232M X D ARGUMENT 000050 0207S 0212S 0225A 0233M 0234A 0242M 0246M 0254 $1 000001 0224D $12 000223 0238 0253D $13 000136 0241D $14 000161 0241 0245D $15 000160 0244D $16 000205 0244 0248D $1901 000246 0258 0259D $1999 000205 0250D $2 000024 0224 0226D $3 000043 0232D $4 000212 0232 0251D $901 000236 0229 0257D 0000 ERRORS [FTN-REV18.2] (0262) (0263) REAL*8 FUNCTION ROMINT(FCT,A,B,GRZW,K,KONVER) (0264) (0265) C ROMBERG INTEGRATION (0266) (0267) INTEGER*4 J,L,K (0268) REAL*8 (0269) H H, (0270) T T, (0271) T TOLD, (0272) A A, (0273) B B, (0274) S SF, (0275) M M, (0276) K K1, (0277) G GRZW (0278) (0279) DIMENSION T(20,2) (0280) (0281) LOGICAL KONVER (0282) (0283) EXTERNAL FCT (0284) (0285) KONVER = .FALSE. (0286) H = B-A (0287) T(1,1) = (FCT(A) + FCT(B)) * H / 2.D0 (0288) M = H * FCT(A+H/2.D0) (0289) J=2 (0290) 101 DO 102 K=2,20 (0291) J=2*J (0292) H = H/2.D0 (0293) T(1,2) = (T(1,1)+M)/2.D0 (0294) SF = 0.D0 (0295) 103 DO 104 L=1,J,2 (0296) 104 SF = SF + FCT(A + L*H/2.D0) (0297) M = H*SF (0298) K1=4.D0 (0299) 1 IF(K.LT.3)GOTO 2 (0300) L = K-1 (0301) 105 DO 106 I=2,L (0302) T(I,2) = (K1*T(I-1,2)-T(I-1,1))/(K1-1.D0) (0303) T(I-1,1) = T(I-1,2) (0304) 106 K1 = K1 * K1 (0305) 2 I=K (0306) T(I,1) = (K1*T(I-1,2)-T(I-1,1))/(K1-1.D0) (0307) C WRITE(1,1097) K,T(K,1) (0308) 1097 FORMAT(I4,D16.8) (0309) 203 IF(DABS(T(I,1)-TOLD).LT.GRZW) GOTO 204 (0310) TOLD=T(K,1) (0311) T(I-1,1) = T(I-1,2) (0312) 102 CONTINUE (0313) 205 GOTO 206 (0314) 204 KONVER = .TRUE. (0315) ROMINT = T(K,1) (0316) C WRITE(1,1098) K (0317) 1098 FORMAT('K=',I4) (0318) RETURN (0319) (0320) 206 CONTINUE (0321) ROMINT = 0.D0 (0322) WRITE(1,1099) (0323) 1099 FORMAT('*** NO CONVERGENCE IN ROMINT ***'/) (0324) RETURN (0325) END PROGRAM SIZE: PROCEDURE - 000500 LINKAGE - 000326 STACK - 000072 A D ARGUMENT 000045 0263S 0268S 0286 0287A 0288 0296 B D ARGUMENT 000050 0263S 0268S 0286 0287A DABS D EXTERNAL 000000 0309 FCT R ARGUMENT 000042 0263S 0283S 0287 0288 0296 GRZW D ARGUMENT 000053 0263S 0268S 0309 H D LINKAGE 000662 0268S 0286M 0287 0288 0292M 0296 0297 I J LINKAGE 000706 0301M 0302 0303 0305M 0306 0309 0311 J J LINKAGE 000672 0267S 0289M 0291M 0295 K J ARGUMENT 000056 0263S 0267S 0290M 0299 0300 0305 0310 0315 K1 D LINKAGE 000702 0268S 0298M 0302 0304M 0306 KONVER L ARGUMENT 000061 0263S 0281S 0285M 0314M L J LINKAGE 000700 0267S 0295M 0296 0300M 0301 M D LINKAGE 000666 0268S 0288M 0293 0297M ROMINT D LINKAGE 000716 0263S 0315M 0321M SF D LINKAGE 000674 0268S 0294M 0296M 0297 T D LINKAGE 000422 0268S 0279S 0287M 0293M 0302M 0303M 0306M 0309 0310 0311M 0315 TOLD D LINKAGE 000710 0268S 0309 0310M $1 000171 0299D $101 000062 0290D $102 000350 0290 0312D $103 000115 0295D $104 000121 0295 0296D $105 000204 0301D $106 000236 0301 0304D $1097 000303 0308D $1098 000375 0317D $1099 000422 0322 0323D $2 000255 0299 0305D $203 000311 0309D $204 000362 0309 0314D $205 000361 0313D $206 000406 0313 0320D 0000 ERRORS [FTN-REV18.2] (0326) (0327) REAL*8 FUNCTION DCCHIS(X) (0328) C CUMULATIVE CHI-SQUARED PROBABILITY DISTRIBUTION FUNCTION (0329) (0330) INTEGER*4 (0331) N NDF1, /* DEGREES OF FREEDOM (0332) N NDF2 /* DEGREES OF FREEDOM (0333) (0334) REAL*8 (0335) D DCHISQ, (0336) F F01, (0337) F F9(15), (0338) G GRZW, /* CRIT. VALUE FOR ITERATION TERMINATION (0339) R RNDF, (0340) R RNDF2, (0341) R ROMINT, (0342) X X,X1 (0343) (0344) LOGICAL KONVER,GTNDF,GTNDF2 (0345) (0346) COMMON /STATIS/ NDF1 (0347) (0348) EXTERNAL DCHISQ (0349) (0350) DATA (0351) F F01/0.982069D-3/, (0352) F F9/2.70554D0,4.60517D0,6.25139D0,7.77944D0,9.23635D0,10.6446D0, (0353) F 12.0170D0,13.3616D0,14.6837D0,15.9871D0,17.2750D0,18.5494D0, (0354) F 19.8119D0,21.0642D0,22.3072D0/ (0355) (0356) GRZW = 1.D-5 (0357) IF(NDF1.LE.15) GRZW = 1.D-4 (0358) RNDF = NDF1 (0359) RNDF2 = 2*NDF1 (0360) GTNDF = .FALSE. (0361) GTNDF2 = .FALSE. (0362) DCCHIS = 0.D0 (0363) X1 = X (0364) (0365) IF(X.LT.0.D0) GOTO 902 (0366) 8 IF(X.EQ.0.D0) GOTO 9 (0367) IF(X.GT.RNDF) GTNDF = .TRUE. (0368) IF(X.GT.RNDF2) GTNDF2 = .TRUE. (0369) IF(NDF1.EQ.1) GOTO 1 (0370) IF(NDF1.GE.2) GOTO 2 (0371) GOTO 901 (0372) (0373) C 1 DEGREE OF FREEDOM (0374) 1 CONTINUE (0375) 101 IF(.NOT.GTNDF) GOTO 102 (0376) DCCHIS = -ROMINT(DCHISQ,X,F9(1),GRZW,K,KONVER) + 0.9D0 (0377) RETURN (0378) 102 CONTINUE (0379) DCCHIS = DCCHIS - ROMINT(DCHISQ,X1,F01,GRZW,K,KONVER) + 0.025D0 (0380) RETURN (0381) (0382) C NDF>=2 (0383) 2 CONTINUE (0384) (0385) 103 IF(NDF1.GT.15.OR..NOT.GTNDF) GOTO 104 (0386) DCCHIS = - ROMINT(DCHISQ,X,F9(NDF1),GRZW,K,KONVER) + 0.9D0 (0387) RETURN (0388) (0389) 104 CONTINUE (0390) IF(GTNDF2) DCCHIS = - ROMINT(DCHISQ,X,RNDF2,GRZW,K,KONVER) (0391) IF(GTNDF2) X1=RNDF2 (0392) DCCHIS = DCCHIS - ROMINT(DCHISQ,X1,0.D0,GRZW,K,KONVER) (0393) RETURN (0394) (0395) 9 CONTINUE (0396) DCCHIS = 0.D0 (0397) RETURN (0398) 901 CONTINUE (0399) WRITE(1,1901) (0400) 1901 FORMAT(' *** NDF<1 IN DCCHIS ***'/) (0401) RETURN (0402) 902 CONTINUE (0403) WRITE(1,1902) (0404) 1902 FORMAT(' *** X<0. IN DCCHIS ***'/) (0405) RETURN (0406) END PROGRAM SIZE: PROCEDURE - 000434 LINKAGE - 000166 STACK - 000052 DCCHIS D LINKAGE 000542 0327S 0362M 0376M 0379M 0386M 0390M 0392M 0396M DCHISQ D EXTERNAL 000000 0334S 0348S 0376A 0379A 0386A 0390A 0392A F01 D LINKAGE 000424 0334S 0350I 0379A F9 D LINKAGE 000430 0334S 0350I 0376A 0386A GRZW D LINKAGE 000524 0334S 0356M 0357M 0376A 0379A 0386A 0390A 0392A GTNDF L LINKAGE 000400 0344S 0360M 0367M 0375 0385 GTNDF2 L LINKAGE 000401 0344S 0361M 0368M 0390 0391 K J LINKAGE 000556 0376A 0379A 0386A 0390A 0392A KONVER L LINKAGE 000402 0344S 0376A 0379A 0386A 0390A 0392A NDF1 J /STATIS/ 000000 0330S 0346S 0357 0358 0359 0369 0370 0385 0386 RNDF D LINKAGE 000532 0334S 0358M 0367 RNDF2 D LINKAGE 000536 0334S 0359M 0368 0390A 0391 ROMINT D EXTERNAL 000000 0334S 0376 0379 0386 0390 0392 X D ARGUMENT 000044 0327S 0334S 0363 0365 0366 0367 0368 0376A 0386A 0390A X1 D LINKAGE 000546 0334S 0363M 0379A 0391M 0392A $1 000107 0369 0374D $101 000107 0375D $102 000136 0375 0378D $103 000164 0385D $104 000232 0385 0389D $1901 000326 0399 0400D $1902 000361 0403 0404D $2 000164 0370 0383D $8 000051 0366D $9 000311 0366 0395D $901 000316 0371 0398D $902 000351 0365 0402D 0000 ERRORS [FTN-REV18.2] (0407) (0408) REAL*8 FUNCTION DICNOR(F) (0409) C INVERSE CUMULATIVE NORMAL PDF (0410) (0411) REAL*8 (0412) D DCNORM, (0413) D DNORM, (0414) D DNEWTO, (0415) F F, (0416) X X (0417) (0418) EXTERNAL DCNORM,DNORM (0419) (0420) X = 2.D0*F (0421) DICNOR = DNEWTO(DCNORM,DNORM,F,X) (0422) RETURN (0423) END PROGRAM SIZE: PROCEDURE - 000030 LINKAGE - 000036 STACK - 000046 DCNORM D EXTERNAL 000000 0411S 0418S 0421A DICNOR D LINKAGE 000432 0408S 0421M DNEWTO D EXTERNAL 000000 0411S 0421 DNORM D EXTERNAL 000000 0411S 0418S 0421A F D ARGUMENT 000042 0408S 0411S 0420 0421A X D LINKAGE 000420 0411S 0420M 0421A 0000 ERRORS [FTN-REV18.2] (0424) (0425) REAL*8 FUNCTION DICSTU(F) (0426) (0427) C INVERSE CUMULATIVE T (STUDENT) PDF (0428) (0429) REAL*8 (0430) D DNEWTO, (0431) D DCSTUD, (0432) D DSTUD, (0433) F F, (0434) X X (0435) (0436) EXTERNAL DCSTUD,DSTUD (0437) (0438) X = 2.D0*F (0439) DICSTU = DNEWTO(DCSTUD,DSTUD,F,X) (0440) RETURN (0441) END PROGRAM SIZE: PROCEDURE - 000030 LINKAGE - 000036 STACK - 000046 DCSTUD D EXTERNAL 000000 0429S 0436S 0439A DICSTU D LINKAGE 000432 0425S 0439M DNEWTO D EXTERNAL 000000 0429S 0439 DSTUD D EXTERNAL 000000 0429S 0436S 0439A F D ARGUMENT 000042 0425S 0429S 0438 0439A X D LINKAGE 000420 0429S 0438M 0439A 0000 ERRORS [FTN-REV18.2] (0442) (0443) SUBROUTINE TIMREG(IDAT,ITIME,IUSER) (0444) C% ZEIT IN [HR.MIN] , DATUM IN [DY.MT.YR] , INITIALEN DES BENUETZERS (0445) C% REGISTRIEREN (0446) INTEGER*2 ITIMDA(15),IDAT(3),ITIME(2),IUSER(3) (0447) (0448) CALL TIMDAT(ITIMDA,INTS(15)) (0449) IDAT(1) = ITIMDA(2) (0450) IDAT(2) = ITIMDA(1) (0451) IDAT(3) = ITIMDA(3) (0452) ITIME(1) = ITIMDA(4)/60 (0453) ITIME(2) = ITIMDA(4)-ITIME(1)*60 (0454) IUSER(1) = ITIMDA(13) (0455) IUSER(2) = ITIMDA(14) (0456) IUSER(3) = ITIMDA(15) (0457) RETURN (0458) END PROGRAM SIZE: PROCEDURE - 000132 LINKAGE - 000044 STACK - 000060 IDAT I ARGUMENT 000042 0443S 0446S 0449M 0450M 0451M INTS J EXTERNAL 000000 0448 ITIMDA I LINKAGE 000422 0446S 0448A 0449 0450 0451 0452 0453 0454 0455 0456 ITIME I ARGUMENT 000045 0443S 0446S 0452M 0453M IUSER I ARGUMENT 000050 0443S 0446S 0454M 0455M 0456M TIMDAT R EXTERNAL 000000 0448 0000 ERRORS [FTN-REV18.2] (0459) $$$ SUBROUTINE GODFIT(V,NOR,VCLS,JCODE,NO,IOB,NVARF,ALPH,NV) GODFIT (0001) SUBROUTINE GODFIT(V,NOR,VCLS,JCODE,NO,IOB,NVARF,ALPH,NV) (0002) C*********************************************************************** (0003) C* (0004) C* GODFIT FERFORMS THE CHI-SQUARE GOODNESS OF FIT TEST ON STANDARDIZED (0005) C* RESIDUALS AND PLOTS THE CORRESPONDING HISTOGRAMS. (0006) C* (0007) C* WRITTEN BY: (0008) C* R.R. STEEVES, AUG, 1978 (0009) C* (0010) C*********************************************************************** (0011) IMPLICIT REAL*8(A-H,O-Z) (0012) INTEGER HVEC(20) (0013) REAL*4 SNGL,FLOAT,X,AREA (0014) DIMENSION AREA(20),IVEC(7),V(NV) ,VCLS(NOR),NHVEC(20),NCNT(6,11), (0015) @ IOB(NOR,4) (0016) (0017) COMMON /STATIS/ NDF1 (0018) (0019) 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,9 (0020) @,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,0 (0021) @,0,0,19,21,0,0,0,0,21,0,0,0,0,0/ (0022) DATA AREA/0.000003,0.000028,0.000201,0.001117,0.004860,0.016540, (0023) @ 0.044057,0.091848,0.149882,0.191462,0.191462,0.149882,0.091848, (0024) @0.044057,0.016540,0.004860,0.001117,0.000201,0.000028,0.000003/ (0025) DATA IVEC/20,10,9,5,4,3,2/ (0026) K=1 (0027) C SELECT THE SET OF RESIDUALS TO BE CONSIDERED (0028) IF(JCODE.EQ.3)GOTO1 (0029) IF(JCODE.EQ.2)GOTO2 (0030) DO 3 J=1,NO (0031) IF(IOB(J,1).NE.1)GOTO3 (0032) VCLS(K)=V(J) (0033) K=K+1 (0034) 3 CONTINUE (0035) GOTO5 (0036) 2 DO 4 J=1,NO (0037) IF(IOB(J,1).EQ.1)GOTO4 (0038) VCLS(K)=V(J) (0039) K=K+1 (0040) 4 CONTINUE (0041) GOTO5 (0042) 1 DO 6 J=1,NO (0043) VCLS(J)=V(J) (0044) 6 CONTINUE (0045) K=NO+1 (0046) 5 NRES=K-1 (0047) C SORT THE RESIDUALS INTO ORDER OF INCREASING MAGNITUDE (0048) CALL SORT(VCLS,NOR,NRES) (0049) DO 8 J=1,20 (0050) 8 HVEC(J)=0 (0051) X=-4.5D0 (0052) J=1 (0053) C PLACE RESIDUALS INTO CORRECT HISTOGRAM INTERVALS (0054) DO 9 K=1,20 (0055) 10 IF(VCLS(J).GT.X.AND.K.LT.20)GOTO11 (0056) HVEC(K)=HVEC(K)+1 (0057) J=J+1 (0058) IF(J.GT.NRES)GOTO7 (0059) GOTO10 (0060) 11 X=X+0.5D0 (0061) 9 CONTINUE (0062) C DETERMINE INTERVALS WITH EXPECTED FREQUENCE OF AT LEAST 5 (0063) 7 DO 20 N=1,7 (0064) DO 29 K=1,20 (0065) 29 NHVEC(K)=0 (0066) NI=IVEC(N) (0067) DO 28 K=1,NI (0068) IF(N.EQ.1)ISUM=HVEC(K) (0069) IF(N.EQ.1)GOTO28 (0070) IFR=NCNT(N-1,K) (0071) ITO=NCNT(N-1,K+1)-1 (0072) ISUM=0 (0073) DO 30 J=IFR,ITO (0074) 30 ISUM=ISUM+HVEC(J) (0075) 28 NHVEC(K)=ISUM (0076) NI1=NI-1 (0077) MINIX=0 (0078) DO 21 K=1,NI1 (0079) AR=0.D0 (0080) IF(N.EQ.1)AR=AREA(K) (0081) IF(N.EQ.1)GOTO57 (0082) IFR=NCNT(N-1,K) (0083) ITO=NCNT(N-1,K+1)-1 (0084) DO 58 J=IFR,ITO (0085) 58 AR=AR+AREA(J) (0086) 57 NEX=AR*NRES (0087) IF(NEX.GE.5)MINIX=K (0088) IF(MINIX.NE.0)GOTO62 (0089) 21 CONTINUE (0090) GOTO20 (0091) 62 MINIA=0 (0092) DO 63 K=1,NI1 (0093) IF(NHVEC(K).NE.0.OR.NHVEC(NI+1-K).NE.0)MINIA=K (0094) IF(MINIA.NE.0)GOTO64 (0095) 63 CONTINUE (0096) 64 IF(MINIA.GE.MINIX)GOTO27 (0097) 20 CONTINUE (0098) NDF=0 (0099) NUMI=0 (0100) GOTO200 (0101) 27 MINI=MINIX (0102) MAXI=NI-MINI+1 (0103) NUMI=MAXI-MINI+1 (0104) NTHETA=0 (0105) IF(NVARF.EQ.0)NTHETA=1 (0106) NDF=NUMI-1-NTHETA (0107) IF(NDF.LE.0)GOTO200 (0108) C PERFORM CHI-SQUARE GOODNESS OF FIT TEST (0109) STRT=-5.0 (0110) DO 35 I=1,MINI (0111) IF(I.EQ.MINI)GOTO35 (0112) IF(N.EQ.1)GOTO36 (0113) IFR=NCNT(N-1,I) (0114) ITO=NCNT(N-1,I+1)-1 (0115) STRT=STRT+(ITO-IFR+1)*0.5D0 (0116) GOTO35 (0117) 36 STRT=STRT+0.5D0 (0118) 35 CONTINUE (0119) WRITE(6 ,101) (0120) IF(JCODE.EQ.1)WRITE(6 ,102) (0121) IF(JCODE.EQ.2)WRITE(6 ,103) (0122) IF(JCODE.EQ.3)WRITE(6 ,104) (0123) WRITE(6 ,105)NUMI (0124) WRITE(6 ,106)NDF (0125) WRITE(6 ,107) (0126) WRITE(6 ,108) (0127) CHISQ=0.D0 (0128) DO 37 I=MINI,MAXI (0129) IF(N.EQ.1)GOTO38 (0130) AR=0.D0 (0131) IFR=NCNT(N-1,I) (0132) ITO=NCNT(N-1,I+1)-1 (0133) DO 39 K=IFR,ITO (0134) 39 AR=AR+AREA(K) (0135) FIN=(ITO-IFR+1)*0.5D0+STRT (0136) GOTO40 (0137) 38 AR=AREA(I) (0138) FIN=STRT+0.5D0 (0139) 40 NEXP=NRES*AR (0140) NOBS=NHVEC(I) (0141) NDIF=NOBS-NEXP (0142) NDIF2=NDIF**2 (0143) CONT=NDIF2/NEXP (0144) CHISQ=CHISQ+CONT (0145) WRITE(6 ,109)STRT,FIN,NOBS,NEXP,NDIF,NDIF2,CONT (0146) STRT=FIN (0147) 37 CONTINUE (0148) WRITE(6 ,110)CHISQ (0149) P=SNGL(ALPH/100.D0) (0150) DF=FLOAT(NDF) (0151) X=SNGL(0.D0) (0152) C CALL MDCHI(P,DF,X,IER) (0153) (0154) NDF1 = NDF (0155) DP = ALPH/100.D0 (0156) DX = DICCHI(DP) (0157) X = SNGL(DX) (0158) (0159) WRITE(6 ,111)ALPH,X (0160) IPASS=0 (0161) IF(SNGL(CHISQ).LE.X)IPASS=1 (0162) IF(IPASS.EQ.1)WRITE(6 ,112)CHISQ,X (0163) IF(IPASS.EQ.0)WRITE(6 ,113)CHISQ,X (0164) WRITE(6 ,114) (0165) IF(NUMI.LT.9)WRITE(6 ,119)NUMI (0166) CALL PLOT(NI,NHVEC) (0167) IF(JCODE.EQ.1)WRITE(6 ,115) (0168) IF(JCODE.EQ.2)WRITE(6 ,116) (0169) IF(JCODE.EQ.3)WRITE(6 ,117) (0170) IF(NUMI.LT.9)WRITE(6 ,121) (0171) 200 IF(NUMI.GE.9)GOTO210 (0172) CALL PLOT(20,HVEC) (0173) IF(JCODE.EQ.1)WRITE(6 ,115) (0174) IF(JCODE.EQ.2)WRITE(6 ,116) (0175) IF(JCODE.EQ.3)WRITE(6 ,117) (0176) IF(NDF.LE.0)WRITE(6 ,118)NDF (0177) 210 RETURN (0178) 101 FORMAT('1',38X,'CHI-SQUARE GOODNESS OF FIT TEST',/,' ',38X, (0179) @ 31('-'),/) (0180) 102 FORMAT(' ',35X,'ON THE STANDARDIZED DISTANCE RESIDUALS',//) (0181) 103 FORMAT(' ',26X,'ON THE STANDARDIZED DIRECTION, ANGLE AND AZIMUTH R (0182) @ESIDUALS',//) (0183) 104 FORMAT(' ',28X,'ON THE STANDARDIZED RESIDUALS (ALL RESIDUALS INCLU (0184) @DED)',//) (0185) 105 FORMAT(' ',41X,'THE NUMBER OF CLASSES IS',I3) (0186) 106 FORMAT(' ',28X,'THE NUMBER OF DEGREES OF FREEDOM FOR THE TEST IS', (0187) @ I6,//) (0188) 107 FORMAT(' ',28X,'SUMMARY OF THE COMPUTATION OF THE CHI-SQUARE STATI (0189) @STIC',/,' ',28X,54('-'),/) (0190) 108 FORMAT(' ',9X,'CLASS INTERVAL',3X,'OBSERVED FREQ.(O)',3X, (0191) @'EXPECTED FREQ.(E)',5X,'(O-E)',5X,'(O-E)**2',5X,'(O-E)**2/E') (0192) 109 FORMAT(' ',10X,'(',F4.1,' ,',F4.1,')',5X,I8,11X,I9,11X,I6,5X,I7, (0193) @6X,F9.2) (0194) 110 FORMAT(' ',91X,8('-'),//,' ',56X,'TOTAL (CHI-SQUARE STATISTIC) --> (0195) @',F11.2,/) (0196) 111 FORMAT(' ',19X,'THE CHI-SQUARE CRITICAL VALUE AT THE',F7.3,' % CON (0197) @FIDENCE LEVEL IS -->',F11.2,///) (0198) 112 FORMAT(' ',39X,F7.2,' IS LESS THAN ',F7.2,////,' ',47X,'THE TEST (0199) @PASSES',/,' ',47X,15('-'),/) (0200) 113 FORMAT(' ',39X,F6.2,' IS GREATER THAN ',F6.2,////,' ',47X,'THE TE (0201) @ST FAILS',/,' ',47X,14('-'),/) (0202) 114 FORMAT(' ',41X,'(SEE HISTOGRAM ON NEXT PAGE)',/) (0203) 115 FORMAT(/,' ',31X,'HISTOGRAM OF THE STANDARDIZED DISTANCE RESIDUALS (0204) *',/,' ',31X,48('-')) (0205) 116 FORMAT(/,' ',22X,'HISTOGRAM OF THE STANDARDIZED DIRECTION, ANGLE A (0206) @ND AZIMUTH RESIDUALS',/,' ',22X,68('-')) (0207) 117 FORMAT(/,' ',24X,'HISTOGRAM OF THE STANDARDIZED RESIDUALS (ALL RES (0208) @IDUALS INCLUDED)',/,' ',24X,64('-')) (0209) 118 FORMAT(' ',4X,'THE CHI-SQUARE GOODNESS OF FIT TEST WAS NOT PERFORM (0210) @ED SINCE THE DEGREES OF FREEDOM OF THE TEST WAS',I4) (0211) 119 FORMAT(' ',4X,'NOTE: THE HISTOGRAM IS FIRST PLOTTED WITH ',I1, (0212) @' CLASSES (THAT USED IN THE GOODNESS OF FIT TEST); THEN WITH',/, (0213) @' ',10X,'20 CLASSES SO THAT A MORE DETAILED REPRESENTATION OF THE (0214) @ACTUAL RESIDUAL DISTRIBUTION IS GIVEN.') (0215) 121 FORMAT(' ','(WITH CLASSES AS USED IN THE GOODNESS OF FIT TEST; A M (0216) @ORE DETAILED REPRESENTATION IS PLOTTED ON THE NEXT PAGE)') (0217) END PROGRAM SIZE: PROCEDURE - 004200 LINKAGE - 000606 STACK - 000110 ALPH D ARGUMENT 000071 0001S 0149 0155 0159 AR D LINKAGE 001066 0079M 0080M 0085M 0086 0130M 0134M 0137M 0139 AREA R LINKAGE 000630 0013S 0014S 0022I 0080 0085 0134 0137 CHISQ D LINKAGE 001124 0127M 0144M 0148 0161A 0162 0163 CONT D LINKAGE 001144 0143M 0144 0145 DF D LINKAGE 001160 0150M DICCHI D EXTERNAL 000000 0156 DP D LINKAGE 001166 0155M 0156A DX D LINKAGE 001174 0156M 0157A FIN D LINKAGE 001130 0135M 0138M 0145 0146 FLOAT R EXTERNAL 000000 0013S 0150 HVEC J LINKAGE 000716 0012S 0050M 0056M 0068 0074 0172A I J LINKAGE 001114 0110M 0111 0113 0114 0128M 0131 0132 0137 0140 IFR J LINKAGE 001056 0070M 0073 0082M 0084 0113M 0115 0131M 0133 0135 IOB J ARGUMENT 000063 0001S 0014S 0031 0037 IPASS J LINKAGE 001202 0160M 0161M 0162 0163 ISUM J LINKAGE 001054 0068M 0072M 0074M 0075 ITO J LINKAGE 001060 0071M 0073 0083M 0084 0114M 0115 0132M 0133 0135 IVEC J LINKAGE 000700 0014S 0025I 0066 J J LINKAGE 001040 0030M 0031 0032 0036M 0037 0038 0042M 0043 0049M 0050 0052M 0055 0057M 0058 0073M 0074 0084M 0085 JCODE J ARGUMENT 000055 0001S 0028 0029 0120 0121 0122 0167 0168 0169 0173 0174 0175 K J LINKAGE 001036 0026M 0032 0033M 0038 0039M 0045M 0046 0054M 0055 0056 0064M 0065 0067M 0068 0070 0071 0075 0078M 0080 0082 0083 0087 0092M 0093 0133M 0134 MAXI J LINKAGE 001104 0102M 0103 0128 MINI J LINKAGE 001102 0101M 0102 0103 0110 0111 0128 MINIA J LINKAGE 001074 0091M 0093M 0094 0096 MINIX J LINKAGE 001064 0077M 0087M 0088 0096 0101 N J LINKAGE 001050 0063M 0066 0068 0069 0070 0071 0080 0081 0082 0083 0112 0113 0114 0129 0131 0132 NCNT J LINKAGE 000424 0014S 0019I 0070 0071 0082 0083 0113 0114 0131 0132 NDF J LINKAGE 001076 0098M 0106M 0107 0124 0150 0154 0176 NDF1 J /STATIS/ 000000 0017S 0154M NDIF J LINKAGE 001140 0141M 0142 0145 NDIF2 J LINKAGE 001142 0142M 0143 0145 NEX J LINKAGE 001072 0086M 0087 NEXP J LINKAGE 001134 0139M 0141 0143 0145 NHVEC J LINKAGE 000766 0014S 0065M 0075M 0093 0140 0166A NI J LINKAGE 001052 0066M 0067 0076 0093 0102 0166A NI1 J LINKAGE 001062 0076M 0078 0092 NO J ARGUMENT 000060 0001S 0030 0036 0042 0045 NOBS J LINKAGE 001136 0140M 0141 0145 NOR J ARGUMENT 000047 0001S 0014S 0048A NRES J LINKAGE 001042 0046M 0048A 0058 0086 0139 NTHETA J LINKAGE 001106 0104M 0105M 0106 NUMI J LINKAGE 001100 0099M 0103M 0106 0123 0165 0170 0171 NVARF J ARGUMENT 000066 0001S 0105 P D LINKAGE 001154 0149M PLOT D EXTERNAL 000000 0166 0172 SNGL R EXTERNAL 000000 0013S 0149 0151 0157 0161 SORT D EXTERNAL 000000 0048 STRT D LINKAGE 001110 0109M 0115M 0117M 0135 0138 0145 0146M V D ARGUMENT 000044 0001S 0014S 0032 0038 0043 VCLS D ARGUMENT 000052 0001S 0014S 0032M 0038M 0043M 0048A 0055 X R LINKAGE 001046 0013S 0051M 0055 0060M 0151M 0157M 0159 0161 0162 0163 $1 000174 0028 0042D $10 000314 0055D 0059 $101 002334 0119 0178D $102 002375 0120 0180D $103 002431 0121 0181D $104 002477 0122 0183D $105 002543 0123 0185D $106 002570 0124 0186D $107 002632 0125 0188D $108 002706 0126 0190D $109 002777 0145 0192D $11 000367 0055 0060D $110 003041 0148 0194D $111 003105 0159 0196D $112 003164 0162 0198D $113 003241 0163 0200D $114 003317 0164 0202D $115 003345 0167 0173 0203D $116 003416 0168 0174 0205D $117 003501 0169 0175 0207D $118 003562 0176 0209D $119 003653 0165 0211D $121 004035 0170 0215D $2 000106 0029 0036D $20 001022 0063 0090 0097D $200 002220 0100 0107 0171D $21 000730 0078 0089D $210 002333 0171 0177D $27 001041 0096 0101D $28 000545 0067 0069 0075D $29 000417 0064 0065D $3 000075 0030 0031 0034D $30 000524 0073 0074D $35 001177 0110 0111 0116 0118D $36 001171 0112 0117D $37 001631 0128 0147D $38 001463 0129 0137D $39 001422 0133 0134D $4 000163 0036 0037 0040D $40 001500 0136 0139D $5 000242 0035 0041 0046D $57 000702 0081 0086D $58 000660 0084 0085D $6 000223 0042 0044D $62 000741 0088 0091D $63 001003 0092 0095D $64 001014 0094 0096D $7 000407 0058 0063D $8 000264 0049 0050D $9 000376 0054 0061D 0000 ERRORS [FTN-REV18.2] SUBROUTINE GVERT(AP,NSR,AA,BB,XO,YO,ZO,VERT,I,J) GVERT0 (0218) SUBROUTINE GVERT(AP,NSR,AA,BB,XO,YO,ZO,VERT,I,J) (0219) C*********************************************************************** (0220) C* (0221) C* GVERT COMPUTES THE ZENITHAL ANGLE FROM STATION I TO STATION J (SEQU (0222) C* NUMBERS) FROM THE COMPUTED LATITUDES AND LONGITUDES AND THE HEIGHTS (0223) C* STATIONS I AND J. USED IN REDUCING OBSERVATIONS FROM TERRAIN TO (0224) C* ELLEPSOID. (0225) C* (0226) C* (0227) C* INPUT: (0228) C* AP,NSR- DESCRIBED IN MAIN (0229) C* AA,BB- SEMI MAJOR AND SEMI MINOR AXES OF REFERENCE ELLIPSOID (0230) C* XO,YO,ZO-TRANSLATION COMPONENTS FROM GEOCENTRIC TO REFERENCE (0231) C* ELLIPSOID (0232) C* (0233) C* OUTPUT: (0234) C* VERT- COMPUTED ZENITHAL ANGLE FROM I TO J (0235) C* (0236) C* (0237) C* WRITTEN BY: (0238) C* R.R. STEEVES, JUNE, 1678 (0239) C* (0240) C*********************************************************************** (0241) IMPLICIT REAL*8(A-H,O-Z) (0242) DIMENSION AP(NSR,12) (0243) HI=AP(I,3)+AP(I,4) (0244) HJ=AP(J,3)+AP(J,4) (0245) C COMPUTE GEOCENTRIC COORDINATES (0246) CALL PLHXYZ(AP(I,9),AP(I,10),HI,XO,YO,ZO,AA,BB,XI,YI,ZI) (0247) CALL PLHXYZ(AP(J,9),AP(J,10),HJ,XO,YO,ZO,AA,BB,XJ,YJ,ZJ) (0248) DX=XJ-XI (0249) DY=YJ-YI (0250) DZ=ZJ-ZI (0251) SP=DSIN(AP(I,9)) (0252) CP=DCOS(AP(I,9)) (0253) SL=DSIN(AP(I,10)) (0254) CL=DCOS(AP(I,10)) (0255) C COMPUTE LOCAL GEODETIC COORDINATE DIFFERENCES (0256) DXL=-DX*SP*CL-DY*SP*SL+DZ*CP (0257) DYL=-DX*SL+DY*CL (0258) DZL=DX*CP*CL+DY*CP*SL+DZ*SP (0259) DIST=DSQRT(DXL**2+DYL**2+DZL**2) (0260) C COMPUTE ZENITHAL ANGLE (0261) VERT=DARCOS(DZL/DIST) (0262) RETURN (0263) END PROGRAM SIZE: PROCEDURE - 000542 LINKAGE - 000146 STACK - 000122 AA D ARGUMENT 000050 0218S 0246A 0247A AP D ARGUMENT 000042 0218S 0242S 0243 0244 0246A 0247A 0251A 0252A 0253A 0254A BB D ARGUMENT 000053 0218S 0246A 0247A CL D LINKAGE 000516 0254M 0256 0257 0258 CP D LINKAGE 000506 0252M 0256 0258 DARCOS D EXTERNAL 000000 0261 DCOS D EXTERNAL 000000 0252 0254 DCOS$X J EXTERNAL 000000 0263 DIST D LINKAGE 000540 0259M 0261 DSIN D EXTERNAL 000000 0251 0253 DSIN$X J EXTERNAL 000000 0263 DSQR$X D EXTERNAL 000000 0263 DSQRT D EXTERNAL 000000 0259 DX D LINKAGE 000462 0248M 0256 0257 0258 DXL D LINKAGE 000522 0256M 0259 DY D LINKAGE 000466 0249M 0256 0257 0258 DYL D LINKAGE 000526 0257M 0259 DZ D LINKAGE 000472 0250M 0256 0258 DZL D LINKAGE 000532 0258M 0259 0261 HI D LINKAGE 000420 0243M 0246A HJ D LINKAGE 000424 0244M 0247A I J ARGUMENT 000072 0218S 0243 0246 0251 0252 0253 0254 J J ARGUMENT 000075 0218S 0244 0247 PLHXYZ D EXTERNAL 000000 0246 0247 SL D LINKAGE 000512 0253M 0256 0257 0258 SP D LINKAGE 000500 0251M 0256 0258 VERT D ARGUMENT 000067 0218S 0261M XI D LINKAGE 000432 0246A 0248 XJ D LINKAGE 000446 0247A 0248 XO D ARGUMENT 000056 0218S 0246A 0247A YI D LINKAGE 000436 0246A 0249 YJ D LINKAGE 000452 0247A 0249 YO D ARGUMENT 000061 0218S 0246A 0247A ZI D LINKAGE 000442 0246A 0250 ZJ D LINKAGE 000456 0247A 0250 ZO D ARGUMENT 000064 0218S 0246A 0247A 0000 ERRORS [FTN-REV18.2] SUBROUTINE INERR(NO,IOB,DOB,ID,NS,NCODE,NOR) INERR0 (0264) SUBROUTINE INERR(NO,IOB,DOB,ID,NS,NCODE,NOR) (0265) C*********************************************************************** (0266) C* (0267) C* INERR PERFORMS SOME CHECKS ON INPUT DATA. ERROR MESSAGES ARE PRINTE (0268) C* WHEN INVALID DATA ARE INCOUNTERED. (0269) C* (0270) C* (0271) C* INPUT: (0272) C* -ALL DESCRIBED IN MAIN (0273) C* (0274) C* OUTPUT: (0275) C* ID- RETURNS 1 IF AN INPUT ERROR WAS DETECTED; 0 IF NOT (0276) C* (0277) C* (0278) C* WRITTEN BY: (0279) C* R.R. STEEVES, JUNE, 1978 (0280) C* (0281) C*********************************************************************** (0282) IMPLICIT REAL*8(A-H,O-Z) (0283) DIMENSION IOB(NOR,4),DOB(NOR,4) (0284) DO 18 I=1,NO (0285) K=IOB(I,1) (0286) C CHECK OBSERVATION CODE (0287) IF(K.LE.4.AND.K.GE.-2.AND.K.NE.0.AND.K.NE.-1)GOTO12 (0288) WRITE(6 , 110)I (0289) ID=1 (0290) C CHECK FOR ZERO STANDARD DEVIATIONS (0291) 12 IF(DOB(I,1).NE.0.0D0)GOTO14 (0292) IF(DOB(I,2).NE.0.D0.AND.IOB(I,1).EQ.1)GOTO14 (0293) WRITE(6 , 112)I (0294) 14 K=IOB(I,1) (0295) IF(K.EQ.1.OR.K.EQ.2.OR.K.EQ.3.OR.K.EQ.4.OR.K.EQ.-2)GOTO15 (0296) ID=1 (0297) GOTO18 (0298) 15 IF(K.EQ.-2)K=2 (0299) GOTO(16,17,17,17),K (0300) C CHECK FOR ZERO DISTANCE OBSERVATION IF ADJUSTMENT REQUESTED (0301) 16 IF(NCODE.EQ.2.AND.DOB(I,3).NE.0.0D0)GOTO18 (0302) IF(NCODE.EQ.1)GOTO18 (0303) WRITE(6 , 113)I (0304) C CHECK VALIDITY OF ANGULAR OBSERVATIONS IF ADJUSTMENT REQUESTED (0305) ID=1 (0306) GOTO18 (0307) 17 IF(NCODE.EQ.2.AND.DOB(I,2).GE.0.0D0.AND.DOB(I,2).LT.360.0D0.AND. (0308) @ DOB(I,3).GE.0.0D0.AND.DOB(I,3).LE.59.D0.AND.DOB(I,4).GE.0.0D0.AND (0309) @.DOB(I,4).LT.60.D0)GOTO18 (0310) IF(NCODE.EQ.1)GOTO18 (0311) WRITE(6 , 114)I (0312) ID=1 (0313) 18 CONTINUE (0314) 110 FORMAT(' ','*** INPUT ERROR #016 *** CODE FOR OBSERVATION NO. ', (0315) @I4,' IS NOT ACCEPTABLE, MUST BE 1,2,3,4 OR -2') (0316) 112 FORMAT(' ','*** INPUT ERROR #017 *** OBSERVATION NO. ',I4,' HAS BE (0317) @EN GIVEN A ZERO STANDARD DEVIATION: CHECK INPUT FACTORS,IF ANY.') (0318) 113 FORMAT(' ','*** INPUT ERROR #018 *** DISTANCE OBSERVATION NO. ', (0319) @I4,' IS ZERO') (0320) 114 FORMAT(' ','*** INPUT ERROR #019 *** OBSERVATION NO. ',I4,' HAS DE (0321) @GREES,MINUTES OR SECONDS OUT OF ACCEPTABLE RANGE.') (0322) RETURN (0323) END PROGRAM SIZE: PROCEDURE - 001124 LINKAGE - 000034 STACK - 000104 DOB D ARGUMENT 000056 0264S 0283S 0291 0292 0301 0307 I J LINKAGE 000422 0284M 0285 0288 0291 0292 0293 0294 0301 0303 0307 0311 ID J ARGUMENT 000061 0264S 0289M 0296M 0305M 0312M IOB J ARGUMENT 000053 0264S 0283S 0285 0292 0294 K J LINKAGE 000424 0285M 0287 0294M 0295 0298M 0299 NCODE J ARGUMENT 000067 0264S 0301 0302 0307 0310 NO J ARGUMENT 000050 0264S 0284 $110 000545 0288 0314D $112 000633 0293 0316D $113 000733 0303 0318D $114 001000 0311 0320D $12 000072 0287 0291D $14 000165 0291 0292 0294D $15 000254 0295 0298D $16 000303 0299 0301D $17 000364 0299 0307D $18 000534 0284 0297 0301 0302 0306 0307 0310 0313D 0000 ERRORS [FTN-REV18.2] $$$ LEPONT: PRE DE L'HAUT 6.1973 ADJ. # 02 0 1 3 3 3 3 1 0 FIXED 5 STATIONS 5 -493.4043 -003.9436 6 -430.2358 -204.3808 7 -728.3599 -308.0244 8 -773.0475 -088.6042 -9 OBSERVAT 4 5 6 0.5000 162. 30. 28.462 1 5 6 0.00029 210.1552 1 6 5 0.00029 210.1560 1 5 7 0.00043 384.2773 1 7 5 0.00043 384.2784 1 5 8 0.00035 292.1779 1 8 5 0.00035 292.1772 1 6 7 0.00037 315.6261 1 7 6 0.00037 315.6266 1 6 8 0.00041 361.8346 1 8 6 0.00041 361.8344 1 7 8 0.00030 223.9245 1 8 7 0.00030 223.9241 2 5 8 0.551 35.000 27.000 51.131 2 5 6 0.551 304.000 48.000 54.216 -2 5 7 0.551 359.000 59.000 59.644 2 6 5 0.551 53.000 50.000 47.256 2 6 7 0.551 322.000 10.000 7.345 -2 6 8 0.551 359.000 59.000 59.870 2 7 8 0.551 277.000 39.000 31.460 2 7 5 0.551 326.000 51.000 44.788 -2 7 6 0.551 359.000 59.000 59.773 2 8 6 0.551 35.000 30.000 15.926 2 8 7 0.551 95.000 19.000 53.468 -2 8 5 0.551 359.000 59.000 59.579 -9 LEPONT: PRE DE L'HAUT 5.1974 ADJ. # 02 0 1 3 3 3 3 1 0 FIXED 5 STATIONS 5 -493.4043 -003.9436 6 -430.2358 -204.3808 7 -728.3599 -308.0244 8 -773.0475 -088.6042 -9 OBSERVAT 1 5 6 0.00029 210.1563 1 6 5 0.00029 210.1556 1 5 7 0.00043 384.2772 1 7 5 0.00043 384.2774 1 5 8 0.00035 292.1782 1 8 5 0.00035 292.1788 1 6 7 0.00037 315.6263 1 7 6 0.00037 315.6262 1 6 8 0.00041 361.8347 1 8 6 0.00041 361.8352 1 7 8 0.00030 223.9248 1 8 7 0.00030 223.9245 2 5 7 0.551 0.0 0.0 0.389 2 5 8 0.551 35.000 27.000 51.131 -2 5 6 0.551 304.000 48.000 55.868 2 6 8 0.551 0.0 0.0 0.259 2 6 5 0.551 53.000 50.000 48.196 -2 6 7 0.551 322.000 10.000 8.123 2 7 6 0.551 0.0 0.0 0.713 2 7 8 0.551 277.000 39.000 30.974 -2 7 5 0.551 326.000 51.000 44.464 2 8 6 0.551 35.000 30.000 18.162 2 8 7 0.551 95.000 19.000 54.926 -2 8 5 0.551 359.000 59.000 59.903 -9 LEPONT: PRE DE L'HAUT 6.1978 ADJ. # 02 0 1 3 3 3 3 1 FIXED 5 STATIONS 5 -493.4043 -003.9436 6 -430.2358 -204.3808 7 -728.3599 -308.0244 8 -773.0475 -088.6042 -9 OBSERVAT 1 5 6 0.00029 210.1569 1 5 7 0.00043 384.2789 1 5 8 0.00035 292.1790 1 6 7 0.00037 315.6271 1 6 8 0.00041 361.8363 1 6 5 0.00029 210.1566 1 7 8 0.00030 223.9247 1 7 5 0.00043 384.2787 1 7 6 0.00037 315.6274 1 8 5 0.00035 292.1787 1 8 6 0.00041 361.8364 1 8 7 0.00030 223.9248 2 5 6 0.551 0.0 0.0 0.0 2 5 7 0.551 55.000 11.000 4.488 -2 5 8 0.551 90.000 38.000 56.364 2 6 7 0.551 0.0 0.0 0.0 2 6 8 0.551 37.000 49.000 52.428 -2 6 5 0.551 91.000 40.000 38.712 2 7 8 0.551 0.0 0.0 0.0 2 7 5 0.551 49.000 12.000 13.068 -2 7 6 0.551 82.000 20.000 29.220 2 8 5 0.551 0.0 0.0 0.0 2 8 6 0.551 35.000 30.000 17.028 -2 8 7 0.551 95.000 19.000 53.760 -9 $$$