C *********************************************** JGGM C * * JGGM C ************* PROGRAM MODNEU ************* JGGM C * * JGGM C *********************************************** JGGM C JGGM C THE PROGRAM MODNEU AS PRESENTED BY THE KERN CO. HAS BEEN JGGM C MODIFIED FOR USE ON THE IBM 360 SYSTEM AT UNB. JGGM C JGGM C ALL MODIFICATIONS DENOTED BY THE CODE JGGM IN C.C. 73-76 JGGM C WERE CARRIED OUT IN NOVEMBER 1970 BY J.G. GIBBONS JGGM C JGGM C FOR STATEMENTS WHICH HAVE BEEN MODIFIED, THE ORIGINAL FORTRAN JGGM C STATEMENT HAS BEEN INCLUDED AS A COMMENT CARD. JGGM C JGGM C ALL SCALAR QUANTITIES AND SEVERAL ARRAYS HAVE BEEN PLACED IN JGGM C COMMON AND OVERLAYED BY THE ARRAY - LCO - . THIS HAS THE EFFECT OFJGGM C REDUCING STORAGE REQUIREMENTS BY ABOUT 15K AND PERMITS THE JGGM C PROGRAM TO BE RUN AS A CLASS=B JOB. JGGM C JGGM C OUTPUT OF STRIP COORDINATES HAS BEEN ALTERED TO PROVIDE MODEL JGGM C COORDINATES OF POINTS COMMON TO TWO MODELS BUT FOR WHICH NO JGGM C CONNECTION WAS PERFORMED. THE TWO MODELS ARE THEN SEPARATED JGGM C BY DOUBLE SPACING JGGM C JGGM C ******************************************************************JGGM C JGGM C TRANSFORMATION OF INDEPENDENT PHOTOGRAMMETRIC MODELS C TO A STRIP. KERN AND CO. AARAU 1968 C C SWITCH CODES 1 LIST INPUT, 2 LIST MODEL COORDINATES C 3 LIST MODEL COORDINATES WITHOUT REPETITIONS C 4 OUTPUT OF INTERMEDIATE RESULTS C 5 = 0 INPUT ALPHA AND BETA,=1 INPUT X AND Y C 6 =1 OUTPUT ON TAPE C C POINTNUMBER -1 READ ANOTHER STRIP, -2 STOP C DOUBLE PRECISION AL,BE,X1,Y1,Z1,SA,SN,TG,TGQ,DLQ,FAC,B12,B13,V1 JGGM 101 1,B22,B23,V2,B32,B33,SS1,SS2,SS3,F,S12,S13,S23,S1(100),S2(100) JGGM 102 3,S3(100),RM(100),PA(3,23),PN(3,23),A(3),C(3),V(3),AA(3,3),BB(3,3) JGGM 103 4,T(3,3) JGGM 104 DIMENSION X(3,2500),IPNR(2500),ICOD(2500),IMO(2500),LCO(2,2500) JGGM 01 COMMON I,J,NMESS,NN,L,LL,K,IK,AL,BE,NMOD,IFE,IPKT,IMOD,AKON,AKO JGGM 02 1,SCALE,ISWI(6),TOL(2),ITITEL(18),MODAN(101),MODEN(100),IANS(23) JGGM 03 2,IANZ(23,2,2),NRANS(23,2,2),IGEW(23,2,2),IDAR(20),NRREP(20),DELX JGGM 04 3,DEL(20),NRMOD(100),S1,S2,S3,RM,PA,PN,A,C,V,AA,BB,T,LDA(2500),MOA JGGM 05 4,IMESS,IREP,IA,NREP,KREP,X1,Y1,Z1,NR,REP,D,IMA,NPKT,IALT,INEU JGGM 06 COMMON MO2,SA,DLQ,B22,SS1,S13,J0,DELY,JG,NA1,SN,FAC,B23,SS2,S23, JGGM 08 1J1,DELZ,ICA,NN1,TG,B12,V2,SS3,DA,II,ICO,NAI,TGQ,B13,B32,F,NA,MO1, JGGM 09 2NNI,Z0,V1,B33,S12,DN,MOE,IHI JGGM 10 EQUIVALENCE (I,LCO(1)),(LCO(4851),X(1)) JGGM 11 C DIMENSION X(3,2500),IPNR(2500),ICOD(2500),IMO(2500), C 1 LDA(2500), MODAN(101),MODEN(100),IANZ(23,2,2),NRANS(23,2,2), C 2IGEW(23,2,2),IANS(23),IDAR(20),NRREP(20),DEL(20), C 3 ISWI(6),TOL(6),NRMOD(100),S1(100),S2(100),S3(100),RM(100) C 4 , PA(3,23),PN(3,23),A(3),C(3),V(3),AA(3,3),BB(3,3), C 5 T(3,3),ITITEL(14),LCO(2,2500) C C READ TITEL C NFILE=0 C 80 READ(5,90)(ITITEL(I),I=1,12) 80 READ(5,90) ITITEL JGGM 12 C 90 FORMAT(12A6) 90 FORMAT (18A4) JGGM 13 C IF(IPNR(NMESS+1) .EQ.-1) WRITE(6,92) C 92 FORMAT (1H1) WRITE(6,95) ITITEL JGGM 113 C WRITE(6,95)(ITITEL(I),I=1,12) C 95 FORMAT(1X,12A6) 95 FORMAT (1H1,18A4) JGGM 14 C C WRITE TITEL,READ AND WRITE SWITCH CODES AND TOLERANCES C WRITE(6,100) C 100 FORMAT(31H TRANSFORMATION OF INDEPENDENT C 1 24HPHOTOGRAMMETRIC MODELS /) READ(5,110)(ISWI(I),I=1,6),SCALE,AKON,TOL(1),TOL(2) 110 FORMAT(6I1,6F9.4) IF (SCALE .LT. 0.01) SCALE = 2. IF(TOL(1).LT.0.001) TOL(1)=0.2 IF(TOL(2).LT.0.001) TOL(2)=0.5 AKO = AKON/SCALE WRITE(6,120)(ISWI(I),I=1,6),SCALE,AKON,TOL(1),TOL(2) 120 FORMAT (53H0TRANSFORMATION OF INDEPENDENT PHOTOGRAMMETRIC MODELS/ JGGM 15 113H0SWITCH CODES,16X,6I4/31H0SCALE FACTOR FOR Z-COORDINATES ,6X, JGGM 16 2F9.3/37H VERTICAL SHIFT OF PROJECTION CENTRES ,F9.3/ JGGM 17 351H0TOLERANCE FOR ELIMINATION OF REPEATED MEASUREMENTS ,F9.3/ JGGM 18 448H TOLERANCE FOR ELIMINATION OF CONNECTING POINTS ,3X,F9.3/) JGGM 19 C 120 FORMAT (13H SWITCH CODES,16X,6I4/ C 1 36H SCALE FACTOR FOR Z-COORDINATES ,F9.3/ C 2 36H VERTICAL SHIFT OF PROJECTION CENTRE ,F9.3// C 3 52H TOLERANCE FOR ELIMINATION OF REPEATED MEASUREMENTS C 4 F7.3/ 48H TOLERANCE FOR ELIMINATION OF CONNECTING POINTS, C 5 F 11.3/) DO 130 I=1,2 130 TOL(I)=TOL(I) **2 C C READ ALL MEASUREMENTS DO 150 I=51,2500 READ(5,140)IPNR(I),ICOD(I),IMO(I),(X(J,I),J=1,3), 1 (LCO(J,I),J=1,2) 140 FORMAT(I4,I3,A3,3F8.3,2A4) IF (IPNR(I).GE.0) GO TO 150 NMESS = I-1 GO TO 160 150 CONTINUE 160 IF(ISWI(1) .EQ.0) GO TO 200 NN = (NMESS-49)/2 IF (ISWI(5).NE.0) GO TO 165 JGGM 21 WRITE(6,170) GO TO 175 JGGM 22 165 WRITE (6,166) JGGM 23 166 FORMAT (6H0INPUT/1H0,2(4X,5HCODES,9X,1HX,8X,1HY,8X,1HZ,7X JGGM 24 1 ,8HCOMMENTS,5X)/) JGGM 25 C 170 FORMAT(//6H INPUT//3X,6H CODES,6X,6H ALPHA,3X,6H BETA , C 1 6X,1HZ, 4X, 4HCODE/) 170 FORMAT (/6H0INPUT/1H0,2(5X,5HCODES,6X,5HDELTA,4X,4HBETA,7X,1HZ,5X JGGM 26 1 ,8HCOMMENTS,5X)/) JGGM 27 175 DO 180 L=1, NN JGGM 28 LL = L+50 180 WRITE(6,190)(IPNR(I),ICOD(I),IMO(I),(X(K,I),K=1,3), 1 (LCO(K,I),K=1,2),I=LL,NMESS,NN) C 190 FORMAT(2(I5,1X,I3,1X,A3,3F9.3,2X,2A6,5X)) 190 FORMAT (1H ,2(I5,1X,I3,1X,A3,3F9.3,2X,2A4,5X)) JGGM 29 C C CALCULATION OF COORDINATES 200 DO 250 I=51,NMESS IK = MOD(ICOD(I),100) IF (ISWI(5).NE.0) GO TO 240 AL = 0.01570796 * X(1,I) BE = 0.01570796 * X(2,I) C X(1,I) = 200. * (SIN(AL) + SIN(BE)) C X(2,I) = 200. * (1+COS(AL)-COS(BE)) X(1,I) = 200.*(DSIN(AL) + DSIN(BE)) JGGM 129 X(2,I) = 200.*(1.+DCOS(AL)-DCOS(BE)) JGGM 130 240 IF(IK .NE.1) GO TO 250 X(3,I) = X(3,I)+AKO 250 X(3,I) = X(3,I)*SCALE C C PRINTING OF MODEL COORDINATES IF (ISWI(2) .EQ.0) GO TO 300 WRITE(6,260) C 260 FORMAT(//18H MODEL COORDINATES //5X,6H CODES, C 1 9X,1HX,8X,1HY,8X,1HZ /) 260 FORMAT (/18H0MODEL COORDINATES/1H0,2(5X,5HCODES,8X,1HX,8X,1HY,8X JGGM 30 1 ,1HZ,18X)/) JGGM 31 NN = (NMESS-49)/2 DO 265 I = 1, NN LL = I+50 265 WRITE(6,270)( IPNR(K), ICOD(K), IMO(K),(X(L,K),L=1,3), 1 K=LL,NMESS,NN) 270 FORMAT (1H ,2(I5,I4,1X,A3,3F9.3,15X)) C 270 FORMAT (2(1X,I6,1X,I3,1X,A3,3F9.3,17X)) C C COUNTING OF MODELS 300 NMOD=1 NRMOD(1)=IMO(51) MODAN(1)=51 DO 310 I=52,NMESS IF(IMO(I) .EQ. NRMOD(NMOD)) GO TO 310 NMOD = NMOD+1 NRMOD(NMOD)=IMO(I) MODAN(NMOD) = I 310 CONTINUE MODAN(NMOD+1)=NMESS+1 MODEN(NMOD+1) = NMESS+1 *NEW C C REPETITIONS OF MEASUREMENTS IFE = 0 IPKT = 1 DO 320 I = 1, NMESS 320 LDA(I) = 0 DO 440 IMOD = 1,NMOD MOA = MODAN(IMOD) MOE = MODAN(IMOD +1) -1 MODAN(IMOD)= IPKT DO 420 IMESS = MOA,MOE IF (LDA(IMESS) .NE. 0) GO TO 420 LDA(IMESS) = 1 C SEARCH FOR REPETITION IREP =1 IDAR(1) = 1 NRREP(1)= IMESS IF (IMESS .EQ. MOE) GO TO 340 IA = IMESS+1 DO 330 I = IA,MOE IF (IPNR(I) .NE. IPNR(IMESS)) GO TO 330 LDA(I) = 1 IREP = IREP +1 IDAR (IREP) = 1 NRREP(IREP) = I 330 NREP = IREP C NUMBER OF REPETITIONS 340 KREP = NREP 350 IF (KREP .GT. 1) GO TO 370 C ONLY ONE MEASUREMENT X (1,IPKT) = X(1,IMESS) X (2,IPKT) = X(2,IMESS) X (3,IPKT) = X(3,IMESS) 360 IPNR(IPKT) = IPNR(IMESS) ICOD(IPKT) = ICOD(IMESS) IMO(IPKT) = IMO(IMESS) IPKT = IPKT+1 GO TO 420 C MORE THAN ONE MEASUREMENT 370 X1 = 0. Y1 = 0. Z1 = 0. DO 380 I = 1,NREP IF(IDAR(I) .EQ. 0) GO TO 380 NR = NRREP(I) X1 = X1 + X(1,NR) Y1 = Y1 + X(2,NR) Z1 = Z1 + X(3,NR) 380 CONTINUE REP = KREP X1 = X1 / REP Y1 = Y1 / REP Z1 = Z1 / REP D = 0. DO 390 I=1,NREP IF(IDAR(I) .EQ.0) GO TO 390 NR = NRREP(I) DEL(I) = (X(1,NR)-X1)**2+(X(2,NR)-Y1)**2 1 +(X(3,NR)-Z1)**2 IF(DEL(I) .LT.D) GO TO 390 D=DEL(I) * 0.99 IMA = I 390 CONTINUE IF (TOL(1) .GT. DEL(IMA)) GO TO 400 C POINT NOT WITHIN TOLERANCE IFE = 1+IFE NR = NRREP(IMA) IPNR(IPKT) = IPNR(NR) + 10000*IMA ICOD(IPKT) = 0 IMO(IPKT) = IMO(IMESS) X(1,IPKT) = X(1,NR) X(2,IPKT) = X(2,NR) X(3,IPKT) = X(3,NR) IPKT = IPKT + 1 IDAR(IMA) = 0 KREP = KREP - 1 GO TO 350 C POINT WITHIN TOLERANCE 400 X(1,IPKT) = X1 X(2,IPKT) = Y1 X(3,IPKT) = Z1 GO TO 360 420 CONTINUE MODEN(IMOD) = IPKT - 1 440 CONTINUE NPKT = IPKT -1 C C PRINTING OF REDUCED INPUT *NEW IF (ISWI(3) .EQ. 0) GO TO 490 **-1 WRITE(6,460) 460 FORMAT(//24H MEAN MODEL COORDINATES /) IF (IFE .GE. 1) WRITE (6,465) IFE 465 FORMAT( 10H THERE ARE,I3,14H DISCREPANCIES, 1 30H BETWEEN REPEATED MEASUREMENTS/) WRITE (6,466) JGGM 33 466 FORMAT(1H0,2(5X,5HCODES,8X,1HX,8X,1HY,8X,1HZ,18X)) JGGM 34 NN = (NPKT +1)/2 DO 470 I = 1, NN 470 WRITE(6,270)(IPNR(K), ICOD(K), IMO(K),(X(L,K),L=1,3), 1 K = I,NPKT,NN) C C LOOP MODELS C 490 IMOD = 0 IALT = 1 INEU = 2 500 IMOD = IMOD +1 IHI = INEU INEU = IALT IALT = IHI DO 505 I = 1,2 DO 505 J = 1,23 IANZ(J,I,INEU) =0 505 NRANS(J,I,INEU) =-MODAN(IMOD) MOA = MODAN(IMOD) MOE = MODEN (IMOD) C C SEARCH FOR CONNECTING POINTS DO 550 I = MOA, MOE IF (ICOD(I) .EQ.0) GO TO 550 JG = ICOD(I) / 100 ICOD(I) = ICOD(I)-100*JG IF(ICOD(I)) 530, 550, 510 510 IF(ICOD(I) .GT.23) GO TO 530 ICA = ICOD(I) IF(IANZ(ICA,1,INEU) .NE.0) GO TO 515 NRANS (ICA,1,INEU) = IPNR(I) IANZ (ICA,1,INEU) = I IGEW(ICA,1,INEU) =JG GO TO 550 515 IF(IANZ(ICA,2,INEU) .NE.0) GO TO 520 NRANS(ICA,2,INEU) = IPNR(I) IANZ(ICA,2,INEU) = I IGEW(ICA,2,INEU) =JG GO TO 550 520 ICO = 100 * JG + ICOD(I) WRITE(6,525) IPNR(I), ICO ,IMO(I) 525 FORMAT(/36H TOO MANY POINTS WITH THE SAME CODE, 1 6H POINT ,I5,2X,6H CODE ,I4,3X,6HMODEL ,A3) ICOD(I) = 0 GO TO 550 530 ICO = 100 *JG + ICOD(I) WRITE(6,540) IPNR(I),ICO, IMO(I) 540 FORMAT (/20H WRONGLY CODED POINT,I5,2X,6H CODE ,I4, 1 3X,6HMODEL ,A3) ICOD(I) = 0 550 CONTINUE C IF (IMOD .EQ. 1) GO TO 900 *NEW C **-1 C CONNECTING POINTS OF TWO MODELS 555 DO 570 I = 1, 23 IF(NRANS(I,2,IALT).EQ.NRANS(I,1,INEU)) GO TO 565 IANS(I)=0 IF (.NOT.((IANZ(I,1,IALT).NE.0.OR.IANZ(I,2,IALT).NE.0).AND. 1 (IANZ(I,1,INEU).NE.0 .OR.IANZ(I,2,INEU).NE.0)))GO TO 570 IF (.NOT.(NRANS(I,1,IALT) .EQ. NRANS(I,1,INEU) .OR. 1 NRANS(I,1,IALT) .EQ.NRANS(I,2,INEU))) GO TO 560 IHI = NRANS (I,1,IALT) NRANS(I,1,IALT) = NRANS(I,2,IALT) NRANS(I,2,IALT) = IHI IHI = IANZ(I,1,IALT) IANZ(I,1,IALT) = IANZ(I,2,IALT) IANZ(I,2,IALT) = IHI IHI = IGEW(I,1,IALT) IGEW(I,1,IALT) = IGEW(I,2,IALT) IGEW(I,2,IALT) = IHI 560 IF(NRANS(I,2,IALT) .EQ. NRANS(I,1,INEU)) GO TO 565 IF(NRANS(I,2,IALT) .NE. NRANS(I,2,INEU)) GO TO 570 IHI = NRANS(I,1,INEU) NRANS(I,1,INEU) = NRANS(I,2,INEU) NRANS(I,2,INEU) = IHI IHI = IANZ(I,1,INEU) IANZ(I,1,INEU) = IANZ(I,2,INEU) IANZ(I,2,INEU) = IHI IHI = IGEW(I,1,INEU) IGEW(I,1,INEU) = IGEW(I,2,INEU) IGEW(I,2,INEU) = IHI 565 IANS(I) = 1 570 CONTINUE C IF(ISWI(4) .LT.6) GO TO 574 WRITE(6,572)(NRANS(J,2,IALT),J=1,23),(NRANS(J,1,INEU),J=1,23) 572 FORMAT(/28H NRANS(J,2,IALT),(J,1,INEU) ,2(/1X,23I5)) C C TEST NUMBER OF CONNECTING POINTS 574 IHI = 1 IF(IANS(1) .EQ. 0) IHI=IHI+100 IF (IANS(2) * IANS(3) .EQ. 0) IHI=IHI+1 DO 575 I=4,23 IHI=IHI-IANS(I) 575 CONTINUE IF (IHI .LE. 0) GO TO 600 MO1 = NRMOD (IMOD-1) MO2 = NRMOD (IMOD) IF (IHI .LT. 50) GO TO 585 WRITE (6,580) MO1, MO2 580 FORMAT(/34H PROJECTION CENTRE MISSING, MODELS ,4X,A3,2X,A3) IHI = IHI -100 IF(IHI .LE.0) GO TO 595 585 WRITE (6,590) MO1,MO2 590 FORMAT(/37H NOT ENOUGH CONNECTING POINTS, MODELS ,1X,A3,2X,A3) 595 RM(IMOD) =0. S1(IMOD) =0. S2(IMOD) =0. S3(IMOD) =0. ISWI (6) = 0 *NEW GO TO 900 C C TRANSFORMATION C C SHIFT OF COORDINATE SYSTEM TO PROJECTION CENTRE 600 NA1 = IANZ (1,2,IALT) NN1 = IANZ (1,1,INEU) DO 670 I = 2,23 IF( IANS(I) .EQ. 0) GO TO 670 NAI = IANZ (I,2,IALT) NNI = IANZ (I,1,INEU) DO 660 J = 1,3 PA (J,I) = X(J,NAI)-X(J,NA1) 660 PN (J,I) = X(J,NNI)-X(J,NN1) 670 CONTINUE C C SCALING FACTOR RM SA = 0. SN = 0. DO 700 I=3,23 IF(IANS(I) .EQ.0) GO TO 700 IF(IGEW(I,2,IALT).GE. 1 .OR. IGEW(I,1,INEU) .GE.1) *NEW 1 GO TO 700 *NEW TG = PA(2,I)/PA(3,I) TGQ = TG ** 2 Z0 = AKON IF(ABS(AKON) .LT.1) Z0 = 100. DLQ = 1+TGQ+TGQ/(1+TGQ)*(PA(3,I)/Z0)**2 SA = SA + (PA(1,I)**2+PA(2,I)**2+PA(3,I)**2)/DLQ SN=SN+(PN(1,I)**2+PN(2,I)**2+PN(3,I)**2)/DLQ 700 CONTINUE C RM(IMOD)=SQRT(SA/SN) RM(IMOD) = DSQRT(SA/SN) JGGM 134 C IF(ISWI(4) .LT.5) GO TO 705 DO 704 I = 2,23 IF(IANS(I).EQ.0) GO TO 704 WRITE (6,703)I,(PA(J,I),J=1,3),(PN(J,I),J=1,3) 703 FORMAT(24H DETAILS. CODE PA AND PN ,I3,2X,3F10.3,3X,3F10.3) 704 CONTINUE C C ADJUSTMENT OF LENGTH OF VECTORS 705 DO 720 I=2,23 IF(IANS(I) .EQ. 0) GO TO 720 FAC=Z0/PA(3,I) DO 710 J=1,3 **-2 PN(J,I)=PN(J,I)*RM(IMOD) * FAC 710 PA(J,I)=PA(J,I) *FAC 720 CONTINUE C DO 730 I=1,3 V(I)=0. DO 730 J=1,3 730 BB(I,J)=0. C C VECTORS A AND C,SUMMATION OF V AND BB DO 800 I= 2,23 IF (IANS(I) .EQ.0) GO TO 800 IF (I .EQ.3) GO TO 800 DO 750 J = 1,3 A(J) = PA(J,I) + PN(J,I) 750 C(J) = PA(J,I) - PN(J,I) DO 760 J= 1,3 760 AA(J,J) = 0. AA(2,1) =-A(3) AA(1,2) = A(3) AA(3,1) = A(2) AA(1,3) =-A(2) AA(2,3) = A(1) AA(3,2) =-A(1) DO 770 J = 1,3 DO 770 K = 1,3 770 V(J) = V(J)+ AA(K,J) * C(K) DO 780 K = 1,3 DO 780 L = 1,3 DO 780 J = 1,3 780 BB(K,L) = BB(K,L)+AA(J,K)*AA(J,L) C IF (ISWI(4) .LT.4) GO TO 800 WRITE (6,790) I,(A(L),L=1,3),(C(L),L=1,3) 790 FORMAT (/20H DETAILS. CODE, A, C ,I3,2X,3F10.3,3X,3F10.3) 800 CONTINUE C C SOLUTION OF LINEAR EQUATIONS B12 = - BB(1,2)/BB(1,1) B13 = - BB(1,3)/BB(1,1) V1 = - V(1)/BB(1,1) B22 = BB(2,2)+BB(1,2)*B12 B23 = - (BB(2,3)+BB(1,2)*B13)/B22 V2 = - (V(2)+BB(1,2)*V1)/B22 B32 = BB(2,3)+BB(1,3)*B12 B33 = BB(3,3)+BB(1,3)*B13+B23*B32 S3(IMOD) = (V(3)+BB(1,3)*V1+B32*V2)/B33 S2(IMOD) = S3(IMOD) * B23-V2 S1(IMOD) = S3(IMOD) * B13+S2(IMOD)*B12-V1 C C TRANSFORMATION MATRIX SS1 = S1(IMOD)**2 SS2 = S2(IMOD)**2 SS3 = S3(IMOD)**2 F = RM(IMOD)/(1.+SS1+SS2+SS3) T(1,1)=F*(1.+SS1-SS2-SS3) T(2,2)=F*(1.-SS1+SS2-SS3) T(3,3)=F*(1.-SS1-SS2+SS3) F = F+F S12 = S1(IMOD)*S2(IMOD) S13 = S1(IMOD)*S3(IMOD) S23 = S2(IMOD)*S3(IMOD) T(1,2) = F * (S12-S3(IMOD)) T(1,3) = F * (S13+S2(IMOD)) T(2,1) = F * (S12+S3(IMOD)) T(2,3) = F * (S23-S1(IMOD)) T(3,1) = F * (S13-S2(IMOD)) T(3,2) = F * (S23+S1(IMOD)) C IF (ISWI(4) .LT.2) GO TO 820 WRITE (6,810) IMOD,((T(L,J),J=1,3),L=1,3) 810 FORMAT (/32H TRANSFORMATION MATRIX OF MODEL , 1 I4, 3(/3X,3F12.6)) 820 DO 830 J=1,3 V(J) = X(J,NA1) DO 830 K=1,3 830 V(J) =V(J)-T(J,K)*X(K,NN1) C C TRANSFORMATION OF CONNECTING POINTS DO 840 J=1,3 840 PN(J,1) = X(J,NA1) LDA(NN1) = 2 DA = -1. DO 870 I=2,23 IF(IANS(I) .EQ.0) GO TO 870 NN = IANZ(I,1,INEU) LDA(NN) = 2+I DO 850 J= 1,3 PN(J,I) = V(J) DO 850 K=1,3 850 PN(J,I) = PN(J,I)+T(J,K)*X(K,NN) C C TEST OF CONNECTING POINTS IF (I. LE.3) GO TO 870 IF (IHI .GE. 0) GO TO 870 NA = IANZ (I,2,IALT) DN = 0. DO 855 J=1,3 855 DN = DN+(PN(J,I)-X(J,NA))**2 IF(DN.LT.DA) GO TO 870 DA = DN IMA = I 870 CONTINUE IF (DA.LT.TOL(2)) GO TO 871 C C BAD CONNECTING POINT I = IMA NN = IANZ(I,1,INEU) NA = IANZ(I,2,IALT) IANZ (I,1,INEU) = 0 IANZ (I,2,IALT) = 0 NRANS(I,1,INEU) =-MODAN(IMOD)-1 NRANS(I,2,IALT) = -MODAN(IMOD-1) LDA(NN) = 0 ICOD(NN) = 0 ICOD(NA) =0 L = I + IGEW(I,2,IALT) * 100 WRITE (6,860) IPNR(NN), L 860 FORMAT(//25H BAD CONNECTION POINT NO. , 1 I5,5H CODE,I4,12H ELIMINATED /) JGGM 35 GO TO 555 C C TRANSFORMATION 871 DO 895 L=MOA,MOE IF (LDA(L)-2) 880, 890, 874 874 I = LDA(L)-2 DO 875 J = 1, 3 875 X(J,L) = PN(J,I) GO TO 895 880 DO 885 J = 1, 3 A(J) = V(J) DO 885 K = 1, 3 885 A(J) = A(J) + T(J,K) * X(K,L) DO 886 J = 1, 3 886 X(J,L) = A(J) GO TO 895 890 DO 891 J = 1, 3 891 X(J,L) = X(J,NA1) 895 CONTINUE C C TEST NUMBER OF MODELS 900 IF (IMOD .LT. NMOD) GO TO 500 C *NEW C PRINTING OF SCALE FACTOR AND S *NEW IF (ISWI(4).EQ.0) GO TO 901 WRITE (6,985) *NEW 985 FORMAT (//25H SCALE FACTOR, S1, S2, S3 /) *NEW WRITE (6,990) (RM(J), S1(J), S2(J), S3(J), J=2,IMOD) *NEW 990 FORMAT (1X,4F9.5) *NEW C C OUTPUT OF STRIP COORDINATES 901 DO 905 I=1,NPKT *NEW 905 LDA(I)=0 **-1 RM(NMOD+1) = 0. JGGM 135 C WRITE(6,906)(ITITEL(I), I=1,12) C 906 FORMAT(/// 1X,12A6) WRITE (6,95) ITITEL JGGM 36 WRITE(6,910) C 910 FORMAT(//19H STRIP COORDINATES //3X,6H CODES, C 1 10X,1HX,8X,1HY,8X,1HZ,11X,2HDX,7X,2HDY,7X,2HDZ/) 910 FORMAT(//19H STRIP COORDINATES /1H0,5X,5HCODES, JGGM 37 1 8X,1HX,8X,1HY,8X,1HZ,11X,2HDX,7X,2HDY,7X,2HDZ/) JGGM 38 DO 981 IMOD = 1,NMOD *NEW MOA = MODAN (IMOD) *NEW MOE = MODEN (IMOD) *NEW C JGGM C DOUBLE SPACE IF NO MODEL CONNECTION PERFORMED JGGM IF (RM(IMOD).EQ.0.0) WRITE (6,935) JGGM 39 DO 980 I=MOA,MOE *NEW IF(LDA(I) .LT.0) GO TO 980 **-1 C SEARCH FOR COMMON POINTS IF ((IMOD.LT.NMOD).AND.(RM(IMOD+1).EQ.0.0)) GO TO 950 JGGM 139 IF (I.EQ. NPKT) GO TO 950 J0 = MODAN (IMOD+1) *NEW J1 = MODEN (IMOD+1) *NEW DO 915 II = J0,J1 IF (IPNR(I) .NE. IPNR(II)) GO TO 915 IF (ICOD(I) .EQ. ICOD(II)) GO TO 920 915 CONTINUE GO TO 950 C COMMON POINT FOUND 920 DELX = (X(1,II) - X(1,I)) /2. DELY = (X(2,II) - X(2,I)) /2. DELZ = (X(3,II) - X(3,I)) /2. DO 930 K =1,3 930 X(K,I) = (X(K,I)+X(K,II))/2. LDA(II) =-1 WRITE (6,935) IPNR(I), ICOD(I), (X(K,I),K=1,3),DELX,DELY,DELZ C 935 FORMAT(1X,I6,I4,4X,3F9.3,2X,3F9.3) 935 FORMAT (1H ,I5,I4,4X,3F9.3,2X,3F9.3) JGGM 40 GO TO 980 C NO COMMON POINT FOUND 950 WRITE (6,935) IPNR(I),ICOD(I),(X(K,I),K=1,3) JGGM 41 C 950 WRITE (6,940) IPNR(I),ICOD(I),(X(K,I),K=1,3) C 940 FORMAT(1X,I6,I4,4X,3F9.3) 980 CONTINUE 981 CONTINUE *NEW C C******************************************************************************* C THE FOLLOWING SET OF INSTRUCTIONS IS INCLUDED IN THE ORIGINAL C PROGRAM FOR UNIVAC USERS REQUIRING OUTPUT ON MAGNETIC TAPE C THIS FACILITY OF NTRAN DOES NOT EXIST AT UNB AND HAS BEEN DELETED C******************************************************************************* C C1000 IF (ISWI(6).LE. 0) GO TO 1200 **-7 C *NEW C IF A POINT IS MEASURED IN TWO MODELS, THE MEAN *NEW C COORDINATES ARE USED AND THE MEASUREMENTS ELIMINATED. *NEW C NP = 0 *NEW C DO 995 I = 1,NPRT *NEW C IF (LDA(I) .LT.0) GO TO 995 *NEW C NP = NP+1 *NEW C IPNR (NP) = IPNR (I) *NEW C X(1,NP) = X(1,I) *NEW C X(2,NP) = X(2,I) *NEW C X(3,NP) = X(3,I) *NEW C 995 CONTINUE *NEW C NPKT = NP *NEW C C OUTPUT ON TAPE C NPKT3 = 3 * NPKT C ITITEL (13) = NPKT C ITITEL (14) = IPNR (NMESS+1) C CALL NTRAN (8,1,14,ITITEL,L1) C CALL NTRAN (8,1,NPKT,IPNR,L2) C CALL NTRAN (8,1,NPKT3,X,L4) C CALL NTRAN (8,9) *NEW CONTINUE C NFILE = NFILE + 1 *NEW C1010 IF (L1 .EQ. -1) GO TO 1010 C IF (L1 .LT. -1) GO TO 1300 C1020 IF (L2 .EQ. -1) GO TO 1020 C IF (L2 .LT. -1) GO TO 1300 C1040 IF (L4 .EQ. -1) GO TO 1040 C IF (L4 .LT. -1) GO TO 1300 C WRITE (6,1050) NFILE *NEW C1050 FORMAT (/21H OUTPUT ON TAPE, FILE ,I2) *NEW C GO TO 1200 **-2 C C ERROR IN TRANSFER TO TAPE C1300 WRITE (6,1310) L1, L2, L4 C1310 FORMAT (/27H ERROR IN TRANSFER TO TAPE, 3I6) C CALL NTRAN(8,22) C CALL NTRAN(8,11) C ISWI(6) = 0 C C TRANSFER TERMINATED C EV. NEW STRIP C IF (ISWI(6). LE. 0) GO TO 1500 C CALL NTRAN (8,11) **-1 C1500 STOP **-1 1200 IF (IPNR(NMESS+1) .EQ. -1) GO TO 80 CALL EXIT JGGM 42 END