IMPLICIT REAL*8 ($), INTEGER*2 (L) DIMENSION $A(50,20),$P(50,50),$T(50),$HD(50),$AHD(50),$AT(20,50), @ $V(50),$EN(20,20),$ENINV(20,20),$U(20),$EX(20), @ $FMTA(4),$FMTB(3) DIMENSION A(50,20),P(50,50),T(50),HD(50),AHD(50),AT(20,50), @ V(50),EN(20,20),ENINV(20,20),U(20),EX(20),D(50), @ ERR(50),X(20),Y(20),Z(20),XI(20),YI(20),ZI(20) DIMENSION IA(50,20),ISTN(20),IWA(20),IWB(20),KTEXT(20,40),KSDP(2), @ KOURSE(7) DIMENSION LOF(100),LOT(100),LFIX(20),LD(100),LN(50),LF(50),LT(50) LOGICAL*1 FMTA(25),FMTB(24),MAP(40,60),MCR,MFIX EQUIVALENCE (FMTA(1),$FMTA(1)),(FMTB(1),$FMTB(1)) COMMON IR DATA MAP/2400*' '/,MCR,MFIX/'+','*'/ DATA IRA,IRN/50,20/,P/2500*0./,KY,KSDP/'Y','SING','DOUB'/ DATA $FMTA/'(7X,I2,F','10.1,F13','.1,F15.2',')'/, @ $FMTB/'(7X,I3,2','I10,F15.','3,F16.1)'/ ROUND(Q,LDD)=IFIX((Q+SIGN(0.5/10.**LDD,Q))*10.**LDD)/10.**LDD SHIFT(RAN,LDD)=IFIX((URAND(IR)*RAN*2-RAN)*10.**LDD)/10.**LDD READ (5,500) KOURSE 500 FORMAT (7A4) READ(5,501) NS,NLO,NLPO,XR,LDDX,ZR,LDDZ,SDH,VF,IRS,IAS,INC,NA,KDEC 501 FORMAT (3I3,1X,2(F7.1,I3),2G5.0,4I5,A1) READ (5,502) LFIX 502 FORMAT (20I1) READ (5,503) XI,YI,ZI 503 FORMAT (20F4.1) READ (5,504) (LOF(I),LOT(I),I=1,NLPO) 504 FORMAT ((10(I2,I3,3X))) READ (5,505,END=100) ((KTEXT(I,J),I=1,20),J=1,40) 505 FORMAT (20A4) J=41 100 NTEX=J-1 IR=IRS NPL=NS*(NS-1)/2 NUL=NPL-NLPO NDL=NUL-NLO NPA=NUL DO 401 I=2,NDL NPA=NPA*(NUL-I+1)/I 401 CONTINUE LDDH=LDDZ+1 FMTA(12)=LDDX+240 FMTA(18)=FMTA(12) FMTA(24)=LDDZ+240 FMTB(17)=LDDH+240 FMTB(23)=FMTA(12) WRITE (6,623) 623 FORMAT ('1'/3(6X,48('M')/),6X,'MMM ',25('M'),15X,'MMM'/6X,'MMM ' @,25('M'),' P R O G R A M MMM'/6X,'MMM ',25('M'),15X,'MMM'/6X, @'MMM ',43('M')/2(6X,'MMM MM',6X,'MM MM ',3('MM',6X),'MMM'/), @2(6X,'MMM',5(' MM'),'MMMM MM',2(' MMMMMM'),'M'/),6X,'MMM MM', @6X,3('MM '),4X,2('MM',6X),'MMM'/6X,'MMM ',5('MM',6X),'MMM'/2(6X, @'MMM MM MMMMMMM MMM MM ',2('MMMMMM '),'MMM'/),2(6X, @'MMM MM MMMM MM',3('MM',6X),'MMM'/),3(6X,48('M')/)/) WRITE (6,600) IRS,NS,NLO,NPL,NLPO,NDL,NPA,NA,IAS,INC, @ XR,ZR,LDDX,LDDZ,SDH,VF,KDEC 600 FORMAT (6X,'RANDOM GENERATOR SEED',20('.'),I6// @6X,'NUMBER OF BENCH MARKS',20('.'),I6// @6X,'NUMBER OF LINES OBSERVED',17('.'),I6// @6X,'NUMBER OF POSSIBLE LINES',17('.'),I6// @6X,'NUMBER OF LINES NEVER OBSERVED',11('.'),I6// @6X,'NUMBER OF LINES RANDOMLY OMITTED', 9('.'),I6/// @6X,'NUMBER OF POSSIBLE ASSIGNMENTS',11('.'),I6// @6X,'NUMBER OF ASSIGNMENTS REQUIRED',11('.'),I6// @6X,'FIRST ASSIGNMENT NUMBER',18('.'),I6// @6X,'ASSIGNMENT NUMBER INCREMENT',14('.'),I6//6X,48('-')/32X, @'HORIZONTAL VERTICAL'/6X,48('-')/6X,'RANDOM COORD. RANGE ', @2F12.1//6X,'NUMBER OF DECIMAL DIGITS',7X,I3,9X,I3/6X,48('-')//6X, @'STANDARD DEVIATION OF BM HEIGHTS ',5('.'),F10.6//6X,'VARIANCE FAC @TOR (P=VF*10/DIST) ',7('.'),F10.6//6X,'OPTIONS: AUTHENTICITY DEC @LARATION ',10('.'),1X,A1) YMAX=YI(1) XMAX=XI(1) XMIN=XI(1) YMIN=YI(1) DO 424 I=2,NS XMAX=AMAX1(XMAX,XI(I)) YMAX=AMAX1(YMAX,YI(I)) XMIN=AMIN1(XMIN,XI(I)) YMIN=AMIN1(YMIN,YI(I)) 424 CONTINUE XRAN=XMAX-XMIN YRAN=YMAX-YMIN XSC=40/XRAN YSC=55/YRAN SC=AMIN1(XSC,YSC) DO 425 I=1,NS IX=40-(XI(I)-XMIN)*SC IY=(YI(I)-YMIN)*SC+2 IF (IX.LE.0.OR.IX.GT.50.OR.IY.LE.0.OR.IY.GT.58) GO TO 425 MAP(IX,IY)=MCR IF (LFIX(I).EQ.1) MAP(IX,IY)=MFIX ITEN=I/10 IU=I-ITEN*10 IF (ITEN.GT.0) MAP(IX,IY+1) =ITEN+240 MAP(IX,IY+2)=IU+240 425 CONTINUE WRITE (6,620) (ZI(I),I=1,NS) 620 FORMAT ('1',5X,'LEVELLING NET'/6X,13('=')//6X,'INITIAL BM HEIGHTS: @ ',20F5.1) WRITE (6,621) MCR,MFIX,((MAP(I,J),J=1,60),I=1,40) 621 FORMAT (/6X,'PLOT OF BASIC NET',10X,A1,' = BM',5X,A1,' = FIXED BM' @/6X,'+',62('-'),'+'/6X,'|',62X,'|'/(6X,'| ',60A1,' |')) WRITE (6,622) (LOF(I),LOT(I),I=1,NLPO) 622 FORMAT (6X,'|',62X,'|'/6X,'+',62('-'),'+'//6X,'LINES NEVER OBSERVE @D',/6X,20('-')//(6X,10(I2,' ->',I2,3X))) DO 402 I=1,NDL LD(I)=I 402 CONTINUE IE=NDL-1 KAS=1 DO 403 IAN=1,NPA IF (IAN.LT.IAS.OR.MOD(IAN-IAS,INC).NE.0) GO TO 101 DO 404 I=1,NS X(I)=XI(I)+SHIFT(XR,LDDX) Y(I)=YI(I)+SHIFT(XR,LDDX) Z(I)=ZI(I)+SHIFT(ZR,LDDZ) 404 CONTINUE CALL NORMAL (0.0,SDH,NLO,ERR) DO 408 I=1,NLO DO 408 J=1,NS IA(I,J)=0 408 CONTINUE KL=1 KLPO=0 IP=1 IFE=NS-1 DO 405 IF=1,IFE K=NS*(IF-1)-(IF*(IF-1))/2-IF ITS=IF+1 DO 406 IT=ITS,NS DO 407 I=1,NLPO IF (LOF(I).EQ.IF.AND.LOT(I).EQ.IT) GO TO 103 407 CONTINUE ILN=K+IT IF (ILN.EQ.LD(IP)+KLPO) GO TO 104 LN(KL)=ILN LF(KL)=IF LT(KL)=IT DIST=SQRT((X(IT)-X(IF))**2+(Y(IT)-Y(IF))**2) D(KL)=ROUND(DIST,LDDX) P(KL,KL)=VF*10./D(KL) H=Z(IT)-Z(IF)+ERR(KL) HD(KL)=ROUND(H,LDDH) T(KL)=-HD(KL) IF (LFIX(IF).NE.0) T(KL)=T(KL)-Z(IF) IF (LFIX(IT).NE.0) T(KL)=T(KL)+Z(IT) IA(KL,IF)=-1 IA(KL,IT)=1 KL=KL+1 IF (KL.GT.NLO) GOTO 106 GO TO 406 103 KLPO=KLPO+1 GO TO 406 104 IP=IP+1 406 CONTINUE 405 CONTINUE 106 DO 410 I=1,NS K=0 DO 411 KL=1,NLO IF (LF(KL).EQ.I.OR.LT(KL).EQ.I) K=K+1 IF (K.EQ.2) GO TO 410 411 CONTINUE GO TO 101 410 CONTINUE NFIX=0 DO 409 I=1,NS IF (LFIX(I).EQ.0) GO TO 105 NFIX=NFIX+1 GO TO 409 105 IF (NFIX.EQ.0) GO TO 409 DO 426 J=1,NLO IA(J,I-NFIX)=IA(J,I) 426 CONTINUE 409 CONTINUE NF=NS-NFIX WRITE (6,601) KOURSE,IAN,IRS,NS,NFIX,NLO 601 FORMAT ('1',5X,7A4,27X,18('*')/61X,'*',16X,'*'/61X,'* PROBLEM NUMB @ER *'/ @6X,'L E V E L L I N G N E T',29X,'*',16X,'*'/6X,26('='),29X,'*' @,I8,'-',I3,4X,'*'/61X,'*',16X,'*'/61X,18('*')/// @6X,'THE HORIZONTAL COORDINATES (IN A LOCAL PLANE COORDINATE SYSTEM @) OF ',I2,' BENCH'/ @6X,'MARKS ARE GIVEN BELOW IN TABLE A. THE KNOWN HEIGHTS OF ',I2, @' OF THE MARKS ARE'/ @6X,'ALSO GIVEN AND THESE ARE TO BE HELD FIXED. DETAILS OF ',I2, @' LEVELLING LINES'/ @6X,'CONNECTING THE BENCH MARKS, ALONG WHICH THE STATED HEIGHT DIFF @ERENCES HAVE'/ @6X,'BEEN OBSERVED, ARE SET OUT IN TABLE B. ALL HEIGHTS AND HEIGHT @ DIFFERENCES'/ @6X,'ARE IN METRES.'//6X,'REQUIRED:'/6X,9('-')/) IF (NTEX.EQ.0) GO TO 107 WRITE (6,602) ((KTEXT(I,J),I=1,20),J=1,NTEX) 602 FORMAT (6X,20A4) 107 WRITE (6,603) KOURSE,IAN,IRS 603 FORMAT ('1',5X,7A4,27X,18('*')/61X,'*',16X,'*'/61X,'* PROBLEM NUMB @ER *'/6X,'NAME:',35('_'),15X,'*',16X,'*'/61X,'*',I8,'-',I3,4X,'*'/ @61X,'*',16X,'*'/6X,'STUDENT ID#:',11('_'),32X,18('*')) IF (KDEC.EQ.KY) WRITE (6,604) 604 FORMAT (///6X,'DECLARATION OF AUTHENTICITY'/6X,27('-')// @6X,'I HEREBY DECLARE THAT ALL OF THE WORK REQUIRED TO OBTAIN THE R @ESULTS'/ @6X,'PRESENTED IN THIS REPORT, INCLUDING THE WRITING OF NON-SYSTEM @COMPUTER'/ @6X,'PROGRAMS USED AND/OR HAND CALCULATIONS, WAS PERFORMED ENTIRELY @ BY MYSELF.'///6X,'SIGNATURE:',25('_'),10X,'DATE:',20('_')) DO 412 I=1,2 IF (I.EQ.2) WRITE (6,605) IAN,IRS 605 FORMAT ('1',5X,18('*')/6X,'*',16X,'*'/6X,'* PROBLEM NUMBER *'/6X, @'*',16X,'*'/6X,'*',I8,'-',I3,4X,'*'/6X,'*',16X,'*'/6X,18('*')) WRITE (6,606) 606 FORMAT (//6X,'TABLE A: BENCH MARK COORDINATES'/6X,32('=')//6X, @46('-')/6X,'BM # NORTH (KM) EAST (KM) HEIGHT (FIXED)'/ @6X,46('-')) JFR=0 DO 413 J=1,NS IF (LFIX(J).EQ.0) GO TO 108 WRITE (6,FMTA) J,X(J),Y(J),Z(J) GO TO 413 108 WRITE (6,FMTA) J,X(J),Y(J) JFR=JFR+1 ISTN(JFR)=J 413 CONTINUE WRITE (6,607) 607 FORMAT (6X,46('-')///6X,'TABLE B: OBSERVED HEIGHT DIFFERENCES AND @ DISTANCES'/6X,51('=')//6X,62('-')/6X,'LINE # FROM BM# TO BM# @ HEIGHT DIFFERENCE DISTANCE (KM)'/6X,62('-')) WRITE (6,FMTB) (LN(J),LF(J),LT(J),HD(J),D(J),J=1,NLO) WRITE (6,608) 608 FORMAT (6X,62('-')) 412 CONTINUE WRITE (6,609) 609 FORMAT ('1'/10X,'ABSOLUTE'/11X,'TERMS',8X,'DESIGN MATRIX'/10X, @8('='),6X,15('=')) DO 414 I=1,NLO WRITE (6,610) I,T(I),(IA(I,J),J=1,NF) 610 FORMAT (/1X,I4,F13.5,3X,20I4) 414 CONTINUE WRITE (6,611) 611 FORMAT (///10X,'W E I G H T M A T R I X'/10X,26('=')) DO 415 I=1,NLO WRITE (6,612) I,(P(I,J),J=1,NLO) 612 FORMAT (/1X,I4,3X,20F6.3/(8X,20F6.3)) 415 CONTINUE DO 416 I=1,NLO $T(I)=T(I) $HD(I)=HD(I) DO 417 J=1,NLO $P(I,J)=P(I,J) IF (J.GT.NF) GO TO 417 A(I,J)=IA(I,J) $A(I,J)=IA(I,J) 417 CONTINUE 416 CONTINUE CALL SSOLN (A,IRA,T,P,NLO,NF,EN,IRN,U,ENINV,EX,V,DET,AT,IWA,IWB) CALL DSOLN ($A,IRA,$T,$P,NLO,NF,$EN,IRN,$U,$ENINV,$EX,$V,$DET,$AT, @ IWA,IWB) IF (ABS(DET).GE.1.E-10.AND.DABS($DET).GE.1.D-20) GO TO 109 WRITE (6,613) DET,$DET 613 FORMAT ('1***** ERROR ***** NORMAL MATRIX DOES NOT PASS SINGUL @ARITY TEST'//16X,'S.P. DET. =',E20.6/16X,'D.P. DET. =',D20.15) GO TO 101 109 WRITE (6,614) KSDP(1),DET 614 FORMAT ('1'/6X,A4,'LE PRECISION SOLUTION',20X,'DETERMINANT =', @G15.6/6X,25('*')///6X,'N O R M A L E Q U A T I O N S'/6X, @32('-')///10X,'ABSOLUTE'/11X,'TERMS',8X,'NORMAL MATRIX'/10X, @8('='),6X,13('=')) DO 418 I=1,NF WRITE (6,615) I,U(I),(EN(I,J),J=1,NF) 615 FORMAT (/1X,I4,F13.5,3X,10F11.5/(21X,10F11.5)) 418 CONTINUE WRITE (6,616) 616 FORMAT (///6X,'S O L U T I O N'/6X,15('-')///3X,'STN. ADJ. HEIGH @T NORMAL MATRIX INVERSE'/3X,4('='),3X,11('='),3X,21('=')) DO 419 I=1,NF WRITE (6,615) ISTN(I),EX(I),(ENINV(I,J),J=1,NF) 419 CONTINUE CALL MADDS(AHD,IRA,HD,IRA,V,IRA,NLO,1) WRITE (6,617) (LN(I),LF(I),LT(I),HD(I),AHD(I),V(I),I=1,NLO) 617 FORMAT ('1'/6X,'ADJUSTED OBSERVATIONS AND RESIDUALS'/6X,35('=')// @6X,70('-')/6X,'LINE # FROM BM# TO BM# HEIGHT DIFF. ADJ. HT @. DIFF. RESIDUAL'/6X,70('-')/(7X,I3,2I10,3F15.5)) WRITE (6,618) 618 FORMAT (6X,70('-')) WRITE (6,614) KSDP(2),$DET DO 420 I=1,NF WRITE (6,615) I,$U(I),($EN(I,J),J=1,NF) 420 CONTINUE WRITE (6,616) DO 421 I=1,NF WRITE (6,615) ISTN(I),$EX(I),($ENINV(I,J),J=1,NF) 421 CONTINUE CALL MADDD ($AHD,IRA,$HD,IRA,$V,IRA,NLO,1) WRITE (6,617) (LN(I),LF(I),LT(I),$HD(I),$AHD(I),$V(I),I=1,NLO) WRITE (6,618) IF (KAS.EQ.NA) GO TO 102 KAS=KAS+1 101 LD(NDL)=LD(NDL)+1 IF (LD(NDL).LE.NUL) GO TO 403 DO 422 I=1,IE IP=NDL-I IF (LD(IP).EQ.NUL-I) GO TO 422 LD(IP)=LD(IP)+1 JS=IP+1 DO 423 J=JS,NDL LD(J)=LD(J-1)+1 423 CONTINUE GO TO 403 422 CONTINUE 403 CONTINUE 102 WRITE (6,619) 619 FORMAT ('1***** E N D ... E N D ... E N D *****') STOP 44 END SUBROUTINE NORMAL (AMEAN,SD,NO,A) DIMENSION A(NO) COMMON IR DO 401 I=1,NO SUM=0. DO 402 K=1,12 SUM=SUM+URAND(IR) 402 CONTINUE A(I)=AMEAN+(SUM-6.)*SD 401 CONTINUE RETURN END SUBROUTINE SSOLN (A,IRA,T,P,NO,NU,EN,IRN,U,ENINV,EX,V,DET,AT, @ IWA,IWB) DIMENSION A(IRA,NU),T(NO),P(IRA,NO),EN(IRN,NU),U(NU),ENINV(IRN,NU) @ ,EX(NU),V(NO),AT(IRN,NO),IWA(NU),IWB(NU) CALL TRNSS (AT,IRN,A,IRA,NO,NU) CALL MMULS (AT,IRN,AT,IRN,P,IRA,NU,NO,NO) CALL MMULS (EN,IRN,AT,IRN,A,IRA,NU,NO,NU) CALL MMULS (U,NU,AT,IRN,T,NO,NU,NO,1) DO 401 I=1,NU U(I)=-U(I) 401 CONTINUE CALL COPYS (ENINV,IRN,EN,IRN,NU,NU) CALL MINVS (ENINV,IRN,NU,DET,IWA,IWB) IF (ABS(DET).LT.1.E-10) RETURN CALL MMULS (EX,NU,ENINV,IRN,U,NU,NU,NU,1) CALL MMULS (V,NO,A,IRA,EX,NU,NO,NU,1) CALL MADDS (V,NO,V,NO,T,NO,NO,1) RETURN END SUBROUTINE DSOLN (A,IRA,T,P,NO,NU,EN,IRN,U,ENINV,EX,V,DET,AT, @ IWA,IWB) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(IRA,NU),T(NO),P(IRA,NO),EN(IRN,NU),U(NU),ENINV(IRN,NU) @ ,EX(NU),V(NO),AT(IRN,NO),IWA(NU),IWB(NU) CALL TRNSD (AT,IRN,A,IRA,NO,NU) CALL MMULD (AT,IRN,AT,IRN,P,IRA,NU,NO,NO) CALL MMULD (EN,IRN,AT,IRN,A,IRA,NU,NO,NU) CALL MMULD (U,NU,AT,IRN,T,NO,NU,NO,1) DO 401 I=1,NU U(I)=-U(I) 401 CONTINUE CALL COPYD (ENINV,IRN,EN,IRN,NU,NU) CALL MINVD (ENINV,IRN,NU,DET,IWA,IWB) IF (DABS(DET).LT.1.E-20) RETURN CALL MMULD (EX,NU,ENINV,IRN,U,NU,NU,NU,1) CALL MMULD (V,NO,A,IRA,EX,NU,NO,NU,1) CALL MADDD (V,NO,V,NO,T,NO,NO,1) RETURN END