IMPLICIT REAL*8(A-H,O-Z) MAIN0010 C MAIN0020 DATA NVERS/3HSX2/,KEYWD/4H****/ MAIN0030 C MAIN0040 DIMENSION FILEA(001600),FILEB(001600),FILEC(001600),FILED(000504) MAIN0050 * ,FILEE(000504) MAIN0060 C MAIN0070 DIMENSION ATA(003072),BTB(003072),CTC(003072) MAIN0080 * ,DTD(001536),ETE(001536),FTF(003072) MAIN0090 C MAIN0100 DIMENSION INTFA(003200),INTFB(003200),INTFC(003200),INTFD(001008) MAIN0110 * ,INTFE(001008),INTCTC(006144) MAIN0120 C MAIN0130 COMMON /DISK/LTRK,NTRK(20),NREC(20) MAIN0140 COMMON /DISK02/MAXTRK,MXBAND MAIN0150 COMMON /IOUNIT/ICARD,IPRINT,IPUNCH,IDISK,IAUX(80) MAIN0160 C MAIN0170 EQUIVALENCE (FILEA(1),INTFA(1)),(FILEB(1),INTFB(1)) MAIN0180 * ,(FILEC(1),INTFC(1)),(FILED(1),INTFD(1)) MAIN0190 * ,(FILEE(1),INTFE(1)),(CTC(1), INTCTC(1)) MAIN0200 C MAIN0210 EQUIVALENCE (IAUX(21),NPTREC),(IAUX(22),NPHREC),(IAUX(23),INTDGT) MAIN0220 * ,(IAUX(24), NYPT),(IAUX(25), NYPH),(IAUX(26), NYHO) MAIN0230 * ,(IAUX(27), NYVE),(IAUX(34), NYPHE),(IAUX(35), NYPTL) MAIN0240 C MAIN0250 ICARD=5 MAIN0260 IPRINT=6 MAIN0270 IPUNCH=7 MAIN0280 IDISK=11 MAIN0290 C MAIN0300 IRBITS=4 MAIN0310 IRBITD=8 MAIN0320 INTDGT=9 MAIN0330 LREC=3200 MAIN0340 LTRK=(LREC*IRBITS)/IRBITD MAIN0350 C MAIN0360 C DEFINE FILE 11(0869,3200,U,IDUMMY) MAIN0370 MAXTRK=0869 MAIN0380 C MAIN0390 NPTDIM=1600 MAIN0400 NPHDIM=0504 MAIN0410 NORDIM=3072 MAIN0420 NOIDIM=1536 MAIN0430 MXBAND=20 MAIN0440 C MAIN0450 NPTREC=10 MAIN0460 NPHREC=2 MAIN0470 C MAIN0480 MAXNU0=16 MAIN0490 MAXOFF=MAXNU0*MAXNU0 MAIN0500 MAXDAG=(MAXNU0*MAXNU0+MAXNU0)/2 MAIN0510 MXADRS=(MXBAND+3)/2 MAIN0520 C MAIN0530 IPTDIM=NPTDIM*2 MAIN0540 IPHDIM=NPHDIM*2 MAIN0550 IORDIM=NORDIM*2 MAIN0560 C MAIN0570 NYPT=4 MAIN0580 NYPH=5 MAIN0590 NYHO=4 MAIN0600 NYVE=3 MAIN0610 NYPHE=36 MAIN0620 NYPTL=10 MAIN0630 NYNUP=3 MAIN0640 C MAIN0650 C CHECK IN-CORE SPACE ALLOCATION MAIN0660 C MAIN0670 IERR=0 MAIN0680 C MAIN0690 IF(NPTDIM.GE.MAXOFF) GO TO 101 MAIN0700 WRITE(IPRINT,1000) NPTDIM,MAXOFF MAIN0710 IERR=1 MAIN0720 C MAIN0730 101 IF(NPTDIM.GE.NPHDIM) GO TO 102 MAIN0740 WRITE(IPRINT,1001) NPTDIM,NPHDIM MAIN0750 IERR=1 MAIN0760 C MAIN0770 102 IF(NPHDIM.GE.MXADRS) GO TO 103 MAIN0780 WRITE(IPRINT,1002) NPHDIM,MXADRS MAIN0790 IERR=1 MAIN0800 C MAIN0810 103 IF(NPHDIM.GE.NYPHE) GO TO 104 MAIN0820 WRITE(IPRINT,1002) NPHDIM,NYPHE MAIN0830 IERR=1 MAIN0840 C MAIN0850 104 IF(NORDIM.GE.MAXOFF) GO TO 105 MAIN0860 WRITE(IPRINT,1004) NORDIM,MAXOFF MAIN0870 IERR=1 MAIN0880 C MAIN0890 105 IF(NOIDIM.GE.MAXNU0) GO TO 110 MAIN0900 WRITE(IPRINT,1005) NOIDIM,MAXNU0 MAIN0910 IERR=1 MAIN0920 C MAIN0930 C CHECK EXTERNAL SPACE ALLOCATION MAIN0940 C MAIN0950 110 NTPT=NPTDIM/NYPT MAIN0960 NPTR=NTPT*NYPT MAIN0970 NTRKA=((NPTR-1)/LTRK+1)*NPTREC MAIN0980 C MAIN0990 NTPH=NPHDIM/NYPH MAIN1000 NPHR=NTPH*NYPH MAIN1010 NTRKD=((NPHR-1)/LTRK+1)*NPHREC MAIN1020 C MAIN1030 MAXPH=NTPH*NPHREC MAIN1040 NTPHE=NPHDIM/NYPHE MAIN1050 NPHRE=NTPHE*NYPHE MAIN1060 NPHERC=(MAXPH-1)/NTPHE+1 MAIN1070 NTRKE=((NPHRE-1)/LTRK+1)*NPHERC MAIN1080 C MAIN1090 NHOR=(NPTDIM/NYHO)*NYHO MAIN1100 NTRKF=(NHOR-1)/LTRK+1 MAIN1110 C MAIN1120 NVER=(NPTDIM/NYVE)*NYVE MAIN1130 NTRKG=(NVER-1)/LTRK+1 MAIN1140 C MAIN1150 NTPHI=NPHDIM/MXADRS MAIN1160 NPHRI=NTPHI*MXADRS MAIN1170 NPHIRC=(MAXPH-1)/NTPHI+1 MAIN1180 NTRKI=((NPHRI-1)/LTRK+1)*NPHIRC MAIN1190 C MAIN1200 NPHKRC=(MAXPH*(1+MXBAND)-1)/NORDIM+1 MAIN1210 NTRKK=((NORDIM-1)/LTRK+1)*NPHKRC MAIN1220 C MAIN1230 MAXPT=NTPT*NPTREC MAIN1240 MAXPTU=(MAXPT+1)/2 MAIN1250 NTPTL=NPTDIM/NYPTL MAIN1260 NPTRL=NTPTL*NYPTL MAIN1270 NPTLRC=(MAXPTU-1)/NTPTL+1 MAIN1280 NTRKL=((NPTRL-1)/LTRK+1)*NPTLRC MAIN1290 C MAIN1300 NTDAG=NORDIM/MAXDAG MAIN1310 NDAGR=NTDAG*MAXDAG MAIN1320 NDAGRC=(MAXPH-1)/NTDAG+1 MAIN1330 NTRK1=((NDAGR-1)/LTRK+1)*NDAGRC MAIN1340 C MAIN1350 NTOFF=NORDIM/MAXOFF MAIN1360 NOFFR=NTOFF*MAXOFF MAIN1370 MM=MAXPH-MXBAND-1 MAIN1380 NN=MAXPH*(MAXPH+1)/2-MAXPH-MM*(MM+1)/2 MAIN1390 NOFFRC=(NN-1)/NTOFF MAIN1400 NTRK2=((NOFFR-1)/LTRK+1)*NOFFRC MAIN1410 C MAIN1420 NTCTL=NOIDIM/MAXNU0 MAIN1430 NCTLR=NTCTL*MAXNU0 MAIN1440 NCTLRC=(MAXPH-1)/NTCTL+1 MAIN1450 NTRK3=((NCTLR-1)/LTRK+1)*NCTLRC MAIN1460 C MAIN1470 NTNUP=NOIDIM/NYNUP MAIN1480 NNUPR=NTNUP*NYNUP MAIN1490 NNUPRC=(MAXPTU-1)/NTNUP+1 MAIN1500 NTRK4=((NNUPR-1)/LTRK+1)*NNUPRC MAIN1510 C MAIN1520 NYFTF=MAXNU0*NYNUP MAIN1530 NTFTF=NORDIM/NYFTF MAIN1540 NFTFR=NTFTF*NYFTF MAIN1550 NFTFRC=(MAXPT-1)/NTFTF+1 MAIN1560 NTRK5=((NFTFR-1)/LTRK+1)*NFTFRC MAIN1570 C MAIN1580 NTRKRQ=NTRKA*4+NTRKD+NTRKE+NTRKF+NTRKG+NTRKI*2+NTRKK+NTRKL MAIN1590 * +NTRK1+NTRK2+NTRK3+NTRK4+NTRK5 MAIN1600 C MAIN1610 IF(NTRKRQ.LE.MAXTRK) GO TO 200 MAIN1620 WRITE(IPRINT,1010) IDISK,MAXTRK,LREC,IDISK,NTRKRQ,LREC MAIN1630 IERR=1 MAIN1640 C MAIN1650 200 IF(IERR.NE.0) GO TO 999 MAIN1660 C MAIN1670 IAUX(36)=NVERS MAIN1680 IAUX(37)=KEYWD MAIN1690 C MAIN1700 CALL INPUT(FILEA,FILEB,FILEC,FILED,FILEE,INTFA,INTFB,INTFC,INTFD,MAIN1710 * INTFE,NPTDIM,IPTDIM,NPHDIM,IPHDIM)MAIN1720 C MAIN1730 CALL LINKPH(FILEA,FILEB,FILEC,FILED,FILEE,INTFA,INTFB,INTFC,INTFD,MAIN1740 * INTFE,NPTDIM,IPTDIM,NPHDIM,IPHDIM)MAIN1750 C MAIN1760 CALL ADJUST(FILEA,FILEB,FILEC,FILED,FILEE,INTFA,INTFB,INTFC,INTFD,MAIN1770 * INTFE,ATA,BTB,CTC,DTD,ETE,FTF,INTCTC,NPTDIM,IPTDIM,MAIN1780 * NPHDIM,IPHDIM,NORDIM,NOIDIM,IORDIM)MAIN1790 C MAIN1800 CALL OUTPUT(FILEA,FILEB,FILEC,FILED,FILEE,INTFA,INTFB,INTFC,INTFD,MAIN1810 * INTFE,ATA,BTB,CTC,DTD,ETE,FTF,INTCTC,NPTDIM,IPTDIM,MAIN1820 * NPHDIM,IPHDIM,NORDIM,NOIDIM,IORDIM)MAIN1830 C MAIN1840 999 STOP MAIN1850 C MAIN1860 1000 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** POINT RECORD (NPTDIM =',I6, MAIN1870 * ') IS TOO SMALL', /,31X,'MINIMUM DIMENSION REQUIRED IS',I6) MAIN1880 1001 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** POINT RECORD (NPTDIM =',I6, MAIN1890 * ') IS SMALLER THAN PHOTO RECORD (NPHDIM =',I6,')') MAIN1900 1002 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** PHOTO RECORD (NPHDIM =',I6, MAIN1910 * ') IS TOO SMALL', /,31X,'MINIMUM DIMENSION REQUIRED IS',I6) MAIN1920 1004 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** NORM. RECORD (NORDIM =',I6, MAIN1930 * ') IS TOO SMALL', /,31X,'MINIMUM DIMENSION REQUIRED IS',I6) MAIN1940 1005 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** NORM. RECORD (NOIDIM =',I6, MAIN1950 * ') IS TOO SMALL', /,31X,'MINIMUM DIMENSION REQUIRED IS',I6) MAIN1960 1010 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** INSUFFICIENT NUMBER OF TRACK'MAIN1970 * ,'S SPECIFIED IN DEFINE FILE STATEMENT',/,31X,'DEFINE FILE', MAIN1980 * I3,'(',I4,',',I4,',U,IDUMMY) MUST BE CHANGED INTO DEFINE FI'MAIN1990 * ,'LE',I3,'(',I4,',',I4,',U,IDUMMY)') MAIN2000 C MAIN2010 END MAIN2020 SUBROUTINE INPUT(FILEA,FILEB,FILEC,FILED,FILEE,INTFA,INTFB,INTFC,PTA00010 * INTFD,INTFE,NPTDIM,IPTDIM,NPHDIM,IPHDIM) PTA00020 IMPLICIT REAL*8(A-H,O-Z) PTA00030 C PTA00040 DIMENSION FILEA(NPTDIM),FILEB(NPTDIM),FILEC(NPTDIM),FILED(NPHDIM),PTA00050 * FILEE(NPHDIM),INTFA(IPTDIM),INTFB(IPTDIM),INTFC(IPTDIM),PTA00060 * INTFD(IPHDIM),INTFE(IPHDIM) PTA00070 C PTA00080 DIMENSION SUBA(04),FIDXY(5,2),LFMT(20),IFIDXY(5,2) PTA00090 COMMON /BLOCKA/WATE(11,5) PTA00100 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00110 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00120 COMMON /DISK02/MAXTRK,MXBAND PTA00130 C PTA00140 EQUIVALENCE (IAUX(21),NPTREC),(IAUX(22),NPHREC),(IAUX(23),INTDGT) PTA00150 * ,(IAUX(24), NYPT),(IAUX(25), NYPH),(IAUX(26), NYHO) PTA00160 * ,(IAUX(27), NYVE),(IAUX(28), IYPT),(IAUX(29), IYPH) PTA00170 * ,(IAUX(30), NTPH),(IAUX(31),NACCPT),(IAUX(32),NACCPH) PTA00180 * ,(IAUX(33),MPTREC),(IAUX(34), NYPHE),(IAUX(35), NYPTL) PTA00190 C PTA00200 DATA LU,LF,IBLK/1HU,1HF,4H / PTA00210 DATA IFLA,IFLB,IFLC,IFLD,IFLE,IFLF,IFLG/1,2,3,4,5,6,7/ PTA00220 C PTA00230 NVERS=IAUX(36) PTA00240 MAXNR=10**INTDGT PTA00250 C PTA00260 C SET UP FILE DIMENSION PTA00270 C PTA00280 CALL SETDIM(NPTDIM,NYPT, NPTR,NTPT,IPTR,IYPT) PTA00290 CALL SETDIM(NPHDIM,NYPH, NPHR,NTPH,IPHR,IYPH) PTA00300 CALL SETDIM(NPTDIM,NYHO, NHOR,NTHO,IHOR,IYHO) PTA00310 CALL SETDIM(NPTDIM,NYVE, NVER,NTVE,IVER,IYVE) PTA00320 CALL SETDIM(NPHDIM,NYPHE, NPHRE,NTPHE,IPHRE,IYPHE) PTA00330 C PTA00340 MAXPT=NTPT*NPTREC PTA00350 MAXPH=NTPH*NPHREC PTA00360 C PTA00370 C READ HEADER CARD AND CHECK AUTHORIZATION CODE PTA00380 C PTA00390 READ(ICD,4) (IAUX(I),I=1,20) PTA00400 C PTA00410 IF(IAUX(20).EQ.IAUX(37)) GO TO 90 PTA00420 WRITE(IPR,5000) PTA00430 CALL ERRSTP(IPR) PTA00440 C PTA00450 90 IAUX(20)=IBLK PTA00460 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA00470 C PTA00480 C INPUT I/O OPTION PARAMETERS PTA00490 C PTA00500 READ(ICD,1) IFILE,IFMT,IOUT PTA00510 READ(ICD,2) IFCODE,IFDGTA,IFDGTB,IFNDGT PTA00520 READ(ICD,2) IPCODE,IPDGTA,IPDGTB PTA00530 READ(ICD,1) KFILE,KFMT,KOUT PTA00540 C PTA00550 KERR=0 PTA00560 IERR=0 PTA00570 C PTA00580 IF(IFILE.GE.0.AND.IFILE.LE.99) GO TO 100 PTA00590 WRITE(IPR,5001) IFILE PTA00600 IERR=1 PTA00610 100 IF(IFILE.NE.IPR.AND.IFILE.NE.IPUNCH.AND.IFILE.NE.IDISK) GO TO 103 PTA00620 WRITE(IPR,5102) IFILE PTA00630 IERR=1 PTA00640 103 IF(IFMT.EQ.LU.OR.IFMT.EQ.LF) GO TO 105 PTA00650 WRITE(IPR,5002) IFMT PTA00660 IERR=1 PTA00670 105 IF(IFILE.EQ.0) IFILE=ICD PTA00680 IF(IFILE.EQ.ICD) IFMT=LF PTA00690 C PTA00700 IF(IERR.NE.0) KERR=1 PTA00710 C PTA00720 CALL TESTCD(1,IFCODE,IFDGTA,IFDGTB,IFID,IHI,LOW,IERR) PTA00730 IF(IHI.LT.0) GO TO 120 PTA00740 C PTA00750 IF(IFNDGT.GE.1 .AND. IFNDGT.LE.INTDGT) GO TO 110 PTA00760 WRITE(IPR,5003) IFNDGT,INTDGT PTA00770 IERR=1 PTA00780 C PTA00790 110 IF(IERR.NE.0) GO TO 120 PTA00800 IF(IFNDGT.LT.LOW .OR. IFNDGT.GT.IHI) GO TO 115 PTA00810 IF(IHI.EQ.LOW) WRITE(IPR,5004) IFNDGT,IHI PTA00820 IF(IHI.NE.LOW) WRITE(IPR,5005) IFNDGT,LOW,IHI PTA00830 IERR=1 PTA00840 GO TO 120 PTA00850 C PTA00860 115 IFDIVL=10**(LOW-1) PTA00870 IFDIVH=10**(IHI-LOW+1) PTA00880 NFDIVL=10**(IFNDGT-1) PTA00890 C PTA00900 120 IF(IERR.NE.0) KERR=1 PTA00910 C PTA00920 CALL TESTCD(2,IPCODE,IPDGTA,IPDGTB,IPID,IHI,LOW,IERR) PTA00930 IF(IHI.LT.0.OR.IERR.NE.0) GO TO 125 PTA00940 IPDIVL=10**(LOW-1) PTA00950 IPDIVH=10**(IHI-LOW+1) PTA00960 C PTA00970 IF(IFID.EQ.0 .OR. IPID.EQ.0) GO TO 125 PTA00980 IF(IFCODE.NE.IPCODE) GO TO 125 PTA00990 WRITE(IPR,5006) IFCODE PTA01000 IERR=1 PTA01010 C PTA01020 125 IF(IERR.NE.0) KERR=1 PTA01030 C PTA01040 IF(KFILE.GE.0 .AND. KFILE.LE.99) GO TO 130 PTA01050 WRITE(IPR,5007) KFILE PTA01060 IERR=1 PTA01070 130 IF(KFILE.NE.IPR.AND.KFILE.NE.IPUNCH.AND.KFILE.NE.IDISK) GO TO 133 PTA01080 WRITE(IPR,5103) KFILE PTA01090 IERR=1 PTA01100 133 IF(KFMT.EQ.LU.OR.KFMT.EQ.LF) GO TO 135 PTA01110 WRITE(IPR,5008) KFMT PTA01120 IERR=1 PTA01130 135 IF(KFILE.EQ.0) KFILE=ICD PTA01140 IF(KFILE.EQ.ICD) KFMT=LF PTA01150 C PTA01160 IF(IERR.NE.0) KERR=1 PTA01170 C PTA01180 C INPUT INITIAL VALUE OF PRINCIPAL DISTANCE PTA01190 C PTA01200 READ(ICD,3) PD PTA01210 IF(PD.NE.0.0) GO TO 140 PTA01220 WRITE(IPR,5009) PTA01230 KERR=1 PTA01240 C PTA01250 140 IF(KERR.NE.0) CALL ERRSTP(IPR) PTA01260 C PTA01270 WRITE(IPR,3100) NVERS PTA01280 WRITE(IPR,3101) PTA01290 WRITE(IPR,3101) PTA01300 WRITE(IPR,3102) PTA01310 C PTA01320 IF(IFILE.EQ.ICD) WRITE(IPR,3103) PTA01330 IF(IFILE.NE.ICD.AND.IFMT.EQ.LF) WRITE(IPR,3104) IFILE PTA01340 IF(IFILE.NE.ICD.AND.IFMT.EQ.LU) WRITE(IPR,3105) IFILE PTA01350 WRITE(IPR,3102) PTA01360 IF(KFILE.EQ.ICD) WRITE(IPR,3106) PTA01370 IF(KFILE.NE.ICD.AND.KFMT.EQ.LF) WRITE(IPR,3107) KFILE PTA01380 IF(KFILE.NE.ICD.AND.KFMT.EQ.LU) WRITE(IPR,3108) KFILE PTA01390 WRITE(IPR,3102) PTA01400 C PTA01410 IF(IFID.EQ.0) GO TO 150 PTA01420 WRITE(IPR,3110) IFCODE PTA01430 WRITE(IPR,3102) PTA01440 WRITE(IPR,3111) PTA01450 WRITE(IPR,3112) IFDGTA,IFDGTB PTA01460 WRITE(IPR,3102) PTA01470 WRITE(IPR,3113) PTA01480 WRITE(IPR,3114) IFNDGT PTA01490 WRITE(IPR,3102) PTA01500 C PTA01510 150 IF(IPID.EQ.0) GO TO 155 PTA01520 WRITE(IPR,3116) IPCODE PTA01530 WRITE(IPR,3102) PTA01540 WRITE(IPR,3117) PTA01550 WRITE(IPR,3112) IPDGTA,IPDGTB PTA01560 WRITE(IPR,3102) PTA01570 C PTA01580 155 WRITE(IPR,3118) PD PTA01590 WRITE(IPR,3102) PTA01600 WRITE(IPR,3102) PTA01610 C PTA01620 WRITE(IPR,3119) NVERS PTA01630 WRITE(IPR,3102) PTA01640 WRITE(IPR,3120) MAXPH PTA01650 WRITE(IPR,3121) MAXPT PTA01660 WRITE(IPR,3122) NTHO PTA01670 WRITE(IPR,3123) NTVE PTA01680 WRITE(IPR,3102) PTA01690 WRITE(IPR,3125) NTPT PTA01700 WRITE(IPR,3124) NTPH PTA01710 WRITE(IPR,3126) MXBAND PTA01720 WRITE(IPR,3102) PTA01730 C PTA01740 WRITE(IPR,3101) PTA01750 WRITE(IPR,3101) PTA01760 C PTA01770 C INPUT IMAGE DATA, STORE ON (FILEA) PTA01780 C PTA01790 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA01800 WRITE(IPR,3200) PTA01810 C PTA01820 READ(ICD,5) ISET,(LFMT(I),I=1,18) PTA01830 C PTA01840 IOUT0=IOUT PTA01850 IOUT=0 PTA01860 JOUT=0 PTA01870 IF(IOUT0.EQ.1.OR.IOUT0.EQ.3) IOUT=1 PTA01880 IF(IOUT0.GE.2) JOUT=1 PTA01890 C PTA01900 CALL SETFIL(IFLA,NPTREC,NPTR,1) PTA01910 CALL OPEN(IFLA,NPTR,NYPT) PTA01920 C PTA01930 NPT=0 PTA01940 LPT=0 PTA01950 IRA=1-NYPT PTA01960 IIA=1-IYPT PTA01970 IERR=0 PTA01980 C PTA01990 IF(IFMT.EQ.LU) GO TO 165 PTA02000 IF(IFILE.NE.ICD) GO TO 160 PTA02010 IF(ISET.EQ.1) WRITE(IPR,3207) ISET PTA02020 IF(ISET.NE.1) WRITE(IPR,3208) ISET PTA02030 WRITE(IPR,3215) (LFMT(I),I=1,18) PTA02040 GO TO 170 PTA02050 160 IF(ISET.EQ.1) WRITE(IPR,3209) ISET,IFILE PTA02060 IF(ISET.NE.1) WRITE(IPR,3210) ISET,IFILE PTA02070 WRITE(IPR,3215) (LFMT(I),I=1,18) PTA02080 GO TO 170 PTA02090 165 IF(ISET.EQ.1) WRITE(IPR,3211) ISET,IFILE PTA02100 IF(ISET.NE.1) WRITE(IPR,3212) ISET,IFILE PTA02110 C PTA02120 170 IF(ISET.EQ.1 .OR. ISET.EQ.2) GO TO 180 PTA02130 WRITE(IPR,5101) ISET PTA02140 CALL ERRSTP(IPR) PTA02150 C PTA02160 180 IF(IOUT.NE.0) GO TO 185 PTA02170 WRITE(IPR,3201) PTA02180 GO TO 200 PTA02190 185 IF(ISET.EQ.1) WRITE(IPR,3213) PTA02200 IF(ISET.EQ.2) WRITE(IPR,3214) PTA02210 C PTA02220 200 IF(ISET.EQ.2) GO TO 205 PTA02230 C PTA02240 IF(IFMT.EQ.LF) READ(IFILE,LFMT) IPHA,IPT,XA,YA PTA02250 IF(IFMT.EQ.LU) READ(IFILE) IPHA,IPT,XA,YA PTA02260 IF(IPT.EQ.-99) GO TO 222 PTA02270 C PTA02280 IF(IPHA.NE.0) GO TO 202 PTA02290 IF(IOUT.NE.0) WRITE(IPR,3203) IPHA,IPT,XA,YA PTA02300 GO TO 200 PTA02310 C PTA02320 202 IF(IOUT.NE.0) WRITE(IPR,3202) IPHA,IPT,XA,YA PTA02330 ICASE=1 PTA02340 203 NPT=NPT+1 PTA02350 IF(IPHA.GT.0) GO TO 214 PTA02360 WRITE(IPR,5201) IPHA PTA02370 KERR=1 PTA02380 GO TO 214 PTA02390 C PTA02400 205 IF(IFMT.EQ.LF) READ(IFILE,LFMT) IPHA,IPHB,IPT, XA,YA, XB,YB PTA02410 IF(IFMT.EQ.LU) READ(IFILE) IPHA,IPHB,IPT, XA,YA, XB,YB PTA02420 IF(IPT.EQ.-99) GO TO 222 PTA02430 C PTA02440 ICASE=0 PTA02450 IF(IPHA.NE.0) ICASE=ICASE+1 PTA02460 IF(IPHB.NE.0) ICASE=ICASE+2 PTA02470 C PTA02480 IF(ICASE.NE.0) GO TO 207 PTA02490 IF(IOUT.NE.0) WRITE(IPR,3203) IPHA,IPT,XA,YA, IPHB,IPT,XB,YB PTA02500 GO TO 200 PTA02510 C PTA02520 207 GO TO (208,209,210),ICASE PTA02530 C PTA02540 208 IF(IOUT.NE.0) WRITE(IPR,3204) IPHA,IPT,XA,YA, IPHB,IPT,XB,YB PTA02550 GO TO 203 PTA02560 C PTA02570 209 IF(IOUT.NE.0) WRITE(IPR,3205) IPHA,IPT,XA,YA, IPHB,IPT,XB,YB PTA02580 NPT=NPT+1 PTA02590 GO TO 212 PTA02600 C PTA02610 210 IF(IOUT.NE.0) WRITE(IPR,3202) IPHA,IPT,XA,YA, IPHB,IPT,XB,YB PTA02620 NPT=NPT+2 PTA02630 C PTA02640 IF(IPHA.GT.0) GO TO 212 PTA02650 WRITE(IPR,5201) IPHA PTA02660 KERR=1 PTA02670 C PTA02680 212 IF(IPHB.GT.0) GO TO 214 PTA02690 WRITE(IPR,5201) IPHB PTA02700 KERR=1 PTA02710 C PTA02720 214 IF(IPT.GT.0) GO TO 216 PTA02730 IF(ICASE.EQ.1) WRITE(IPR,5202) IPT,IPHA PTA02740 IF(ICASE.EQ.2) WRITE(IPR,5202) IPT,IPHB PTA02750 IF(ICASE.EQ.3) WRITE(IPR,5203) IPT,IPHA,IPHB PTA02760 KERR=1 PTA02770 C PTA02780 216 IF(NPT.LE.MAXPT) GO TO 218 PTA02790 IF(IERR.NE.0) GO TO 200 PTA02800 WRITE(IPR,5204) MAXPT PTA02810 IERR=1 PTA02820 KERR=1 PTA02830 GO TO 200 PTA02840 C PTA02850 218 IF(KERR.NE.0) GO TO 200 PTA02860 C PTA02870 IF(ICASE.EQ.2) GO TO 220 PTA02880 C PTA02890 CALL APUT(IFLA,FILEA,NPTR, LPT,1, 1,1, IRA,IIA) PTA02900 LPT=LPT+1 PTA02910 IRA=IRA+NYPT PTA02920 IIA=IIA+IYPT PTA02930 C PTA02940 INTFA(IIA)=IPHA PTA02950 INTFA(IIA+1)=IPT PTA02960 FILEA(IRA+1)=DFLOAT(IPT) PTA02970 FILEA(IRA+2)=XA PTA02980 FILEA(IRA+3)=YA PTA02990 IF(ICASE.EQ.1) GO TO 200 PTA03000 C PTA03010 220 CALL APUT(IFLA,FILEA,NPTR, LPT,1, 1,1, IRA,IIA) PTA03020 LPT=LPT+1 PTA03030 IRA=IRA+NYPT PTA03040 IIA=IIA+IYPT PTA03050 C PTA03060 INTFA(IIA)=IPHB PTA03070 INTFA(IIA+1)=IPT PTA03080 FILEA(IRA+1)=DFLOAT(IPT) PTA03090 FILEA(IRA+2)=XB PTA03100 FILEA(IRA+3)=YB PTA03110 GO TO 200 PTA03120 C PTA03130 222 WRITE(IPR,3500) PTA03140 WRITE(IPR,3206) NPT PTA03150 C PTA03160 IF(KERR.NE.0) CALL ERRSTP(IPR) PTA03170 C PTA03180 CALL ACLOSE(IFLA,FILEA,NPTR,LPT) PTA03190 C PTA03200 IF(NREC(IFLA).NE.0) GO TO 225 PTA03210 WRITE(IPR,5205) PTA03220 CALL ERRSTP(IPR) PTA03230 C PTA03240 225 MPTREC=(NPT-1)/NTPT+1 PTA03250 CALL SETFIL(IFLA,MPTREC,NPTR,1) PTA03260 CALL SETFIL(IFLB,MPTREC,NPTR,1) PTA03270 CALL SETFIL(IFLC,MPTREC,NPTR,1) PTA03280 C PTA03290 C TOTAL SORTING OF POINT DATA ON (FILEA), INDEX = PHOTO NUMBER ONLY PTA03300 C PTA03310 CALL SORTD(IFLA,1,FILEA,FILEB,INTFA,INTFB,SUBA,NPTR,IPTR,NYPT, PTA03320 * IYPT) PTA03330 C PTA03340 C PHOTOWISE SORTING OF POINT DATA ON (FILEA), INDEX = POINT NUMBER PTA03350 C PTA03360 CALL SETFIL(IFLD,NPHREC,NPHR,1) PTA03370 CALL OPEN(IFLD,NPHR,1) PTA03380 C PTA03390 IGA=0 PTA03400 IPH=0 PTA03410 NPH=0 PTA03420 KPT=NPT PTA03430 PHADD=10.D0**(INTDGT+1) PTA03440 ADD=-PHADD PTA03450 IERR=0 PTA03460 LIM=MAXPH*NYPH PTA03470 LPH=0 PTA03480 IRD=0 PTA03490 IID=-1 PTA03500 C PTA03510 230 CALL BRING(IFLA,FILEA,NPTR,NYPT,IGA,IFLA,ITRKA,NRA,IPA,IRA,IIA) PTA03520 KPT=KPT-1 PTA03530 C PTA03540 IF(INTFA(IIA).EQ.IPH) GO TO 234 PTA03550 IF(IPH.EQ.0) GO TO 232 PTA03560 IF(IERR.NE.0) GO TO 232 PTA03570 CALL APUT(IFLD,FILED,NPHR, LPH,1, 1,1, IRD,IID) PTA03580 LPH=LPH+1 PTA03590 IID=IID+2 PTA03600 INTFD(IID)=IPH PTA03610 INTFD(IID+1)=NPT PTA03620 232 IPH=INTFA(IIA) PTA03630 ADD=ADD+PHADD PTA03640 NPT=0 PTA03650 NPH=NPH+1 PTA03660 IF(NPH.GT.LIM) IERR=1 PTA03670 C PTA03680 234 FILEA(IRA+1)=FILEA(IRA+1)+ADD PTA03690 NPT=NPT+1 PTA03700 C PTA03710 IF(KPT.NE.0) GO TO 230 PTA03720 C PTA03730 IF(ITRKA.EQ.NTRK(IFLA)) CALL BPUT(IFLA,ITRKA,FILEA,NPTR) PTA03740 C PTA03750 IF(IERR.NE.0) GO TO 235 PTA03760 CALL APUT(IFLD,FILED,NPHR, LPH,1, 1,1, IRD,IID) PTA03770 LPH=LPH+1 PTA03780 IID=IID+2 PTA03790 INTFD(IID)=IPH PTA03800 INTFD(IID+1)=NPT PTA03810 C PTA03820 235 WRITE(IPR,3501) NPH PTA03830 IF(NPH.GE.2) GO TO 236 PTA03840 WRITE(IPR,5206) PTA03850 CALL ERRSTP(IPR) PTA03860 C PTA03870 236 IF(NPH.LE.MAXPH) GO TO 237 PTA03880 WRITE(IPR,5207) MAXPH PTA03890 CALL ERRSTP(IPR) PTA03900 C PTA03910 237 CALL ACLOSE(IFLD,FILED,NPHR,LPH) PTA03920 C PTA03930 CALL SORTC(IFLA,2,FILEA,FILEB,SUBA,NPTR,NYPT) PTA03940 C PTA03950 C REDUCE POINT DATA ON (FILEA), PRINT REDUCED POINT DATA PTA03960 C PTA03970 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA03980 WRITE(IPR,3300) PTA03990 IF(JOUT.EQ.0) WRITE(IPR,3301) PTA04000 C PTA04010 MPHREC=(NPH-1)/NTPH+1 PTA04020 CALL SETFIL(IFLD,MPHREC,NPHR,1) PTA04030 C PTA04040 NPHERC=(NPH-1)/NTPHE+1 PTA04050 CALL SETFIL(IFLE,NPHERC,NPHRE,1) PTA04060 C PTA04070 IGA=0 PTA04080 IGD=0 PTA04090 KPH=0 PTA04100 NACCPT=0 PTA04110 NACCPH=0 PTA04120 C PTA04130 LPT=0 PTA04140 IRC=1-NYPT PTA04150 IIC=1-IYPT PTA04160 LPH=0 PTA04170 IRE=1-NYPH PTA04180 IIE=1-IYPH PTA04190 C PTA04200 CALL OPEN(IFLC,NPTR,NYPT) PTA04210 CALL OPEN(IFLE,NPHR,NYPH) PTA04220 C PTA04230 240 CALL BRING(IFLD,FILED,NPHR,1,IGD,0,ITRKD,NRD,IPD,IRD,IID) PTA04240 KPH=KPH+1 PTA04250 C PTA04260 KPT=INTFD(IID+1) PTA04270 IPH=INTFD(IID) PTA04280 IF(JOUT.NE.0) WRITE(IPR,3302) IPH PTA04290 C PTA04300 IPT=0 PTA04310 NPT=0 PTA04320 NFID=0 PTA04330 XM=0.0 PTA04340 YM=0.0 PTA04350 PD0=0.0 PTA04360 IERR=0 PTA04370 LERR=0 PTA04380 C PTA04390 IF(IFID.EQ.0) GO TO 250 PTA04400 DO 245 I=1,5 PTA04410 DO 245 J=1,2 PTA04420 IFIDXY(I,J)=0 PTA04430 245 FIDXY(I,J)=0.0 PTA04440 C PTA04450 250 NP=1 PTA04460 ICASE=1 PTA04470 C PTA04480 255 CALL BRING(IFLA,FILEA,NPTR,NYPT,IGA,0,ITRKA,NRA,IPA,IRA,IIA) PTA04490 KPT=KPT-1 PTA04500 C PTA04510 IF(INTFA(IIA+1).NE.IPT) GO TO 275 PTA04520 C PTA04530 IF(JOUT.EQ.0) GO TO 262 PTA04540 IF(NP.NE.1) GO TO 260 PTA04550 C PTA04560 CALL OPEN(IFLB,NPTR,2) PTA04570 JPT=1 PTA04580 IRB=1 PTA04590 IIB=0 PTA04600 FILEB(IRB)=FILEC(IRC+2) PTA04610 FILEB(IRB+1)=FILEC(IRC+3) PTA04620 C PTA04630 260 CALL APUT(IFLB,FILEB,NPTR, JPT,1, 1,0, IRB,IIB) PTA04640 JPT=JPT+1 PTA04650 IRB=IRB+2 PTA04660 FILEB(IRB)=FILEA(IRA+2) PTA04670 FILEB(IRB+1)=FILEA(IRA+3) PTA04680 C PTA04690 262 NP=NP+1 PTA04700 FILEC(IRC+2)=FILEC(IRC+2)+FILEA(IRA+2) PTA04710 FILEC(IRC+3)=FILEC(IRC+3)+FILEA(IRA+3) PTA04720 IF(KPT.NE.0) GO TO 255 PTA04730 ICASE=2 PTA04740 C PTA04750 265 IF(JOUT.NE.0) CALL ACLOSE(IFLB,FILEB,NPTR,JPT) PTA04760 C PTA04770 FILEC(IRC+2)=FILEC(IRC+2)/DFLOAT(NP) PTA04780 FILEC(IRC+3)=FILEC(IRC+3)/DFLOAT(NP) PTA04790 C PTA04800 MFID=0 PTA04810 IF(IFID.NE.0) CALL TESTFD(MFID,IFLOC,IPT,IFCODE,IFDIVL,IFDIVH, PTA04820 * NFDIVL) PTA04830 IF(IPID.NE.0) CALL TESTPD(MFID,IPT,IPCODE,IPDIVL,IPDIVH) PTA04840 C PTA04850 IF(JOUT.EQ.0) GO TO 272 PTA04860 C PTA04870 IGB=0 PTA04880 DO 270 I=1,NP PTA04890 CALL BRING(IFLB,FILEB,NPTR,2,IGB,0,ITRKB,NRB,IPB,IRB,IIB) PTA04900 DX=FILEB(IRB)-FILEC(IRC+2) PTA04910 DY=FILEB(IRB+1)-FILEC(IRC+3) PTA04920 IF(MFID.EQ.0) WRITE(IPR,3305) IPT,FILEB(IRB),FILEB(IRB+1),NP,DX,DYPTA04930 IF(MFID.EQ.1) WRITE(IPR,3306) IPT,FILEB(IRB),FILEB(IRB+1),NP,DX,DYPTA04940 IF(MFID.EQ.2) WRITE(IPR,3313) IPT,FILEB(IRB),NP,DX PTA04950 270 CONTINUE PTA04960 C PTA04970 IF(MFID.EQ.0) WRITE(IPR,3307) IPT,FILEC(IRC+2),FILEC(IRC+3) PTA04980 IF(MFID.EQ.1) WRITE(IPR,3308) IPT,FILEC(IRC+2),FILEC(IRC+3) PTA04990 IF(MFID.EQ.2) WRITE(IPR,3314) IPT,FILEC(IRC+2) PTA05000 272 IF(MFID.EQ.2) WRITE(IPR,5208) IPH PTA05010 GO TO 280 PTA05020 C PTA05030 275 IF(NP.NE.1) GO TO 265 PTA05040 C PTA05050 IF(IPT.NE.0) GO TO 277 PTA05060 IF(LPT.EQ.0) GO TO 284 PTA05070 IF(MFID.EQ.0) GO TO 284 PTA05080 GO TO 285 PTA05090 C PTA05100 277 MFID=0 PTA05110 IF(IFID.NE.0) CALL TESTFD(MFID,IFLOC,IPT,IFCODE,IFDIVL,IFDIVH, PTA05120 * NFDIVL) PTA05130 IF(IPID.NE.0) CALL TESTPD(MFID,IPT,IPCODE,IPDIVL,IPDIVH) PTA05140 C PTA05150 IF(JOUT.EQ.0) GO TO 280 PTA05160 IF(MFID.EQ.0) WRITE(IPR,3303) IPT,FILEC(IRC+2),FILEC(IRC+3) PTA05170 IF(MFID.EQ.1) WRITE(IPR,3304) IPT,FILEC(IRC+2),FILEC(IRC+3) PTA05180 IF(MFID.EQ.2) WRITE(IPR,3315) IPT,FILEC(IRC+2) PTA05190 C PTA05200 280 IF(MFID.EQ.0) GO TO 282 PTA05210 IF(MFID.EQ.1) CALL LISTFD(IPH,IPT,IFLOC,NFID,LERR,FIDXY,IFIDXY, PTA05220 * FILEC,IRC,NPTR) PTA05230 IF(MFID.EQ.2) CALL LISTPD(IPH,IPT,PD0,FILEC(IRC+2),KERR) PTA05240 GO TO (285,300),ICASE PTA05250 C PTA05260 282 NPT=NPT+1 PTA05270 XM=XM+FILEC(IRC+2) PTA05280 YM=YM+FILEC(IRC+3) PTA05290 C PTA05300 IF(ICASE.EQ.2) GO TO 290 PTA05310 C PTA05320 IF(NPT.LE.NTPT) GO TO 284 PTA05330 IF(IERR.NE.0) GO TO 285 PTA05340 WRITE(IPR,5300) IPH,NTPT PTA05350 IERR=1 PTA05360 KERR=1 PTA05370 GO TO 285 PTA05380 C PTA05390 284 CALL APUT(IFLC,FILEC,NPTR, LPT,1, 1,1, IRC,IIC) PTA05400 LPT=LPT+1 PTA05410 IRC=IRC+NYPT PTA05420 IIC=IIC+IYPT PTA05430 C PTA05440 285 IPT=INTFA(IIA+1) PTA05450 INTFC(IIC)=IPH PTA05460 INTFC(IIC+2)=IPT PTA05470 INTFC(IIC+3)=0 PTA05480 FILEC(IRC+2)=FILEA(IRA+2) PTA05490 FILEC(IRC+3)=FILEA(IRA+3) PTA05500 C PTA05510 IF(KPT.NE.0) GO TO 250 PTA05520 C PTA05530 MFID=0 PTA05540 IF(IFID.NE.0) CALL TESTFD(MFID,IFLOC,IPT,IFCODE,IFDIVL,IFDIVH, PTA05550 * NFDIVL) PTA05560 IF(IPID.NE.0) CALL TESTPD(MFID,IPT,IPCODE,IPDIVL,IPDIVH) PTA05570 C PTA05580 IF(JOUT.EQ.0) GO TO 287 PTA05590 IF(MFID.EQ.0) WRITE(IPR,3303) IPT,FILEC(IRC+2),FILEC(IRC+3) PTA05600 IF(MFID.EQ.1) WRITE(IPR,3304) IPT,FILEC(IRC+2),FILEC(IRC+3) PTA05610 IF(MFID.EQ.2) WRITE(IPR,3315) IPT,FILEC(IRC+2) PTA05620 C PTA05630 287 IF(MFID.EQ.0) GO TO 288 PTA05640 IF(MFID.EQ.1) CALL LISTFD(IPH,IPT,IFLOC,NFID,LERR,FIDXY,IFIDXY, PTA05650 * FILEC,IRC,NPTR) PTA05660 IF(MFID.EQ.2) CALL LISTPD(IPH,IPT,PD0,FILEC(IRC+2),KERR) PTA05670 GO TO 300 PTA05680 C PTA05690 288 NPT=NPT+1 PTA05700 XM=XM+FILEC(IRC+2) PTA05710 YM=YM+FILEC(IRC+3) PTA05720 C PTA05730 290 IF(NPT.LE.NTPT) GO TO 300 PTA05740 IF(IERR.NE.0) GO TO 300 PTA05750 WRITE(IPR,5300) IPH,NTPT PTA05760 IERR=1 PTA05770 KERR=1 PTA05780 C PTA05790 300 IF(IFID.EQ.0) GO TO 305 PTA05800 CALL FIDUPT(IPH,NFID,LERR,FIDXY,IFIDXY) PTA05810 IF(LERR.NE.0) GO TO 305 PTA05820 C PTA05830 IFTYPE=IFIDXY(5,1) PTA05840 IF(JOUT.EQ.0) GO TO 310 PTA05850 IF(IFTYPE-4) 301,302,303 PTA05860 301 WRITE(IPR,3309) FIDXY(5,1),FIDXY(5,2) PTA05870 GO TO 310 PTA05880 302 WRITE(IPR,3310) FIDXY(5,1),FIDXY(5,2) PTA05890 GO TO 310 PTA05900 303 WRITE(IPR,3311) FIDXY(5,1),FIDXY(5,2) PTA05910 GO TO 310 PTA05920 C PTA05930 305 IFTYPE=0 PTA05940 IF(NPT.NE.0) GO TO 307 PTA05950 WRITE(IPR,5301) IPH PTA05960 KERR=1 PTA05970 GO TO 310 PTA05980 307 XM=XM/DFLOAT(NPT) PTA05990 YM=YM/DFLOAT(NPT) PTA06000 IF(JOUT.NE.0) WRITE(IPR,3312) XM,YM PTA06010 C PTA06020 310 IF(KERR.NE.0) GO TO 315 PTA06030 C PTA06040 CALL APUT(IFLE,FILEE,NPHR, LPH,1, 1,1, IRE,IIE) PTA06050 LPH=LPH+1 PTA06060 IRE=IRE+NYPH PTA06070 IIE=IIE+IYPH PTA06080 C PTA06090 INTFE(IIE)=IPH PTA06100 INTFE(IIE+1)=NPT PTA06110 INTFE(IIE+2)=NACCPT+1 PTA06120 INTFE(IIE+3)=0 PTA06130 FILEE(IRE+4)=PD PTA06140 IF(PD0.NE.0.0) FILEE(IRE+4)=PD0 PTA06150 IF(IFTYPE.NE.0) GO TO 312 PTA06160 FILEE(IRE+2)=XM PTA06170 FILEE(IRE+3)=YM PTA06180 GO TO 315 PTA06190 312 FILEE(IRE+2)=FIDXY(5,1) PTA06200 FILEE(IRE+3)=FIDXY(5,2) PTA06210 C PTA06220 315 NACCPT=NACCPT+NPT PTA06230 NACCPH=NACCPH+1 PTA06240 C PTA06250 IF(KPH.NE.NPH) GO TO 240 PTA06260 C PTA06270 IF(MFID.NE.0) LPT=LPT-1 PTA06280 CALL ACLOSE(IFLE,FILEE,NPHR,LPH) PTA06290 CALL ACLOSE(IFLC,FILEC,NPTR,LPT) PTA06300 C PTA06310 C INPUT HORIZONTAL CONTROL COORDINATES, STORE ON (FILEF) PTA06320 C PTA06330 WRITE(IPR,3401) PTA06340 C PTA06350 IF(KFMT.EQ.LF) GO TO 340 PTA06360 WRITE(IPR,3412) KFILE PTA06370 GO TO 345 PTA06380 C PTA06390 340 READ(ICD,4) (LFMT(I),I=1,20) PTA06400 IF(KFILE.EQ.ICD) WRITE(IPR,3413) PTA06410 IF(KFILE.NE.ICD) WRITE(IPR,3414) KFILE PTA06420 WRITE(IPR,3415) (LFMT(I),I=1,20) PTA06430 C PTA06440 345 IOUT0=KOUT PTA06450 KOUT=0 PTA06460 IF(IOUT0.EQ.1.OR.IOUT0.EQ.3) KOUT=1 PTA06470 IF(KOUT.EQ.0) WRITE(IPR,3402) PTA06480 IF(KOUT.NE.0) WRITE(IPR,3410) PTA06490 C PTA06500 CALL SETFIL(IFLF, 1, NHOR,1) PTA06510 CALL OPEN(IFLF,NHOR,NYHO) PTA06520 C PTA06530 NPT=0 PTA06540 IERR=0 PTA06550 IHO=0 PTA06560 JHO=0 PTA06570 C PTA06580 350 IF(KFMT.EQ.LF) READ(KFILE,LFMT) IPT,XM,YM,IWT PTA06590 IF(KFMT.EQ.LU) READ(KFILE) IPT,XM,YM,IWT PTA06600 IF(IPT.EQ.-99) GO TO 370 PTA06610 C PTA06620 IF(IWT.EQ.0) IWT=1 PTA06630 IF(KOUT.NE.0) WRITE(IPR,3403) IPT,XM,YM,IWT PTA06640 C PTA06650 IF(IPT.GT.0) GO TO 351 PTA06660 WRITE(IPR,5400) IPT PTA06670 KERR=1 PTA06680 351 IF(IWT.GE.1 .AND. IWT.LE.9) GO TO 352 PTA06690 WRITE(IPR,5407) IWT PTA06700 KERR=1 PTA06710 352 NPT=NPT+1 PTA06720 C PTA06730 IF(JHO.EQ.0) GO TO 360 PTA06740 C PTA06750 DO 355 I=3,JHO,IYHO PTA06760 IF(INTFA(I).NE.IPT) GO TO 355 PTA06770 WRITE(IPR,5401) IPT PTA06780 KERR=1 PTA06790 GO TO 350 PTA06800 355 CONTINUE PTA06810 C PTA06820 360 IF(IHO+NYHO.LE.NHOR) GO TO 365 PTA06830 IF(IERR.NE.0) GO TO 350 PTA06840 WRITE(IPR,5402) NTHO PTA06850 IERR=1 PTA06860 KERR=1 PTA06870 GO TO 350 PTA06880 C PTA06890 365 INTFA(JHO+1)=MAXNR PTA06900 INTFA(JHO+2)=IWT PTA06910 INTFA(JHO+3)=IPT PTA06920 INTFA(JHO+4)=0 PTA06930 FILEA(IHO+3)=XM PTA06940 FILEA(IHO+4)=YM PTA06950 IHO=IHO+NYHO PTA06960 JHO=JHO+IYHO PTA06970 GO TO 350 PTA06980 C PTA06990 370 NREC(IFLF)=IHO/NYHO PTA07000 IF(NREC(IFLF).GE.2) GO TO 400 PTA07010 WRITE(IPR,5404) PTA07020 WRITE(IPR,5405) PTA07030 KERR=1 PTA07040 C PTA07050 C INPUT VERTICAL CONTROL COORDINATES, STORE ON (FILEG) PTA07060 C PTA07070 400 WRITE(IPR,3404) PTA07080 C PTA07090 IF(KFMT.EQ.LF) GO TO 440 PTA07100 WRITE(IPR,3416) KFILE PTA07110 GO TO 445 PTA07120 C PTA07130 440 READ(ICD,4) (LFMT(I),I=1,20) PTA07140 IF(KFILE.EQ.ICD) WRITE(IPR,3417) PTA07150 IF(KFILE.NE.ICD) WRITE(IPR,3418) KFILE PTA07160 WRITE(IPR,3419) (LFMT(I),I=1,20) PTA07170 C PTA07180 445 KOUT=0 PTA07190 IF(IOUT0.GE.2) KOUT=1 PTA07200 IF(KOUT.EQ.0) WRITE(IPR,3405) PTA07210 IF(KOUT.NE.0) WRITE(IPR,3411) PTA07220 C PTA07230 CALL SETFIL(IFLG, 1, NVER,1) PTA07240 CALL OPEN(IFLG,NVER,NYVE) PTA07250 C PTA07260 C PTA07270 MPT=0 PTA07280 IERR=0 PTA07290 IVE=0 PTA07300 JVE=0 PTA07310 C PTA07320 450 IF(KFMT.EQ.LF) READ(KFILE,LFMT) IPT,ZM,IWT PTA07330 IF(KFMT.EQ.LU) READ(KFILE) IPT,ZM,IWT PTA07340 IF(IPT.EQ.-99) GO TO 470 PTA07350 C PTA07360 IF(IWT.EQ.0) IWT=1 PTA07370 IF(KOUT.NE.0) WRITE(IPR,3406) IPT,ZM,IWT PTA07380 C PTA07390 IF(IPT.GT.0) GO TO 451 PTA07400 WRITE(IPR,5400) IPT PTA07410 KERR=1 PTA07420 451 IF(IWT.GE.1 .AND. IWT.LE.9) GO TO 452 PTA07430 WRITE(IPR,5407) IWT PTA07440 KERR=1 PTA07450 452 MPT=MPT+1 PTA07460 C PTA07470 IF(JVE.EQ.0) GO TO 460 PTA07480 C PTA07490 DO 455 I=3,JVE,IYVE PTA07500 IF(INTFB(I).NE.IPT) GO TO 455 PTA07510 WRITE(IPR,5401) IPT PTA07520 KERR=1 PTA07530 GO TO 450 PTA07540 455 CONTINUE PTA07550 C PTA07560 460 IF(IVE+NYVE.LE.NVER) GO TO 465 PTA07570 IF(IERR.EQ.1) GO TO 450 PTA07580 WRITE(IPR,5403) NTVE PTA07590 IERR=1 PTA07600 KERR=1 PTA07610 GO TO 450 PTA07620 C PTA07630 465 INTFB(JVE+1)=MAXNR PTA07640 INTFB(JVE+2)=IWT PTA07650 INTFB(JVE+3)=IPT PTA07660 INTFB(JVE+4)=0 PTA07670 FILEB(IVE+3)=ZM PTA07680 IVE=IVE+NYVE PTA07690 JVE=JVE+IYVE PTA07700 GO TO 450 PTA07710 C PTA07720 470 NREC(IFLG)=IVE/NYVE PTA07730 IF(NREC(IFLG).GE.3) GO TO 475 PTA07740 WRITE(IPR,5404) PTA07750 WRITE(IPR,5406) PTA07760 KERR=1 PTA07770 GO TO 480 PTA07780 C PTA07790 475 IF(KERR.NE.0) GO TO 480 PTA07800 C PTA07810 NTRK(IFLF)=1 PTA07820 NTRK(IFLG)=1 PTA07830 CALL BPUT(IFLF,1,FILEA,NHOR) PTA07840 CALL BPUT(IFLG,1,FILEB,NVER) PTA07850 C PTA07860 C INPUT WEIGHT MATRICES PTA07870 C PTA07880 480 WRITE(IPR,3407) PTA07890 C PTA07900 DO 485 I=1,11 PTA07910 485 WATE(I,5)=0.0 PTA07920 C PTA07930 READ(ICD,6) IWT,P11,P22,P12 PTA07940 C PTA07950 IF(IWT.NE.-99) GO TO 490 PTA07960 WRITE(IPR,5408) PTA07970 KERR=1 PTA07980 GO TO 520 PTA07990 490 WRITE(IPR,3408) P11,P12,P12,P22 PTA08000 DET=P11*P22-P12*P12 PTA08010 IF(DET.NE.0.0) GO TO 492 PTA08020 WRITE(IPR,5411) PTA08030 KERR=1 PTA08040 GO TO 495 PTA08050 492 WATE(10,1)= P11 PTA08060 WATE(10,2)= P22 PTA08070 WATE(10,3)= P12 PTA08080 WATE(11,1)= P22/DET PTA08090 WATE(11,2)= P11/DET PTA08100 WATE(11,3)=-P12/DET PTA08110 C PTA08120 495 NWT=0 PTA08130 Z=0.0 PTA08140 500 READ(ICD,6) IWT,(SUBA(J),J=1,4) PTA08150 IF(IWT.EQ.-99) GO TO 517 PTA08160 WRITE(IPR,3409) IWT,IWT,SUBA(1),SUBA(4),Z,SUBA(4),SUBA(2),Z, PTA08170 * Z,Z,SUBA(3) PTA08180 C PTA08190 IF(IWT.GE.1 .AND. IWT.LE.9) GO TO 505 PTA08200 WRITE(IPR,5407) IWT PTA08210 KERR=1 PTA08220 GO TO 500 PTA08230 C PTA08240 505 IF(WATE(IWT,5).EQ.0.0) GO TO 510 PTA08250 WRITE(IPR,5409) IWT PTA08260 KERR=1 PTA08270 GO TO 500 PTA08280 C PTA08290 510 WATE(IWT,5)=IWT PTA08300 DO 515 J=1,4 PTA08310 515 WATE(IWT,J)=SUBA(J) PTA08320 NWT=NWT+1 PTA08330 GO TO 500 PTA08340 C PTA08350 517 IF(NWT.NE.0) GO TO 520 PTA08360 WRITE(IPR,5410) PTA08370 KERR=1 PTA08380 C PTA08390 520 WRITE(IPR,3500) PTA08400 WRITE(IPR,3501) NACCPH PTA08410 WRITE(IPR,3502) NACCPT PTA08420 WRITE(IPR,3503) NPT PTA08430 WRITE(IPR,3504) MPT PTA08440 C PTA08450 IF(KERR.NE.0) CALL ERRSTP(IPR) PTA08460 C PTA08470 RETURN PTA08480 C PTA08490 1 FORMAT(I10,9X,A1,2I10) PTA08500 2 FORMAT(8I10) PTA08510 3 FORMAT(F20.5) PTA08520 4 FORMAT(20A4) PTA08530 5 FORMAT(I10,17A4,A2) PTA08540 6 FORMAT(I10,4F15.5) PTA08550 C PTA08560 3000 FORMAT(1H1,//, 5X,'UNBASC2-PROGRAM: ',20A4,'(PART-1)',/) PTA08570 C PTA08580 3100 FORMAT(1H0,///,45X,'UNBASC2 VERSION ',A3,//) PTA08590 3101 FORMAT(1H ,27X,'*************************************************'PTA08600 * ,'******') PTA08610 3102 FORMAT(1H ,27X,'**',51X,'**') PTA08620 3103 FORMAT(1H ,27X,'** FORMATTED PHOTO COORDINATES ON PUNCHED CARDS', PTA08630 * 6X,'**') PTA08640 3104 FORMAT(1H ,27X,'** FORMATTED PHOTO COORDINATES ON FILE',I3,12X, PTA08650 * '**') PTA08660 3105 FORMAT(1H ,27X,'** UNFORMATTED PHOTO COORDINATES ON FILE',I3,10X, PTA08670 * '**') PTA08680 3106 FORMAT(1H ,27X,'** FORMATTED CONTROL COORDINATES ON PUNCHED CARDS'PTA08690 * ,4X,'**') PTA08700 3107 FORMAT(1H ,27X,'** FORMATTED CONTROL COORDINATES ON FILE',I3,10X, PTA08710 * '**') PTA08720 3108 FORMAT(1H ,27X,'** UNFORMATTED CONTROL COORDINATES ON FILE',I3,8X,PTA08730 * '**') PTA08740 3110 FORMAT(1H ,27X,'** CODE NO. TO IDENTIFY FIDUCIAL MARKS',6X,'=',I7,PTA08750 * ' **') PTA08760 3111 FORMAT(1H ,27X,'** DIGITS TO LOCATE CODE NO. FOR FIDUCIAL MARKS', PTA08770 * 6X,'**') PTA08780 3112 FORMAT(1H ,27X,'**', 9X,'FROM (RIGHT-JUSTIFIED) DIGIT',I2,' TO DI'PTA08790 * ,'GIT',I2,' **') PTA08800 3113 FORMAT(1H ,27X,'** DIGIT TO LOCATE FIDUCIAL NUMBERS',18X,'**') PTA08810 3114 FORMAT(1H ,27X,'**',14X,'(RIGHT-JUSTIFIED) DIGIT',I2,12X,'**') PTA08820 3116 FORMAT(1H ,27X,'** CODE NO. TO IDENTIFY PRINCIPAL DISTANCES =',I7,PTA08830 * ' **') PTA08840 3117 FORMAT(1H ,27X,'** DIGITS TO LOCATE CODE NO. FOR PRINCIPAL DISTAN'PTA08850 * ,'CES **') PTA08860 3118 FORMAT(1H ,27X,'** INITIAL VALUE OF PRINCIPAL DISTANCE =',F12.5, PTA08870 * ' **') PTA08880 3119 FORMAT(1H ,27X,'** CAPACITY OF PROGRAM VERSION ',A3,':',18X,'**') PTA08890 3120 FORMAT(1H ,27X,'** MAX. NUMBER OF PHOTOGRAPHS.................',I6PTA08900 * ,' **') PTA08910 3121 FORMAT(1H ,27X,'** MAX. NUMBER OF PHOTO POINTS................',I6PTA08920 * ,' **') PTA08930 3122 FORMAT(1H ,27X,'** MAX. NUMBER OF HORIZONTAL CONTROL POINTS...',I6PTA08940 * ,' **') PTA08950 3123 FORMAT(1H ,27X,'** MAX. NUMBER OF VERTICAL CONTROL POINTS.....',I6PTA08960 * ,' **') PTA08970 3124 FORMAT(1H ,27X,'** MAX. NUMBER OF PHOTOS IN ONE PHOTO-GROUP...',I6PTA08980 * ,' **') PTA08990 3125 FORMAT(1H ,27X,'** MAX. NUMBER OF POINTS IN ONE PHOTO.........',I6PTA09000 * ,' **') PTA09010 3126 FORMAT(1H ,27X,'** MAX. NUMBER OF PHOTOS IN ONE COLUMN BAND...',I6PTA09020 * ,' **') PTA09030 C PTA09040 3200 FORMAT(1H0,/, 10X,'READ-IN PHOTO COORDINATES (RAW DATA)',/,10X, PTA09050 * '------------------------------------',/) PTA09060 3201 FORMAT(1H ,//,10X,'NO PRINTOUT OF READ-IN PHOTO COORDINATES',//) PTA09070 3202 FORMAT(1H ,I15,I10,2F13.5,I15,I10,2F13.5) PTA09080 3203 FORMAT(1H ,I15,'X', I9,'X',F12.5,'X',F12.5,'X', PTA09090 * I14,'X', I9,'X',F12.5,'X',F12.5,'X') PTA09100 3204 FORMAT(1H ,I15,I10,2F13.5,I15,'X', I9,'X',F12.5,'X',F12.5,'X') PTA09110 3205 FORMAT(1H ,I15,'X', I9,'X',F12.5,'X',F12.5,'X',I15,I10,2F13.5) PTA09120 3206 FORMAT(1H0, 9X,'NUMBER OF PHOTO POINTS ENTERED...............',I6)PTA09130 3207 FORMAT(1H0,I10,' SET OF FORMATTED PHOTO COORDINATES PER CARD') PTA09140 3208 FORMAT(1H0,I10,' SETS OF FORMATTED PHOTO COORDINATES PER CARD') PTA09150 3209 FORMAT(1H0,I10,' SET OF FORMATTED PHOTO COORDINATES PER RECORD ON'PTA09160 * ,' FILE',I3) PTA09170 3210 FORMAT(1H0,I10,' SETS OF FORMATTED PHOTO COORDINATES PER RECORD O'PTA09180 * ,'N FILE',I3) PTA09190 3211 FORMAT(1H0,I10,' SET OF UNFORMATTED PHOTO COORDINATES PER RECORD' PTA09200 * ,' ON FILE',I3) PTA09210 3212 FORMAT(1H0,I10,' SETS OF UNFORMATTED PHOTO COORDINATES PER RECORD'PTA09220 * ,' ON FILE',I3) PTA09230 3213 FORMAT(1H0,/,10X,'(PHOTO)',3X,'(POINT)',7X,'(X)',10X,'(Y)',/) PTA09240 3214 FORMAT(1H0,/,10X,'(PHOTO)',3X,'(POINT)',7X,'(X)',10X,'(Y)',11X, PTA09250 * '(PHOTO)',3X,'(POINT)',7X,'(X)',10X,'(Y)',/) PTA09260 3215 FORMAT(1H0, 9X,'FORMAT FOR PHOTO COORDINATES: ',17A4,A2) PTA09270 C PTA09280 3300 FORMAT(1H0,/,10X,'SORTED PHOTO COORDINATES',/,10X,'--------------'PTA09290 * ,'----------',/) PTA09300 3301 FORMAT(1H ,/ ,10X,'NO PRINTOUT OF SORTED PHOTO COORDINATES',//) PTA09310 3302 FORMAT(1H0,/,10X,'PHOTO NUMBER',I10,/,10X,'----------------------'PTA09320 * ,//,10X,'(POINT NUMBER)',7X,'(X)',12X,'(Y)',18X,'(DX)',11X, PTA09330 * '(DY)',/) PTA09340 3303 FORMAT(1H ,I18,F17.5,F15.5) PTA09350 3304 FORMAT(1H ,I18,' (F)',F13.5,F15.5) PTA09360 3305 FORMAT(1H ,I18,'* ',F13.5,F15.5,I6,2F15.5) PTA09370 3306 FORMAT(1H ,I18,'*(F)',F13.5,F15.5,I6,2F15.5) PTA09380 3307 FORMAT(1H ,I18,F17.5,F15.5,2X,'MEAN') PTA09390 3308 FORMAT(1H ,I18,' (F)',F13.5,F15.5,2X,'MEAN') PTA09400 3309 FORMAT(1H ,14X,'P.P.',F17.5,F15.5,2X,'(FOOT POINT COORDINATES)') PTA09410 3310 FORMAT(1H ,14X,'P.P.',F17.5,F15.5,2X,'(INTERSECTED POINT COORDINA'PTA09420 * ,'TES)') PTA09430 3311 FORMAT(1H ,14X,'P.P.',F17.5,F15.5,2X,'(READ-IN COORDINATES)') PTA09440 3312 FORMAT(1H ,14X,'P.P.',F17.5,F15.5,2X,'(DEFAULT GRAVITY-CENTER COO'PTA09450 * ,'RDINATES)') PTA09460 3313 FORMAT(1H ,I18,'*(P)',F13.5,I21,F15.5) PTA09470 3314 FORMAT(1H ,I18,' (P)',F13.5,17X,'(MEAN READ-IN PRINCIPAL DISTANCE'PTA09480 * ,')') PTA09490 3315 FORMAT(1H ,I18,' (P)',F13.5,17X,'(READ-IN PRINCIPAL DISTANCE)') PTA09500 C PTA09510 3401 FORMAT(1H0,//,10X,'READ-IN HORIZONTAL CONTROL COORDINATES',/,10X, PTA09520 * '--------------------------------------') PTA09530 3402 FORMAT(1H ,//,10X,'NO PRINTOUT OF READ-IN HORIZONTAL CONTROL COOR'PTA09540 * ,'DINATES',//) PTA09550 3403 FORMAT(1H ,I18,F17.5,F15.5,I12) PTA09560 3404 FORMAT(1H0,//,10X,'READ-IN VERTICAL CONTROL COORDINATES',/,10X, PTA09570 * '------------------------------------') PTA09580 3405 FORMAT(1H ,//,10X,'NO PRINTOUT OF READ-IN VERTICAL CONTROL COORDI'PTA09590 * ,'NATES',//) PTA09600 3406 FORMAT(1H ,I18,17X,F15.5,I12) PTA09610 3407 FORMAT(1H0,//,10X,'READ-IN WEIGHT MATRICES',/,10X,'--------------'PTA09620 * ,'---------',///,10X,'WEIGHT MATRIX (PIMG) FOR IMAGE POINTS'PTA09630 * ,/,10X,'-------------------------------------') PTA09640 3408 FORMAT(1H ,/,( 6X,2F20.6)) PTA09650 3409 FORMAT(1H ,//,I11,'. WEIGHT MATRIX (PCTL NO.',I1,') FOR CONTROL P'PTA09660 * ,'OINTS',/,13X,'--------------------------------------------'PTA09670 * ,//,( 6X,3F20.6)) PTA09680 3410 FORMAT(1H0, 9X,'(POINT NUMBER)',7X,'(X)',12X,'(Y)',6X,'(WEIGHT IN'PTA09690 * ,'DEX)',/) PTA09700 3411 FORMAT(1H0, 9X,'(POINT NUMBER)',22X,'(Z)',6X,'(WEIGHT INDEX)',/) PTA09710 3412 FORMAT(1H0, 9X,'UNFORMATTED HORIZONTAL CONTROL COORDINATES ON FIL'PTA09720 * ,'E',I3) PTA09730 3413 FORMAT(1H0, 9X,'FORMATTED HORIZONTAL CONTROL COORDINATES ON CARDS'PTA09740 * )PTA09750 3414 FORMAT(1H0, 9X,'FORMATTED HORIZONTAL CONTROL COORDINATES ON FILE',PTA09760 * I3) PTA09770 3415 FORMAT(1H0, 9X,'FORMAT FOR HORIZONTAL CONTROL COORDINATES: ',20A4)PTA09780 3416 FORMAT(1H0, 9X,'UNFORMATTED VERTICAL CONTROL COORDINATES ON FILE',PTA09790 * I3) PTA09800 3417 FORMAT(1H0, 9X,'FORMATTED VERTICAL CONTROL COORDINATES ON CARDS') PTA09810 3418 FORMAT(1H0, 9X,'FORMATTED VERTICAL CONTROL COORDINATES ON FILE',I3PTA09820 * )PTA09830 3419 FORMAT(1H0, 9X,'FORMAT FOR VERTICAL CONTROL COORDINATES: ',20A4) PTA09840 C PTA09850 3500 FORMAT(1H0,//,10X,'STATISTICS',/,10X,'----------') PTA09860 3501 FORMAT(1H0, 9X,'NUMBER OF PHOTOGRAPHS ENTERED................',I6)PTA09870 3502 FORMAT(1H0, 9X,'NUMBER OF IMAGE POINTS ENTERED...............',I6)PTA09880 3503 FORMAT(1H0, 9X,'NUMBER OF HORIZONTAL CONTROL POINTS ENTERED..',I6)PTA09890 3504 FORMAT(1H0, 9X,'NUMBER OF VERTICAL CONTROL POINTS ENTERED....',I6)PTA09900 C PTA09910 5000 FORMAT(1H0,///,10X,'PROGRAM UNBASC2 IS NOT RELEASED TO UNAUTHORIZ'PTA09920 * ,'ED USERS') PTA09930 5001 FORMAT(1H , 9X,'***(ERROR)*** INVALID READ-IN IFILE (',I10,')') PTA09940 5002 FORMAT(1H , 9X,'***(ERROR)*** READ-IN IFMT (',A1,') MUST BE EITHE'PTA09950 * ,'R F OR U') PTA09960 5003 FORMAT(1H , 9X,'***(ERROR)*** READ-IN IFNDGT (',I10,') MUST BE AN'PTA09970 * ,' INTEGER BETWEEN 1 AND',I3) PTA09980 5004 FORMAT(1H0, 9X,'***(ERROR)*** READ-IN IFNDGT (',I10,') MUST BE AN'PTA09990 * ,' INTEGER OTHER THAN',I3) PTA10000 5005 FORMAT(1H0, 9X,'***(ERROR)*** READ-IN IFNDGT (',I10,') MAY NOT BE'PTA10010 * ,' IN THE RANGE (',I3,',',I3,')') PTA10020 5006 FORMAT(1H , 9X,'***(ERROR)*** IFCODE AND IPCODE HAVE THE SAME COD'PTA10030 * ,'E (',I10,')') PTA10040 5007 FORMAT(1H , 9X,'***(ERROR)*** INVALID READ-IN KFILE (',I10,')') PTA10050 5008 FORMAT(1H , 9X,'***(ERROR)*** READ-IN KFMT (',A1,') MUST BE EITHE'PTA10060 * ,'R F OR U') PTA10070 5009 FORMAT(1H0, 9X,'***(ERROR)*** READ-IN PD (INITIAL VALUE OF PRINCI'PTA10080 * ,'PAL DISTANCE) MAY NOT BE ZERO') PTA10090 C PTA10100 5101 FORMAT(1H , 9X,'***(ERROR)*** READ-IN ISET (',I10,') MUST BE EIT',PTA10110 * 'HER 1 OR 2') PTA10120 5102 FORMAT(1H , 9X,'***(ERROR)*** READ-IN IFILE (',I2,') IS A RESERVE'PTA10130 * ,'D FILE NUMBER') PTA10140 5103 FORMAT(1H , 9X,'***(ERROR)*** READ-IN KFILE (',I2,') IS A RESERVE'PTA10150 * ,'D FILE NUMBER') PTA10160 C PTA10170 5201 FORMAT(1H , 9X,'***(ERROR)*** NEGATIVE PHOTO NUMBER (',I10,') IS 'PTA10180 * ,'NOT ALLOWED') PTA10190 5202 FORMAT(1H , 9X,'***(ERROR)*** POINT NUMBER (',I10,') MUST BE NON-'PTA10200 * ,'ZERO POSITIVE IN PHOTO',I10) PTA10210 5203 FORMAT(1H , 9X,'***(ERROR)*** POINT NUMBER (',I10,') MUST BE NON-'PTA10220 * ,'ZERO POSITIVE IN PHOTOS',I10,' AND',I10) PTA10230 5204 FORMAT(1H , 9X,'***(ERROR)*** OVER FLOW - MAXIMUM NUMBER OF PHOTO'PTA10240 * ,' POINTS IN THE BLOCK =',I6) PTA10250 5205 FORMAT(1H0, 9X,'***(ERROR)*** INSUFFICIENT NUMBER OF POINTS') PTA10260 5206 FORMAT(1H0, 9X,'***(ERROR)*** INSUFFICIENT NUMBER OF PHOTOS') PTA10270 5207 FORMAT(1H0, 9X,'***(ERROR)*** OVER FLOW - MAXIMUM NUMBER OF PHOTO'PTA10280 * ,'S IN THE BLOCK =',I6) PTA10290 5208 FORMAT(1H , 9X,'***(WARNING)*** READ-IN PRINCIPAL DISTANCE APPEAR'PTA10300 * ,'S TWICE OR MORE IN PHOTO',I10) PTA10310 C PTA10320 5300 FORMAT(1H , 9X,'***(ERROR)*** PHOTO',I10,' OVER FLOW - MAXIMUM N'PTA10330 * ,'UMBER OF IMAGE POINTS IN ONE PHOTO =',I6) PTA10340 5301 FORMAT(1H0, 9X,'***(ERROR)*** PHOTO',I10,' HAS NO IMAGE POINTS') PTA10350 C PTA10360 5400 FORMAT(1H , 9X,'***(ERROR)*** POINT NUMBER (',I10,') MUST BE NON-'PTA10370 * ,'ZERO POSITIVE') PTA10380 5401 FORMAT(1H , 9X,'***(ERROR)*** DUPLICATE POINT NUMBER (',I10,') IS'PTA10390 * ,' NOT ALLOWED IN HORIZONTAL/VERTICAL CONTROL LIST') PTA10400 5402 FORMAT(1H , 9X,'***(ERROR)*** OVER FLOW - MAXIMUM NUMBER OF HORIZ'PTA10410 * ,'ONTAL CONTROL POINTS =',I6) PTA10420 5403 FORMAT(1H , 9X,'***(ERROR)*** OVER FLOW - MAXIMUM NUMBER OF VERTI'PTA10430 * ,'CAL CONTROL POINTS =',I6) PTA10440 5404 FORMAT(1H0, 9X,'***(ERROR)*** INSUFFICIENT NUMBER OF CONTROL POI',PTA10450 * 'NTS') PTA10460 5405 FORMAT(1H ,23X,'MINIMUM 2 HORIZONTAL CONTROL POINTS ARE REQUIRED')PTA10470 5406 FORMAT(1H ,23X,'MINIMUM 3 VERTICAL CONTROL POINTS ARE REQUIRED') PTA10480 5407 FORMAT(1H0, 9X,'***(ERROR)*** WEIGHT INDEX (',I10,') MUST BE AN I'PTA10490 * ,'NTEGER BETWEEN 1 AND 9') PTA10500 5408 FORMAT(1H0, 9X,'***(ERROR)*** WEIGHT MATRIX (PIMG) FOR IMAGE POIN'PTA10510 * ,'TS IS MISSING') PTA10520 5409 FORMAT(1H0, 9X,'***(ERROR)*** WEIGHT MATRIX (PCTL NO.',I1,') WAS 'PTA10530 * ,'ALREADY ENTERED') PTA10540 5410 FORMAT(1H0, 9X,'***(ERROR)*** NO VALID WEIGHT MATRICES EXIST') PTA10550 5411 FORMAT(1H0, 9X,'***(ERROR)*** WEIGHT MATRIX (PIMG) IS SINGULAR') PTA10560 C PTA10570 END PTA10580 SUBROUTINE LINKPH(FILEA,FILEB,FILEC,FILED,FILEE,INTFA,INTFB,INTFC,PTA00010 * INTFD,INTFE,NPTDIM,IPTDIM,NPHDIM,IPHDIM) PTA00020 IMPLICIT REAL*8(A-H,O-Z) PTA00030 C PTA00040 DIMENSION FILEA(NPTDIM),FILEB(NPTDIM),FILEC(NPTDIM),FILED(NPHDIM),PTA00050 * FILEE(NPHDIM),INTFA(IPTDIM),INTFB(IPTDIM),INTFC(IPTDIM),PTA00060 * INTFD(IPHDIM),INTFE(IPHDIM) PTA00070 C PTA00080 DIMENSION GRV(3),SUBA(04),ISUBC(08),IPHG(4) PTA00090 COMMON /BLOCKA/WATE(11,5) PTA00100 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00110 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00120 COMMON /DISK02/MAXTRK,MXBAND PTA00130 C PTA00140 EQUIVALENCE (SUBA(1),ISUBC(1)) PTA00150 C PTA00160 EQUIVALENCE (IAUX(23),INTDGT),(IAUX(24), NYPT),(IAUX(25), NYPH) PTA00170 * ,(IAUX(26), NYHO),(IAUX(27), NYVE),(IAUX(28), IYPT) PTA00180 * ,(IAUX(29), IYPH),(IAUX(31),NACCPT),(IAUX(32),NACCPH) PTA00190 * ,(IAUX(33),MPTREC),(IAUX(36), NPTU),(IAUX(37),GRV(1)) PTA00200 * ,(IAUX(43), NYPHI),(IAUX(50),MAXROW) PTA00210 C PTA00220 DATA IFLA,IFLB,IFLC,IFLD,IFLE,IFLF,IFLG,IFLH,IFLI/1,2,3,4,5,6PTA00230 * ,7,8,9/ PTA00240 C PTA00250 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA00260 WRITE(IPR,3003) PTA00270 C PTA00280 C SET UP FILE DIMENSION PTA00290 C PTA00300 CALL SETDIM(NPTDIM,NYPT, NPTR,NTPT,IPTR,IYPT) PTA00310 CALL SETDIM(NPHDIM,NYPH, NPHR,NTPH,IPHR,IYPH) PTA00320 CALL SETDIM(NPTDIM,NYHO, NHOR,NTHO,IHOR,IYHO) PTA00330 CALL SETDIM(NPTDIM,NYVE, NVER,NTVE,IVER,IYVE) PTA00340 C PTA00350 C PHOTO CONNECTION PTA00360 C PTA00370 CALL OPEN(IFLA,NPTR,NYPT) PTA00380 CALL OPEN(IFLD,NPHR,NYPH) PTA00390 C PTA00400 IPG=1 PTA00410 NPH=0 PTA00420 IACCE=0 PTA00430 KERR=0 PTA00440 MAXNR=10**INTDGT PTA00450 C PTA00460 C READ-IN PHOTO NUMBERS IN 1ST GROUP PTA00470 C PTA00480 READ(ICD,1) MPH PTA00490 WRITE(IPR,3004) MPH PTA00500 C PTA00510 IF(MPH.GE.1.AND.MPH.LE.NTPH) GO TO 102 PTA00520 WRITE(IPR,5001) MPH,NTPH PTA00530 CALL ERRSTP(IPR) PTA00540 C PTA00550 102 READ(ICD,1) (IPHG(I),I=1,4) PTA00560 C PTA00570 DO 105 I=1,4 PTA00580 IF(IPHG(I).EQ.0) GO TO 105 PTA00590 NPH=NPH+1 PTA00600 INTFD(NPH)=IPHG(I) PTA00610 IF(NPH.EQ.MPH) GO TO 110 PTA00620 105 CONTINUE PTA00630 GO TO 102 PTA00640 C PTA00650 110 IF(NPH.LE.5) WRITE(IPR,3005) (INTFD(I),I=1,NPH) PTA00660 IF(NPH.GE.6) WRITE(IPR,3006) (INTFD(I),I=1,NPH) PTA00670 C PTA00680 IERR=0 PTA00690 DO 115 I=1,NPH PTA00700 IF(INTFD(I).GT.0) GO TO 112 PTA00710 IF(IERR.EQ.0) WRITE(IPR,2) PTA00720 WRITE(IPR,5002) INTFD(I) PTA00730 IERR=1 PTA00740 112 IF(I.EQ.NPH) GO TO 115 PTA00750 K=I+1 PTA00760 DO 113 J=K,NPH PTA00770 IF(INTFD(I).NE.INTFD(J)) GO TO 113 PTA00780 IF(IERR.EQ.0) WRITE(IPR,2) PTA00790 WRITE(IPR,5003) INTFD(I) PTA00800 IERR=1 PTA00810 113 CONTINUE PTA00820 115 CONTINUE PTA00830 C PTA00840 IF(IERR.NE.0) CALL ERRSTP(IPR) PTA00850 C PTA00860 CALL SORTB(INTFD,IACCE+1,NPH,1,ISUBC,IPHR,1) PTA00870 CALL SHIFT(INTFD,IACCE,NPH,IPG,IPHR) PTA00880 ITRKE=0 PTA00890 K=1 PTA00900 IRD=-NYPH PTA00910 IID=1-IYPH PTA00920 C PTA00930 DO 140 I=1,NPH PTA00940 IRD=IRD+NYPH PTA00950 IID=IID+IYPH PTA00960 DO 120 J=K,NACCPH PTA00970 CALL LOCATE(IFLE,FILEE,NPHR,NTPH,NYPH,0,J,ITRKE,IRE,IIE) PTA00980 IF(INTFD(IID).EQ.INTFE(IIE)) GO TO 125 PTA00990 120 CONTINUE PTA01000 IF(IERR.EQ.0) WRITE(IPR,2) PTA01010 WRITE(IPR,5004) INTFD(IID) PTA01020 IERR=1 PTA01030 GO TO 140 PTA01040 125 DO 130 L=1,NYPH PTA01050 130 FILED(IRD+L)=FILEE(IRE+L-1) PTA01060 INTFD(IID+3)=NPH PTA01070 K=J+1 PTA01080 IF(K.GT.NACCPH) K=NACCPH PTA01090 140 CONTINUE PTA01100 C PTA01110 IF(IERR.NE.0) CALL ERRSTP(IPR) PTA01120 C PTA01130 NEND=NPH*IYPH PTA01140 WRITE(IPR,2) PTA01150 IF(NPH.LE.6) WRITE(IPR,3001) NPH,IPG,(INTFD(I),I=1,NEND,IYPH) PTA01160 IF(NPH.GE.7) WRITE(IPR,3002) NPH,IPG,(INTFD(I),I=1,NEND,IYPH) PTA01170 C PTA01180 C PHOTO CONNECTION FOR 2ND, 3RD, --- GROUPS PTA01190 C PTA01200 KPH=0 PTA01210 NOWTRK=0 PTA01220 NTRKC=NTRK(IFLC) PTA01230 NTRKE=NTRK(IFLE) PTA01240 IF(NTRKC.EQ.0) NIB=NREC(IFLC)*IYPT PTA01250 ISGN=-1 PTA01260 IPLOC=0 PTA01270 IRMV=0 PTA01280 IACCPT=0 PTA01290 C PTA01300 200 MPH=0 PTA01310 IADD=NPH*IYPH PTA01320 NES=IACCE+1 PTA01330 NIE=NES+IADD-1 PTA01340 IP=NES-IYPH PTA01350 KRMV=0 PTA01360 IF(NTRKE.EQ.0) GO TO 201 PTA01370 ISGN=-ISGN PTA01380 IGO=2 PTA01390 GO TO 202 PTA01400 201 IACCE=IACCE+IADD PTA01410 IGO=3 PTA01420 202 IF(ISGN.GT.0) IGO=1 PTA01430 C PTA01440 DO 500 IPH=1,NPH PTA01450 C PTA01460 IP=IP+IYPH PTA01470 C PTA01480 IF(NTRKE.EQ.0 .OR. ISGN.GT.0) GO TO 205 PTA01490 IPHNO=INTFE(IP) PTA01500 NRA=INTFE(IP+1) PTA01510 NS=INTFE(IP+2) PTA01520 GO TO 210 PTA01530 C PTA01540 205 IPHNO=INTFD(IP) PTA01550 NRA=INTFD(IP+1) PTA01560 NS=INTFD(IP+2) PTA01570 C PTA01580 210 IF(NTRKC.EQ.0) GO TO 400 PTA01590 C PTA01600 NIA=NRA*IYPT PTA01610 C PTA01620 CALL SEARCH(IFLC,FILEC,NS,NRA, FILEA,NPTR,NYPT,NOWTRK) PTA01630 CALL LINKA(INTFA,IPTR,1,NIA,IPLOC,-1) PTA01640 C PTA01650 GO TO (300,310,320),IGO PTA01660 C PTA01670 300 DO 306 ITRK=1,NTRKC PTA01680 CALL BGET(IFLC,ITRK,FILEB,NPTR,NRB) PTA01690 NIB=NRB*IYPT PTA01700 ICHNG=0 PTA01710 DO 305 IB=1,NIB,IYPT PTA01720 CALL LINKB(INTFD,INTFB,INTFC,IPHR,IPTR,IB,NES,NIE,NOWTRK,ITRK, PTA01730 * ICHNG) PTA01740 305 CALL LINKC(INTFE,INTFA,INTFB,INTFC,IPHR,IPTR,01,NIA,IB,IACCE,MPH, PTA01750 * IPG,NOWTRK,ITRK,ICHNG)PTA01760 IF(ICHNG.EQ.1) CALL BPUT(IFLC,ITRK,FILEB,NPTR) PTA01770 306 CONTINUE PTA01780 GO TO 330 PTA01790 C PTA01800 310 DO 316 ITRK=1,NTRKC PTA01810 CALL BGET(IFLC,ITRK,FILEB,NPTR,NRB) PTA01820 NIB=NRB*IYPT PTA01830 ICHNG=0 PTA01840 DO 315 IB=1,NIB,IYPT PTA01850 CALL LINKB(INTFE,INTFB,INTFC,IPHR,IPTR,IB,NES,NIE,NOWTRK,ITRK, PTA01860 * ICHNG) PTA01870 315 CALL LINKC(INTFD,INTFA,INTFB,INTFC,IPHR,IPTR,01,NIA,IB,IACCE,MPH, PTA01880 * IPG,NOWTRK,ITRK,ICHNG)PTA01890 IF(ICHNG.EQ.1) CALL BPUT(IFLC,ITRK,FILEB,NPTR) PTA01900 316 CONTINUE PTA01910 GO TO 330 PTA01920 C PTA01930 320 DO 326 ITRK=1,NTRKC PTA01940 CALL BGET(IFLC,ITRK,FILEB,NPTR,NRB) PTA01950 NIB=NRB*IYPT PTA01960 ICHNG=0 PTA01970 DO 325 IB=1,NIB,IYPT PTA01980 CALL LINKB(INTFD,INTFB,INTFC,IPHR,IPTR,IB,NES,NIE,NOWTRK,ITRK, PTA01990 * ICHNG) PTA02000 325 CALL LINKC(INTFD,INTFA,INTFB,INTFC,IPHR,IPTR,01,NIA,IB,IACCE,MPH, PTA02010 * IPG,NOWTRK,ITRK,ICHNG)PTA02020 IF(ICHNG.EQ.1) CALL BPUT(IFLC,ITRK,FILEB,NPTR) PTA02030 326 CONTINUE PTA02040 C PTA02050 330 JRMV=0 PTA02060 KPH=KPH+1 PTA02070 DO 350 IA=1,NIA,IYPT PTA02080 INTFA(IA+1)=KPH PTA02090 IF(INTFA(IA+3).GE.2) GO TO 350 PTA02100 IF(KRMV.EQ.0) WRITE(IPR,2) PTA02110 WRITE(IPR,5005) INTFA(IA+2),IPHNO PTA02120 INTFA(IA)=-MAXNR PTA02130 JRMV=JRMV+1 PTA02140 KRMV=1 PTA02150 350 CONTINUE PTA02160 C PTA02170 CALL SORTB2(FILEA,INTFA,1,NRA,1,SUBA,NPTR,IPTR,NYPT,IYPT) PTA02180 C PTA02190 NRA=NRA-JRMV PTA02200 IRMV=IRMV+JRMV PTA02210 C PTA02220 IF(NRA.NE.0) GO TO 355 PTA02230 WRITE(IPR,5006) IPHNO PTA02240 KERR=1 PTA02250 GO TO 490 PTA02260 C PTA02270 355 CALL DPUT(IFLA,FILEA,FILEB,NRA,NPTR) PTA02280 GO TO 490 PTA02290 C PTA02300 400 NN=(NS-1)*IYPT+1 PTA02310 NIA=(NS+NRA-1)*IYPT PTA02320 C PTA02330 CALL LINKA(INTFC,IPTR,NN,NIA,IPLOC,-1) PTA02340 C PTA02350 GO TO (405,410,420),IGO PTA02360 C PTA02370 405 DO 406 IB=1,NIB,IYPT PTA02380 CALL LINKBI(INTFD,INTFC,IPHR,IPTR,IB,NES,NIE) PTA02390 406 CALL LINKCI(INTFE,INTFC,IPHR,IPTR,NN,NIA,IB,IACCE,MPH,IPG) PTA02400 GO TO 430 PTA02410 C PTA02420 410 DO 415 IB=1,NIB,IYPT PTA02430 CALL LINKBI(INTFE,INTFC,IPHR,IPTR,IB,NES,NIE) PTA02440 415 CALL LINKCI(INTFD,INTFC,IPHR,IPTR,NN,NIA,IB,IACCE,MPH,IPG) PTA02450 GO TO 430 PTA02460 C PTA02470 420 DO 425 IB=1,NIB,IYPT PTA02480 CALL LINKBI(INTFD,INTFC,IPHR,IPTR,IB,NES,NIE) PTA02490 425 CALL LINKCI(INTFD,INTFC,IPHR,IPTR,NN,NIA,IB,IACCE,MPH,IPG) PTA02500 C PTA02510 430 JRMV=0 PTA02520 KPH=KPH+1 PTA02530 DO 450 IA=NN,NIA,IYPT PTA02540 INTFC(IA+1)=KPH PTA02550 IF(INTFC(IA+3).GE.2) GO TO 450 PTA02560 IF(KRMV.EQ.0) WRITE(IPR,2) PTA02570 WRITE(IPR,5005) INTFC(IA+2),IPHNO PTA02580 INTFC(IA)=-MAXNR PTA02590 JRMV=JRMV+1 PTA02600 KRMV=1 PTA02610 450 CONTINUE PTA02620 C PTA02630 CALL SORTB2(FILEC,INTFC,NN,NRA,1,SUBA,NPTR,IPTR,NYPT,IYPT) PTA02640 C PTA02650 NRA=NRA-JRMV PTA02660 IRMV=IRMV+JRMV PTA02670 C PTA02680 IF(NRA.NE.0) GO TO 460 PTA02690 WRITE(IPR,5006) IPHNO PTA02700 KERR=1 PTA02710 GO TO 490 PTA02720 C PTA02730 460 NIA=NRA*NYPT PTA02740 NA=(NS-1)*NYPT PTA02750 K=NREC(IFLA) PTA02760 DO 465 IA=1,NIA PTA02770 465 FILEA(K+IA)=FILEC(NA+IA) PTA02780 NREC(IFLA)=NREC(IFLA)+NIA PTA02790 C PTA02800 490 IF(NTRKE.EQ.0 .OR. ISGN.GT.0) GO TO 495 PTA02810 INTFE(IP+1)=NRA PTA02820 INTFE(IP+2)=IACCPT+1 PTA02830 GO TO 496 PTA02840 C PTA02850 495 INTFD(IP+1)=NRA PTA02860 INTFD(IP+2)=IACCPT+1 PTA02870 496 IACCPT=IACCPT+NRA PTA02880 C PTA02890 500 CONTINUE PTA02900 C PTA02910 IF(NTRKE.EQ.0) GO TO 505 PTA02920 IF(ISGN.GT.0) CALL DPUT(IFLD,FILED,FILEB,NPH,NPHR) PTA02930 IF(ISGN.LT.0) CALL DPUT(IFLD,FILEE,FILEB,NPH,NPHR) PTA02940 C PTA02950 505 IF(IACCPT+IRMV.GE.NACCPT) GO TO 550 PTA02960 C PTA02970 IPG=IPG+1 PTA02980 NPH=MPH PTA02990 C PTA03000 IF(ISGN.LT.0) GO TO 510 PTA03010 C PTA03020 CALL SORTB(INTFE,IACCE+1,MPH,1,ISUBC,IPHR,1) PTA03030 CALL SHIFT(INTFE,IACCE,MPH,IPG,IPHR) PTA03040 CALL FINDPH(IFLE, FILED,INTFD,FILEE,INTFE,IACCE,MPH,NPHR,IPHR) PTA03050 GO TO 520 PTA03060 C PTA03070 510 CALL SORTB(INTFD,IACCE+1,MPH,1,ISUBC,IPHR,1) PTA03080 CALL SHIFT(INTFD,IACCE,MPH,IPG,IPHR) PTA03090 CALL FINDPH(IFLE, FILEE,INTFE,FILED,INTFD,IACCE,MPH,NPHR,IPHR) PTA03100 C PTA03110 520 IF(MPH.LE.NTPH) GO TO 200 PTA03120 C PTA03130 WRITE(IPR,5007) NTPH PTA03140 KERR=1 PTA03150 GO TO 200 PTA03160 C PTA03170 550 IF(KERR.NE.0) CALL ERRSTP(IPR) PTA03180 C PTA03190 NPG=IPG PTA03200 NACCPT=IACCPT PTA03210 IF(NTRKE.EQ.0) NREC(IFLD)=IACCE/IYPH PTA03220 IF(NTRKE.NE.0) CALL DCLOSE(IFLD) PTA03230 IF(NTRKC.NE.0) GO TO 560 PTA03240 NREC(IFLA)=NREC(IFLA)/NYPT PTA03250 GO TO 590 PTA03260 560 CALL DCLOSE(IFLA) PTA03270 IF(NACCPT.GT.NTPT) GO TO 590 PTA03280 CALL BGET(IFLA,1,FILEA,NPTR,NRA) PTA03290 NTRK(IFLA)=0 PTA03300 NREC(IFLA)=NRA PTA03310 C PTA03320 590 IF(IRMV.EQ.0) GO TO 700 PTA03330 C PTA03340 C RENUMBER POINT ADDRESS IF IRMV IS NOT ZERO PTA03350 C PTA03360 NPH=0 PTA03370 IGD=0 PTA03380 IPLOC=0 PTA03390 NOWTRK=0 PTA03400 NTRKA=NTRK(IFLA) PTA03410 IF(NTRKA.EQ.0) NIB=NREC(IFLA)*IYPT PTA03420 C PTA03430 600 CALL BRING(IFLD,FILED,NPHR,NYPH,IGD,0,ITRKD,NRD,IPD,IRD,IID) PTA03440 C PTA03450 NPH=NPH+1 PTA03460 NRA=INTFD(IID+1) PTA03470 NS=INTFD(IID+2) PTA03480 C PTA03490 IF(NTRKA.EQ.0) GO TO 650 PTA03500 C PTA03510 ITRK=(NS-1)/NTPT+1 PTA03520 IF(ITRK.EQ.NOWTRK) GO TO 605 PTA03530 IF(NOWTRK.NE.0) CALL BPUT(IFLA,NOWTRK,FILEA,NPTR) PTA03540 CALL BGET(IFLA,ITRK,FILEA,NPTR,NRTA) PTA03550 NOWTRK=ITRK PTA03560 C PTA03570 605 IS=NS-(ITRK-1)*NTPT PTA03580 IE=IS+NRA-1 PTA03590 LEFT=IE-NRTA PTA03600 IF(LEFT.GE.1) IE=NRTA PTA03610 NN=(IS-1)*IYPT+1 PTA03620 NIA=IE*IYPT PTA03630 CALL LINKA(INTFA,IPTR,NN,NIA,IPLOC,+1) PTA03640 C PTA03650 IF(LEFT) 610, 630, 611 PTA03660 C PTA03670 610 MM=NIA+1 PTA03680 MIA=NRTA*IYPT PTA03690 CALL LINKDI(INTFA,IPTR,NN,NIA,MM,MIA) PTA03700 GO TO 630 PTA03710 C PTA03720 611 NA=(NN+1)/2-NYPT PTA03730 NC=1-NYPT PTA03740 DO 615 IA=NN,NIA,IYPT PTA03750 NA=NA+NYPT PTA03760 NC=NC+NYPT PTA03770 FILEC(NC)=FILEA(NA) PTA03780 615 FILEC(NC+1)=FILEA(NA+1) PTA03790 LL=NIA-NN+2 PTA03800 C PTA03810 CALL BPUT(IFLA,NOWTRK,FILEA,NPTR) PTA03820 ITRK=ITRK+1 PTA03830 CALL BGET(IFLA,ITRK,FILEA,NPTR,NRTA) PTA03840 NOWTRK=ITRK PTA03850 C PTA03860 NA=1-NYPT PTA03870 NIA=LEFT*IYPT PTA03880 DO 620 IA=1,NIA,IYPT PTA03890 NA=NA+NYPT PTA03900 NC=NC+NYPT PTA03910 FILEC(NC)=FILEA(NA) PTA03920 620 FILEC(NC+1)=FILEA(NA+1) PTA03930 C PTA03940 NIC=NRA*IYPT PTA03950 CALL LINKA(INTFC,IPTR,LL,NIC,IPLOC,+1) PTA03960 C PTA03970 MIB=NRTA*IYPT PTA03980 CALL LINKD(INTFC,INTFA,IPTR,01,NIC,01,MIB,ICHNG) PTA03990 C PTA04000 630 IF(ITRK.EQ.NTRKA) GO TO 640 PTA04010 C PTA04020 KTRK=ITRK+1 PTA04030 C PTA04040 DO 635 JTRK=KTRK,NTRKA PTA04050 C PTA04060 CALL BGET(IFLA,JTRK,FILEB,NPTR,NRB) PTA04070 NIB=NRB*IYPT PTA04080 ICHNG=0 PTA04090 C PTA04100 IF(LEFT.GE.1) CALL LINKD(INTFC,INTFB,IPTR,01,NIC,01,NIB,ICHNG) PTA04110 IF(LEFT.LE.0) CALL LINKD(INTFA,INTFB,IPTR,NN,NIA,01,NIB,ICHNG) PTA04120 IF(ICHNG.EQ.1) CALL BPUT(IFLA,JTRK,FILEB,NPTR) PTA04130 C PTA04140 635 CONTINUE PTA04150 C PTA04160 640 IF(NPH.LT.NACCPH) GO TO 600 PTA04170 CALL BPUT(IFLA,ITRK,FILEA,NPTR) PTA04180 GO TO 700 PTA04190 C PTA04200 650 NN=(NS-1)*IYPT+1 PTA04210 NIA=(NS+NRA-1)*IYPT PTA04220 CALL LINKA(INTFA,IPTR,NN,NIA,IPLOC,+1) PTA04230 C PTA04240 IF(NIA.GE.NIB) GO TO 700 PTA04250 C PTA04260 MM=NIA+1 PTA04270 CALL LINKDI(INTFA,IPTR,NN,NIA,MM,NIB) PTA04280 GO TO 600 PTA04290 C PTA04300 700 NPTU=IPLOC PTA04310 IF(IRMV.EQ.0) NPTU=-IPLOC PTA04320 C PTA04330 C FINALIZE FILEA, FILEF, FILEG PTA04340 C PTA04350 CALL BGET(IFLF,1,FILEB,NHOR,NRH) PTA04360 CALL BGET(IFLG,1,FILEC,NVER,NRV) PTA04370 C PTA04380 IHO=NRH*IYHO PTA04390 IVE=NRV*IYVE PTA04400 IGA=0 PTA04410 KPT=NACCPT PTA04420 C PTA04430 705 CALL BRING(IFLA,FILEA,NPTR,NYPT,IGA,IFLA,ITRKA,NRA,IPA,IRA,IIA) PTA04440 KPT=KPT-1 PTA04450 IPT=INTFA(IIA+2) PTA04460 C PTA04470 IF(IRMV.EQ.0) INTFA(IIA)=-INTFA(IIA) PTA04480 C PTA04490 DO 710 I=1,IHO,IYHO PTA04500 IF(IPT.NE.INTFB(I+2)) GO TO 710 PTA04510 INTFB(I)=INTFA(IIA) PTA04520 INTFB(I+3)=INTFA(IIA+3) PTA04530 INTFA(IIA+3)=INTFA(IIA+3)+2000 PTA04540 GO TO 715 PTA04550 710 CONTINUE PTA04560 C PTA04570 715 DO 720 I=1,IVE,IYVE PTA04580 IF(IPT.NE.INTFC(I+2)) GO TO 720 PTA04590 INTFA(IIA+3)=INTFA(IIA+3)+1000 PTA04600 INTFC(I)=INTFA(IIA) PTA04610 INTFC(I+3)=INTFA(IIA+3) PTA04620 GO TO 730 PTA04630 720 CONTINUE PTA04640 C PTA04650 730 IF(KPT.NE.0) GO TO 705 PTA04660 C PTA04670 IF(ITRKA.EQ.NTRK(IFLA)) CALL BPUT(IFLA,ITRKA,FILEA,NPTR) PTA04680 C PTA04690 C CHECK CONTROL LIST REFERENCE PTA04700 C PTA04710 DO 740 I=1,3 PTA04720 740 GRV(I)=0.0 PTA04730 IRMVH=0 PTA04740 IRMVV=0 PTA04750 JHO=2-NYHO PTA04760 JVE=3-NYVE PTA04770 C PTA04780 DO 750 I=1,IHO,IYHO PTA04790 JHO=JHO+NYHO PTA04800 IF(INTFB(I).NE.MAXNR) GO TO 747 PTA04810 IRMVH=IRMVH+1 PTA04820 GO TO 750 PTA04830 747 DO 748 J=1,2 PTA04840 748 GRV(J)=GRV(J)+FILEB(JHO+J) PTA04850 750 CONTINUE PTA04860 C PTA04870 DO 760 I=1,IVE,IYVE PTA04880 JVE=JVE+NYVE PTA04890 IF(INTFC(I).NE.MAXNR) GO TO 755 PTA04900 IRMVV=IRMVV+1 PTA04910 GO TO 760 PTA04920 755 GRV(3)=GRV(3)+FILEC(JVE) PTA04930 760 CONTINUE PTA04940 C PTA04950 CALL SORTB1(FILEB,INTFB,1,NRH,1,SUBA,NHOR,IHOR,NYHO,IYHO) PTA04960 CALL SORTB1(FILEC,INTFC,1,NRV,1,SUBA,NVER,IVER,NYVE,IYVE) PTA04970 C PTA04980 IF(IRMVH.EQ.0) GO TO 770 PTA04990 NRH=NRH-IRMVH PTA05000 NS=NRH*IYHO+1 PTA05010 IS=NS+2 PTA05020 CALL SORTB(INTFB,NS,IRMVH,3,ISUBC,IHOR,IYHO) PTA05030 WRITE(IPR,5101) (INTFB(I),I=IS,IHO,IYHO) PTA05040 C PTA05050 770 IF(IRMVV.EQ.0) GO TO 780 PTA05060 NRV=NRV-IRMVV PTA05070 NS=NRV*IYVE+1 PTA05080 IS=NS+2 PTA05090 CALL SORTB(INTFC,NS,IRMVV,3,ISUBC,IVER,IYVE) PTA05100 WRITE(IPR,5102) (INTFC(I),I=IS,IVE,IYVE) PTA05110 C PTA05120 780 IF(NRH.EQ.0) GO TO 795 PTA05130 JHO=NRH*NYHO PTA05140 IHO=2-IYHO PTA05150 IERR=0 PTA05160 DO 786 J=1,2 PTA05170 786 GRV(J)=GRV(J)/DFLOAT(NRH) PTA05180 C PTA05190 DO 790 I=2,JHO,NYHO PTA05200 DO 788 J=1,2 PTA05210 788 FILEB(I+J)=FILEB(I+J)-GRV(J) PTA05220 IHO=IHO+IYHO PTA05230 IWT=INTFB(IHO) PTA05240 IF(WATE(IWT,5).NE.0.0) GO TO 790 PTA05250 IF(IERR.EQ.0) WRITE(IPR,2) PTA05260 WRITE(IPR,5103) IWT,INTFB(IHO+1) PTA05270 IERR=1 PTA05280 KERR=1 PTA05290 790 CONTINUE PTA05300 C PTA05310 795 IF(NRV.EQ.0) GO TO 810 PTA05320 JVE=NRV*NYVE PTA05330 IVE=2-IYVE PTA05340 IERR=0 PTA05350 GRV(3)=GRV(3)/DFLOAT(NRV) PTA05360 C PTA05370 DO 805 I=3,JVE,NYVE PTA05380 FILEC(I)=FILEC(I)-GRV(3) PTA05390 IVE=IVE+IYVE PTA05400 IWT=INTFC(IVE) PTA05410 IF(WATE(IWT,5).NE.0.0) GO TO 805 PTA05420 IF(IERR.EQ.0) WRITE(IPR,2) PTA05430 WRITE(IPR,5104) IWT,INTFC(IVE+1) PTA05440 IERR=1 PTA05450 KERR=1 PTA05460 805 CONTINUE PTA05470 C PTA05480 810 IF(NRH.GE.2) GO TO 815 PTA05490 WRITE(IPR,5105) PTA05500 WRITE(IPR,5106) PTA05510 KERR=1 PTA05520 C PTA05530 815 IF(NRV.GE.3) GO TO 820 PTA05540 WRITE(IPR,5105) PTA05550 WRITE(IPR,5107) PTA05560 KERR=1 PTA05570 C PTA05580 820 IF(KERR.NE.0) GO TO 950 PTA05590 C PTA05600 NREC(IFLF)=NRH PTA05610 NREC(IFLG)=NRV PTA05620 CALL BPUT(IFLF,1,FILEB,NHOR) PTA05630 CALL BPUT(IFLG,1,FILEC,NVER) PTA05640 C PTA05650 C SET UP WORK FILES FOR BLOCK ADJUSTMENT PTA05660 C PTA05670 WRITE(IPR,3200) PTA05680 C PTA05690 READ(ICD,1) MAXNPH PTA05700 WRITE(IPR,3201) MAXNPH PTA05710 C PTA05720 C COPY FILEA ONTO FILEH PTA05730 C PTA05740 CALL SETFIL(IFLH,MPTREC,NPTR,1) PTA05750 CALL COPYFL(IFLA,IFLH,FILEA,NPTR,NYPT) PTA05760 C PTA05770 C SET UP FILEA, FILEB, FILEC, FILEI, FILEJ PTA05780 C PTA05790 CALL SORTD(IFLA,1,FILEA,FILEB,INTFA,INTFB,SUBA,NPTR,IPTR,NYPT,IYPTPTA05800 * )PTA05810 C PTA05820 C SET UP (FILEA)=(A12)T, (FILEC)=(PT. COOD. LIST) PTA05830 C PTA05840 CALL OPEN(IFLC,NPTR,NYPT) PTA05850 LPT=0 PTA05860 IRC=1-NYPT PTA05870 IIC=1-IYPT PTA05880 C PTA05890 IGA=0 PTA05900 IPT=0 PTA05910 KPT=NACCPT PTA05920 IACCPT=0 PTA05930 PTADD=10.D0**(INTDGT+1) PTA05940 C PTA05950 830 CALL BRING(IFLA,FILEA,NPTR,NYPT,IGA,IFLA,ITRKA,NRA,IPA,IRA,IIA) PTA05960 KPT=KPT-1 PTA05970 C PTA05980 IF(INTFA(IIA).EQ.IPT) GO TO 840 PTA05990 IF(IPT.EQ.0) GO TO 835 PTA06000 C PTA06010 CALL APUT(IFLC,FILEC,NPTR, LPT,1, 1,1, IRC,IIC) PTA06020 LPT=LPT+1 PTA06030 IRC=IRC+NYPT PTA06040 IIC=IIC+IYPT PTA06050 C PTA06060 FILEC(IRC+1)=0.0 PTA06070 FILEC(IRC+2)=0.0 PTA06080 FILEC(IRC+3)=0.0 PTA06090 INTFC(IIC)=JPT PTA06100 INTFC(IIC+1)=MULT PTA06110 INTFC(IIC+2)=IACCPT+1 PTA06120 IACCPT=IACCPT+MULT-(MULT/1000)*1000 PTA06130 C PTA06140 835 IPT=INTFA(IIA) PTA06150 JPT=INTFA(IIA+2) PTA06160 MULT=INTFA(IIA+3) PTA06170 C PTA06180 840 FILEA(IRA+1)=DFLOAT(IPT)*PTADD+DFLOAT(INTFA(IIA+1)) PTA06190 C PTA06200 IF(KPT.NE.0) GO TO 830 PTA06210 C PTA06220 CALL APUT(IFLC,FILEC,NPTR, LPT,1, 1,1, IRC,IIC) PTA06230 LPT=LPT+1 PTA06240 IRC=IRC+NYPT PTA06250 IIC=IIC+IYPT PTA06260 C PTA06270 FILEC(IRC+1)=0.0 PTA06280 FILEC(IRC+2)=0.0 PTA06290 FILEC(IRC+3)=0.0 PTA06300 INTFC(IIC)=JPT PTA06310 INTFC(IIC+1)=MULT PTA06320 INTFC(IIC+2)=IACCPT+1 PTA06330 C PTA06340 CALL ACLOSE(IFLC,FILEC,NPTR,LPT) PTA06350 IF(ITRKA.EQ.NTRK(IFLA)) CALL BPUT(IFLA,ITRKA,FILEA,NPTR) PTA06360 C PTA06370 CALL SORTC(IFLA,2,FILEA,FILEB,SUBA,NPTR,NYPT) PTA06380 C PTA06390 C SET UP (FILEB)=(A12) PTA06400 C (FILEI)=(COLUMNWISE PHOTO-ADDRESS MATRIX, COMPRESSED) PTA06410 C PTA06420 CALL OPEN(IFLB,NPTR,NYPT) PTA06430 NTRK(IFLB)=NTRK(IFLH) PTA06440 NREC(IFLB)=NREC(IFLH) PTA06450 C PTA06460 IERR=0 PTA06470 IF(MAXNPH.GE.0) GO TO 845 PTA06480 WRITE(IPR,5201) PTA06490 GO TO 846 PTA06500 C PTA06510 845 IF(MAXNPH.LE.MXBAND) GO TO 850 PTA06520 WRITE(IPR,5202) MXBAND PTA06530 846 IERR=1 PTA06540 NYPHI=NPHDIM PTA06550 GO TO 855 PTA06560 C PTA06570 850 NYPHI=(MAXNPH+2)/2 PTA06580 855 CALL SETDIM(NPHDIM,NYPHI, NPHRI,NTPHI,IPHRI,IYPHI) PTA06590 C PTA06600 IF(IERR.NE.0) GO TO 860 PTA06610 C PTA06620 C (NOTE: NPHIRC TAKES MAX.VALUE WHEN NACCPH=MAXPH AND NTPHI=NPHDIM/NNN, PTA06630 C WHERE NNN=(MXBAND+3)/2 ) PTA06640 C PTA06650 MMM=(MXBAND+3)/2 PTA06660 MTPHI=NPHDIM/MMM PTA06670 NPHIRC=(NACCPH-1)/MTPHI+1 PTA06680 C PTA06690 CALL SETFIL(IFLI,NPHIRC,NPHRI,1) PTA06700 C PTA06710 860 CALL OPEN(IFLI,NPHRI,NYPHI) PTA06720 C PTA06730 IGD=0 PTA06740 IGH=0 PTA06750 KPH=0 PTA06760 MAXMPH=0 PTA06770 ITRKA=0 PTA06780 ITRKC=0 PTA06790 IPH=0 PTA06800 IIE=1-IYPHI PTA06810 IF(IERR.NE.0) IIE=0 PTA06820 JERR=0 PTA06830 IYPHI1=IYPHI-1 PTA06840 C PTA06850 870 CALL BRING(IFLD,FILED,NPHR,NYPH,IGD,IFLD,ITRKD,NRD,IPD,IRD,IID) PTA06860 KPH=KPH+1 PTA06870 NPH=0 PTA06880 KPT=INTFD(IID+1) PTA06890 IPHSTA=((KPH-2)*(KPH-1))/2 PTA06900 INTFD(IID+3)=IPHSTA PTA06910 C PTA06920 IF(IERR.NE.0) GO TO 880 PTA06930 C PTA06940 CALL APUT(IFLI,FILEE,NPHRI,IPH,1, 0,1, IRE,IIE) PTA06950 IPH=IPH+1 PTA06960 IIE=IIE+IYPHI PTA06970 C PTA06980 DO 875 I=1,IYPHI1 PTA06990 875 INTFE(IIE+I)=0 PTA07000 C PTA07010 880 CALL BRING(IFLH,FILEB,NPTR,NYPT,IGH,IFLB,ITRKB,NRB,IPB,IRB,IIB) PTA07020 KPT=KPT-1 PTA07030 C PTA07040 CALL LOCATE(IFLC,FILEC,NPTR,NTPT,NYPT,0,INTFB(IIB),ITRKC,IRC,IIC) PTA07050 C PTA07060 MULT=INTFC(IIC+1) PTA07070 IF(MULT.GE.1000) MULT=MULT-(MULT/1000)*1000 PTA07080 LOC=INTFC(IIC+2) PTA07090 INTFB(IIB+1)=LOC PTA07100 INTFB(IIB+2)=MULT PTA07110 C PTA07120 IF(KPH.EQ.1) GO TO 900 PTA07130 C PTA07140 DO 890 I=1,MULT PTA07150 C PTA07160 MOC=LOC+I-1 PTA07170 CALL LOCATE(IFLA,FILEA,NPTR,NTPT,NYPT,0,MOC,ITRKA,IRA,IIA) PTA07180 C PTA07190 IF(INTFA(IIA+1).GE.KPH) GO TO 900 PTA07200 LPH=INTFA(IIA+1) PTA07210 C PTA07220 IF(NPH.EQ.0) GO TO 883 PTA07230 C PTA07240 DO 882 J=1,NPH PTA07250 IF(LPH.EQ.INTFE(IIE+J)) GO TO 890 PTA07260 882 CONTINUE PTA07270 C PTA07280 883 NPH=NPH+1 PTA07290 IF(IIE+NPH .GT. IPHRI) GO TO 885 PTA07300 INTFE(IIE+NPH)=LPH PTA07310 GO TO 890 PTA07320 C PTA07330 885 IF(IIE.EQ.0) GO TO 895 PTA07340 IF(NPH.EQ.1) GO TO 888 PTA07350 NPH1=NPH-1 PTA07360 DO 887 K=1,NPH1 PTA07370 887 INTFE(K)=INTFE(IIE+K) PTA07380 888 INTFE(NPH)=LPH PTA07390 IERR=1 PTA07400 IIE=0 PTA07410 C PTA07420 890 CONTINUE PTA07430 C PTA07440 GO TO 900 PTA07450 C PTA07460 895 WRITE(IPR,5203) INTFD(IID),NPH PTA07470 CALL ERRSTP(IPR) PTA07480 C PTA07490 900 IF(KPT.NE.0) GO TO 880 PTA07500 C PTA07510 IF(NPH.GT.MAXMPH) MAXMPH=NPH PTA07520 IF(NPH+1.LE.IYPHI) GO TO 905 PTA07530 IF(JERR.EQ.0) WRITE(IPR,2) PTA07540 WRITE(IPR,5204) INTFD(IID) PTA07550 IERR=1 PTA07560 JERR=1 PTA07570 IIE=0 PTA07580 C PTA07590 905 IF(IERR.NE.0) GO TO 910 PTA07600 C PTA07610 INTFE(IIE)=NPH PTA07620 IF(NPH.EQ.0) GO TO 910 PTA07630 C PTA07640 DO 907 I=1,NPH PTA07650 907 INTFE(IIE+I)=INTFE(IIE+I)+IPHSTA PTA07660 C PTA07670 IF(NPH.GE.2) CALL SORTB(INTFE,IIE+1,NPH,1,ISUBC,IPHRI,1) PTA07680 C PTA07690 910 IF(KPH.NE.NACCPH) GO TO 870 PTA07700 C PTA07710 IF(IERR.EQ.0) GO TO 915 PTA07720 WRITE(IPR,3202) MAXMPH PTA07730 CALL ERRSTP(IPR) PTA07740 C PTA07750 915 CALL ACLOSE(IFLI,FILEE,NPHRI,IPH) PTA07760 IF(ITRKD.EQ.NTRK(IFLD)) CALL BPUT(IFLD,ITRKD,FILED,NPHR) PTA07770 IF(ITRKB.EQ.NTRK(IFLH)) CALL BPUT(IFLB,ITRKB,FILEB,NPTR) PTA07780 C PTA07790 C FIND ROW BANDWIDTH PTA07800 C PTA07810 ITRKI=0 PTA07820 NM1=NACCPH-1 PTA07830 MAXROW=0 PTA07840 C PTA07850 DO 930 ILP=1,NM1 PTA07860 C PTA07870 JSTA=ILP+1 PTA07880 JEND=ILP+MXBAND PTA07890 IF(JEND.GT.NACCPH) JEND=NACCPH PTA07900 NROW=ILP PTA07910 C PTA07920 DO 920 JLP=JSTA,NACCPH PTA07930 LPH=ILP+((JLP-2)*(JLP-1))/2 PTA07940 CALL LOCATE(IFLI,FILEE,NPHRI,NTPHI,NYPHI,0,JLP,ITRKI,IRE,IIE) PTA07950 CALL TRACEP(LPH,LOC,INTFE,IIE,IPHRI) PTA07960 IF(LOC.NE.0) NROW=JLP PTA07970 920 CONTINUE PTA07980 C PTA07990 NROW=NROW-ILP PTA08000 IF(NROW.GT.MAXROW) MAXROW=NROW PTA08010 C PTA08020 930 CONTINUE PTA08030 C PTA08040 IF(MAXNPH.NE.MAXMPH) WRITE(IPR,3202) MAXMPH PTA08050 WRITE(IPR,3203) MAXMPH PTA08060 WRITE(IPR,3204) MAXROW PTA08070 C PTA08080 IF(MAXROW.LE.MXBAND) GO TO 940 PTA08090 WRITE(IPR,5205) MXBAND PTA08100 CALL ERRSTP(IPR) PTA08110 940 CALL STORE(IFLD,FILED,NPHR) PTA08120 C PTA08130 950 WRITE(IPR,3100) PTA08140 WRITE(IPR,3101) NACCPH PTA08150 WRITE(IPR,3102) NACCPT PTA08160 WRITE(IPR,3103) NRH PTA08170 WRITE(IPR,3104) NRV PTA08180 WRITE(IPR,3105) NPTU PTA08190 C PTA08200 IF(KERR.NE.0) CALL ERRSTP(IPR) PTA08210 C PTA08220 RETURN PTA08230 C PTA08240 1 FORMAT(4I20) PTA08250 2 FORMAT(1H ) PTA08260 C PTA08270 3000 FORMAT(1H1,//, 5X,'UNBASC2-PROGRAM: ',20A4,'(PART-2)',/) PTA08280 3001 FORMAT(1H0,I11,' PHOTO(S) ALLOCATED IN GROUP',I3,' :',6I10) PTA08290 3002 FORMAT(1H0,I11,' PHOTO(S) ALLOCATED IN GROUP',I3,' :',6I10,/, PTA08300 * (45X,6I10)) PTA08310 3003 FORMAT(1H0,/,10X,'FORMATION OF MULTIPLET PHOTO BLOCK',/,10X,'----'PTA08320 * ,'------------------------------',/) PTA08330 3004 FORMAT(1H0, 9X,'READ-IN NUMBER OF PHOTO(S) IN 1ST PHOTO-GROUP =',PTA08340 * I7) PTA08350 3005 FORMAT(1H0, 9X,'READ-IN PHOTO NUMBER(S) IN 1ST PHOTO-GROUP =', PTA08360 * 5I10) PTA08370 3006 FORMAT(1H0, 9X,'READ-IN PHOTO NUMBER(S) IN 1ST PHOTO-GROUP =', PTA08380 * 5I10,/,(55X,5I10)) PTA08390 C PTA08400 3100 FORMAT(1H0,//,10X,'STATISTICS',/,10X,'----------') PTA08410 3101 FORMAT(1H0, 9X,'NUMBER OF PHOTOGRAPHS USED FOR BUNDLE ADJUSTMENT.'PTA08420 * ,'.................',I6) PTA08430 3102 FORMAT(1H0, 9X,'NUMBER OF IMAGE POINTS USED FOR BUNDLE ADJUSTMENT'PTA08440 * ,'.................',I6) PTA08450 3103 FORMAT(1H0, 9X,'NUMBER OF HORIZONTAL CONTROL POINTS USED FOR BUND'PTA08460 * ,'LE ADJUSTMENT....',I6) PTA08470 3104 FORMAT(1H0, 9X,'NUMBER OF VERTICAL CONTROL POINTS USED FOR BUNDLE'PTA08480 * ,' ADJUSTMENT......',I6) PTA08490 3105 FORMAT(1H0, 9X,'NUMBER OF UNKNOWN OBJECT POINTS IN THIS BLOCK....'PTA08500 * ,'.................',I6) PTA08510 C PTA08520 3200 FORMAT(1H0,//,10X,'FORMATION OF ADDRESS MATRIX FOR NORMAL EQUATIO'PTA08530 * ,'N SYSTEM',/,10X,'-----------------------------------------'PTA08540 * ,'-------------',/) PTA08550 3201 FORMAT(1H0, 9X,'READ-IN MAXNPH (MAXIMUM NUMBER OF PHOTOS IN COLU',PTA08560 * 'MN BAND) =',I6) PTA08570 3202 FORMAT(1H0, 9X,'OPTIMUM MAXNPH (MAXIMUM NUMBER OF PHOTOS IN COLU',PTA08580 * 'MN BAND) =',I6) PTA08590 3203 FORMAT(1H0, 9X,'COMPRESSED COLUMN BANDWIDTH =',I4) PTA08600 3204 FORMAT(1H0, 9X,'COMPRESSED ROW BANDWIDTH =',I4) PTA08610 C PTA08620 5001 FORMAT(1H0, 9X,'***(ERROR)*** READ-IN NUMBER OF PHOTOS (',I10,' )'PTA08630 * ,' IN 1ST PHOTO-GROUP MUST BE BETWEEN 1 AND',I4) PTA08640 5002 FORMAT(1H , 9X,'***(ERROR)*** NEGATIVE PHOTO NUMBER (',I10,') IS 'PTA08650 * ,'NOT ALLOWED') PTA08660 5003 FORMAT(1H , 9X,'***(ERROR)*** DUPLICATE PHOTO NUMBER (',I10,') IS'PTA08670 * ,' NOT ALLOWED') PTA08680 5004 FORMAT(1H , 9X,'***(ERROR)*** UNABLE TO FIND PHOTO NUMBER',I10) PTA08690 5005 FORMAT(1H , 9X,'***(WARNING)*** POINT',I10,' OF PHOTO',I10,' HA'PTA08700 * ,'S NO CONNECTION TO ANY OTHER PHOTOS') PTA08710 5006 FORMAT(1H0, 9X,'***(ERROR)*** ALL POINTS HAVE BEEN REMOVED FROM ',PTA08720 * 'PHOTO',I10,/) PTA08730 5007 FORMAT(1H0, 9X,'***(ERROR)*** OVER FLOW - MAXIMUM NUMBER OF PHOTO'PTA08740 * ,'S IN ONE PHOTO-GROUP =',I5) PTA08750 C PTA08760 5101 FORMAT(1H0,/,10X,'***(WARNING)*** HORIZONTAL CONTROL POINT(S) NOT'PTA08770 * ,' REFERENCED BY IMAGE DATA:',//,(10X,8I10)) PTA08780 5102 FORMAT(1H0,/,10X,'***(WARNING)*** VERTICAL CONTROL POINT(S) NOT ',PTA08790 * 'REFERENCED BY IMAGE DATA:',//,(10X,8I10)) PTA08800 5103 FORMAT(1H , 9X,'***(ERROR)*** MISSING WEIGHT MATRIX (PCTL NO.',I1,PTA08810 * ') REFERENCED BY CONTROL POINT',I10,' (H)') PTA08820 5104 FORMAT(1H , 9X,'***(ERROR)*** MISSING WEIGHT MATRIX (PCTL NO.',I1,PTA08830 * ') REFERENCED BY CONTROL POINT',I10,' (V)') PTA08840 5105 FORMAT(1H0, 9X,'***(ERROR)*** INSUFFICIENT NUMBER OF CONTROL POIN'PTA08850 * ,'TS') PTA08860 5106 FORMAT(1H ,23X,'MINIMUM 2 HORIZONTAL CONTROL POINTS ARE REQUIRED')PTA08870 5107 FORMAT(1H ,23X,'MINIMUM 3 VERTICAL CONTROL POINTS ARE REQUIRED') PTA08880 C PTA08890 5201 FORMAT(1H0, 9X,'***(ERROR)*** READ-IN MAXNPH MAY NOT BE NEGATIVE')PTA08900 5202 FORMAT(1H0, 9X,'***(ERROR)*** READ-IN MAXNPH IS TOO LARGE',/,24X, PTA08910 * 'MAXNPH MAY NOT EXCEED',I6) PTA08920 5203 FORMAT(1H0, 9X,'***(ERROR)*** PHOTO',I10,' IS CONNECTED TO MORE',PTA08930 * ' THAN',I6,' PHOTOS', /,24X,'UNABLE TO OPTIMIZE THE BANDW',PTA08940 * 'IDTH OF NORMAL EQUATION MATRIX') PTA08950 5204 FORMAT(1H , 9X,'***(ERROR)*** PHOTO',I10,' HAS A BANDWIDTH GREAT'PTA08960 * ,'ER THAN SPECIFIED BY MAXNPH') PTA08970 5205 FORMAT(1H0, 9X,'***(ERROR)*** COMPRESSED ROW BANDWIDTH MAY NOT EX'PTA08980 * ,'CEED',I4) PTA08990 C PTA09000 END PTA09010 SUBROUTINE ADJUST(FILEA,FILEB,FILEC,FILED,FILEE,INTFA,INTFB,INTFC,PTA09020 * INTFD,INTFE,ATA,BTB,CTC,DTD,ETE,FTF,INTCTC, PTA09030 * NPTDIM,IPTDIM,NPHDIM,IPHDIM,NORDIM,NOIDIM,IORDIMPTA09040 * )PTA09050 IMPLICIT REAL*8(A-H,O-Z) PTA09060 C PTA09070 DIMENSION FILEA(NPTDIM),FILEB(NPTDIM),FILEC(NPTDIM),FILED(NPHDIM),PTA09080 * FILEE(NPHDIM),INTFA(IPTDIM),INTFB(IPTDIM),INTFC(IPTDIM),PTA09090 * INTFD(IPHDIM),INTFE(IPHDIM) PTA09100 C PTA09110 DIMENSION ATA(NORDIM),BTB(NORDIM),CTC(NORDIM),DTD(NOIDIM), PTA09120 * ETE(NOIDIM),FTF(NORDIM),INTCTC(IORDIM) PTA09130 C PTA09140 DIMENSION A(2,22),TEMPA(48),TEMPB(48),P(3),Q(3),R(3),SUBA(16) PTA09150 DIMENSION NULIST(22),NAME11(16),ICH(80),KCH(80) PTA09160 C PTA09170 COMMON /BLOCKA/WATE(11,5) PTA09180 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA09190 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA09200 COMMON /MARIKO/RMSG(6),NU11(16),NU22(3),ISET(10),MAME11(12), PTA09210 * NAME22(3),MAM,NUSUM,IMS(3) PTA09220 C PTA09230 EQUIVALENCE (IAUX(24), NYPT),(IAUX(25), NYPH),(IAUX(26), NYHO) PTA09240 * ,(IAUX(27), NYVE),(IAUX(31),NACCPT),(IAUX(32),NACCPH) PTA09250 * ,(IAUX(34), NYPHE),(IAUX(35), NYPTL),(IAUX(36), NPTU) PTA09260 * ,(IAUX(43), NYPHI),(IAUX(46), NYDAG),(IAUX(47), NYOFF) PTA09270 * ,(IAUX(48), NYCTL),(IAUX(49),NPHOFF) PTA09280 EQUIVALENCE (IAUX(51), NU0),(IAUX(52), NUP),(IAUX(53), IDIST) PTA09290 * ,(IAUX(54),NULIST(1)) PTA09300 C PTA09310 DATA IFLA,IFLB,IFLC,IFLD,IFLE,IFLF,IFLG/1,2,3,4,5,6,7/ PTA09320 DATA IFLI,IFLL,NFL1,NFL3,NFL2,NFL4,NFL5/9,12,13,14,15,16,17/ PTA09330 C PTA09340 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA09350 C PTA09360 C SET UP ADDRESS MATRICES, (FILEI), (FILEJ), (FILEK) PTA09370 C PTA09380 CALL ADDRES(FILED,FILEE,CTC,INTFD,INTFE,INTCTC,NPHDIM,IPHDIM, PTA09390 * NORDIM,IORDIM) PTA09400 C PTA09410 C SET UP FILE DIMENSION PTA09420 C PTA09430 CALL SETDIM(NPTDIM,NYPT, NPTR,NTPT,IPTR,IYPT) PTA09440 CALL SETDIM(NPHDIM,NYPH, NPHR,NTPH,IPHR,IYPH) PTA09450 CALL SETDIM(NPTDIM,NYHO, NHOR,NTHO,IHOR,IYHO) PTA09460 CALL SETDIM(NPTDIM,NYVE, NVER,NTVE,IVER,IYVE) PTA09470 CALL SETDIM(NPHDIM,NYPHI, NPHRI,NTPHI,IPHRI,IYPHI) PTA09480 CALL SETDIM(NPTDIM,NYPTL, NPTRL,NTPTL,IPTRL,IYPTL) PTA09490 C PTA09500 NPTLRC=(NPTU-1)/NTPTL+1 PTA09510 CALL SETFIL(IFLL,NPTLRC,NPTRL,1) PTA09520 C PTA09530 C START OF ITERATIVE SOLUTION PTA09540 C PTA09550 DO 85 I=1,3 PTA09560 P(I)=WATE(10,I) PTA09570 85 Q(I)=WATE(11,I) PTA09580 C PTA09590 DO 95 I=1,9 PTA09600 IF(WATE(I,5).EQ.0.0) GO TO 95 PTA09610 DO 90 J=1,4 PTA09620 IF(WATE(I,J).NE.0.0) GO TO 95 PTA09630 90 CONTINUE PTA09640 WATE(I,5)=0.0 PTA09650 95 CONTINUE PTA09660 C PTA09670 IPASS=0 PTA09680 LASTIT=0 PTA09690 ITER=-1 PTA09700 NU0=4 PTA09710 NUP=2 PTA09720 C PTA09730 READ(ICD,1) (KCH(I),I=1,80) PTA09740 C PTA09750 100 ITER=ITER+1 PTA09760 C PTA09770 IF(ITER.EQ.0) GO TO 110 PTA09780 C PTA09790 DO 105 I=1,80 PTA09800 105 ICH(I)=KCH(I) PTA09810 C PTA09820 WRITE(IPR,3101) ITER PTA09830 C PTA09840 CALL DESIGN(ICH,KCH,LASTIT,NU0,MAM,NULIST,NU11,ISET,NAME11,MAME11,PTA09850 * IDIST,NUP,NU22,NAME22,IX,IY,IZ,IXX,IYY,IZZ,IXY)PTA09860 C PTA09870 110 NUPHS=NACCPH*NU0 PTA09880 NUPTS=NPTU*NUP PTA09890 NUSUM=NUPHS+NUPTS PTA09900 NU0NUP=NU0+NUP PTA09910 NW=NU0NUP+1 PTA09920 C PTA09930 IF(ITER.EQ.0) GO TO 135 PTA09940 WRITE(IPR,3103) NUSUM,NUPHS PTA09950 IF(NU0.NE.0) WRITE(IPR,3105) (MAME11(I),I=1,MAM) PTA09960 WRITE(IPR,3104) NUPTS PTA09970 IF(NUP.NE.0) WRITE(IPR,3105) (NAME22(I),I=1,NUP) PTA09980 C PTA09990 IF(NU0.NE.0) GO TO 140 PTA10000 WRITE(IPR,5101) PTA10010 GO TO 700 PTA10020 C PTA10030 135 WRITE(IPR,3102) ITER PTA10040 WRITE(IPR,3103) NUSUM,NUPHS PTA10050 WRITE(IPR,3106) PTA10060 WRITE(IPR,3104) NUPTS PTA10070 WRITE(IPR,3109) PTA10080 C PTA10090 140 NYOFF=NU0*NU0 PTA10100 NYDAG=(NYOFF+NU0)/2 PTA10110 NYCTL=NU0 PTA10120 NYNUP=NUP PTA10130 NYFTF=NU0*NUP PTA10140 C PTA10150 CALL SETDIM(NORDIM,NYDAG, NDAGR,NTDAG,IDAGR,IYDAG) PTA10160 CALL SETDIM(NOIDIM,NYCTL, NCTLR,NTCTL,ICTLR,IYCTL) PTA10170 C PTA10180 NDAGRC=(NACCPH-1)/NTDAG+1 PTA10190 NCTLRC=(NACCPH-1)/NTCTL+1 PTA10200 C PTA10210 CALL SETFIL(NFL1,NDAGRC,NDAGR,1) PTA10220 CALL SETFIL(NFL3,NCTLRC,NCTLR,1) PTA10230 C PTA10240 IF(NUP.EQ.0) GO TO 300 PTA10250 C PTA10260 CALL SETDIM(NORDIM,NYOFF, NOFFR,NTOFF,IOFFR,IYOFF) PTA10270 CALL SETDIM(NOIDIM,NYNUP, NNUPR,NTNUP,INUPR,IYNUP) PTA10280 CALL SETDIM(NORDIM,NYFTF, NFTFR,NTFTF,IFTFR,IYFTF) PTA10290 C PTA10300 NOFFRC=(NPHOFF-1)/NTOFF+1 PTA10310 NNUPRC=(NPTU-1)/NTNUP+1 PTA10320 NFTFRC=(NACCPT-1)/NTFTF+1 PTA10330 C PTA10340 CALL SETFIL(NFL2,NOFFRC,NOFFR,1) PTA10350 CALL SETFIL(NFL4,NNUPRC,NNUPR,1) PTA10360 CALL SETFIL(NFL5,NFTFRC,NFTFR,1) PTA10370 C PTA10380 IF(ITER.NE.0) GO TO 210 PTA10390 C PTA10400 C PLANIMETRIC 4-PARAMETER ADJUSTMENT FOR INITIAL APPROXIMATION ONLY PTA10410 C SET UP (FILEC)=(B2) PTA10420 C PTA10430 IGF=0 PTA10440 ITRKC=0 PTA10450 ICX=0 PTA10460 ICY=0 PTA10470 KHO=NREC(IFLF) PTA10480 C PTA10490 DO 160 KPT=1,KHO PTA10500 C PTA10510 CALL BRING(IFLF,FILEB,NHOR,NYHO,IGF,0,ITRKF,NRF,IPF,IRB,IIB) PTA10520 CALL LOCATE(IFLC,FILEC,NPTR,NTPT,NYPT,IFLC,INTFB(IIB),ITRKC,IRC, PTA10530 * IIC) PTA10540 K=INTFB(IIB+1) PTA10550 C PTA10560 IF(WATE(K,1).EQ.0.0 .OR. WATE(K,2).EQ.0.0) GO TO 155 PTA10570 C PTA10580 FILEC(IRC+1)= FILEB(IRB+2) PTA10590 ICX=ICX+1 PTA10600 ICY=ICY+1 PTA10610 GO TO 160 PTA10620 C PTA10630 155 INTFC(IIC+1)=-IABS(INTFC(IIC+1)) PTA10640 C PTA10650 160 CONTINUE PTA10660 C PTA10670 IF(NTRK(IFLC).NE.0) CALL BPUT(IFLC,ITRKC,FILEC,NPTR) PTA10680 GO TO 270 PTA10690 C PTA10700 C SET UP (IFLL)=(A22), (NFL4)=(B2), (NFL5)=(A12)T PTA10710 C PTA10720 210 CALL OPEN(NFL4,NNUPR,NYNUP) PTA10730 CALL OPEN(NFL5,NFTFR,NYFTF) PTA10740 C PTA10750 NYL=NUP*(NUP+1)/2 PTA10760 LPT=0 PTA10770 IR4=-NYNUP PTA10780 II4=-IYNUP PTA10790 C PTA10800 MPT=0 PTA10810 IR5=-NYFTF PTA10820 II5=-IYFTF PTA10830 C PTA10840 IGA=0 PTA10850 ITRKE=0 PTA10860 ITRKL=0 PTA10870 C PTA10880 DO 240 KPT=1,NPTU PTA10890 C PTA10900 CALL LOCATE(IFLL,FILEB,NPTRL,NTPTL,NYPTL,IFLL,KPT,ITRKL,IRB,IIB) PTA10910 MULT=INTFB(IIB+1)-(INTFB(IIB+1)/1000)*1000 PTA10920 C PTA10930 CALL APUT(NFL4, ETE, NNUPR, LPT,1, 0,0, IR4,II4) PTA10940 LPT=LPT+1 PTA10950 IR4=IR4+NYNUP PTA10960 C PTA10970 CALL RCLEAR(FILEB,NPTRL,IRB+4,NYL) PTA10980 CALL RCLEAR(ETE, NNUPR,IR4+1,NYNUP) PTA10990 C PTA11000 DO 240 IPT=1,MULT PTA11010 C PTA11020 CALL BRING(IFLA,FILEA,NPTR,NYPT,IGA,0,ITRKA,NRA,IPA,IRA,IIA) PTA11030 CALL LOCATE(IFLE,FILEE,NPHRE,NTPHE,NYPHE,0,INTFA(IIA+1),ITRKE,IRE,PTA11040 * IIE)PTA11050 C PTA11060 CALL APUT(NFL5, FTF, NFTFR, MPT,1, 0,0, IR5,II5) PTA11070 MPT=MPT+1 PTA11080 IR5=IR5+NYFTF PTA11090 C PTA11100 IF(IDIST.EQ.0) CALL SETAND(FILEA,IRA,FILEB,IRB,FILEE,IRE,A,1, PTA11110 * NU0NUP,NULIST,NPTDIM,NPTDIM,NPHDIM) PTA11120 IF(IDIST.NE.0) CALL SETADS(FILEA,IRA,FILEB,IRB,FILEE,IRE,A,Q,R,1, PTA11130 * NU0NUP,NULIST,NPTDIM,NPTDIM,NPHDIM) PTA11140 C PTA11150 IS0=3 PTA11160 CALL ATPAW(IS0,NUP,IDIST,A,NU0,NW,P,R,FILEB,IRB,ETE,IR4, PTA11170 * NPTDIM,NOIDIM) PTA11180 C PTA11190 CALL ATPAN(NU0,NUP,IDIST,A,P,R,FTF,IR5,NORDIM) PTA11200 C PTA11210 240 CONTINUE PTA11220 C PTA11230 CALL ACLOSE(NFL4, ETE, NNUPR,LPT) PTA11240 CALL ACLOSE(NFL5, FTF, NFTFR,MPT) PTA11250 C PTA11260 C H/V CONTROL RESTRAINTS PTA11270 C PTA11280 ITRK4=0 PTA11290 ICX=0 PTA11300 ICY=0 PTA11310 ICZ=0 PTA11320 ICT=0 PTA11330 C PTA11340 IF(IXX.EQ.3 .AND. IYY.EQ.3) GO TO 260 PTA11350 C PTA11360 C HORIZONTAL CONTROLS PTA11370 C PTA11380 IGF=0 PTA11390 KHO=NREC(IFLF) PTA11400 C PTA11410 DO 255 KPT=1,KHO PTA11420 C PTA11430 CALL BRING(IFLF,FILEC,NHOR,NYHO,IGF,0,ITRKF,NRF,IPF,IRC,IIC) PTA11440 C PTA11450 K=INTFC(IIC+1) PTA11460 IF(WATE(K,5).EQ.0.0) GO TO 255 PTA11470 C PTA11480 LOC=INTFC(IIC) PTA11490 CALL LOCATE(IFLL,FILEB,NPTRL,NTPTL,NYPTL,IFLL,LOC,ITRKL,IRB,IIB) PTA11500 CALL LOCATE(NFL4, ETE, NNUPR,NTNUP,NYNUP,NFL4,LOC,ITRK4,IR4,II4) PTA11510 ICT=ICT+1 PTA11520 C PTA11530 IF(IXX.EQ.3) GO TO 245 PTA11540 FILEB(IRB+IXX)=FILEB(IRB+IXX)+WATE(K,1) PTA11550 ETE(IR4)=ETE(IR4)-(FILEC(IRC+2)-FILEB(IRB+1))*WATE(K,1) PTA00020 ICX=ICX+1 PTA00030 C PTA00040 245 IF(IYY.EQ.3) GO TO 250 PTA00050 IF(WATE(K,2).EQ.0.0) GO TO 250 PTA00060 FILEB(IRB+IYY)=FILEB(IRB+IYY)+WATE(K,2) PTA00070 ETE(IR4+IY)=ETE(IR4+IY)-(FILEC(IRC+3)-FILEB(IRB+2))*WATE(K,2) PTA00080 ICY=ICY+1 PTA00090 C PTA00100 250 IF(WATE(K,4).EQ.0.0) GO TO 255 PTA00110 IF(IXY.EQ.3) GO TO 255 PTA00120 FILEB(IRB+IXY)=FILEB(IRB+IXY)+WATE(K,4) PTA00130 ETE(IR4)=ETE(IR4)-(FILEC(IRC+3)-FILEB(IRB+2))*WATE(K,4) PTA00140 ETE(IR4+IY)=ETE(IR4+IY)-(FILEC(IRC+2)-FILEB(IRB+1))*WATE(K,4) PTA00150 C PTA00160 255 CONTINUE PTA00170 C PTA00180 260 IF(IZZ.EQ.3) GO TO 270 PTA00190 C PTA00200 C VERTICAL CONTROLS PTA00210 C PTA00220 IGG=0 PTA00230 KVE=NREC(IFLG) PTA00240 C PTA00250 DO 265 KPT=1,KVE PTA00260 C PTA00270 CALL BRING(IFLG,FILEC,NVER,NYVE,IGG,0,ITRKG,NRG,IPG,IRC,IIC) PTA00280 K=INTFC(IIC+1) PTA00290 IF(WATE(K,5).EQ.0.0) GO TO 265 PTA00300 C PTA00310 LOC=INTFC(IIC) PTA00320 CALL LOCATE(IFLL,FILEB,NPTRL,NTPTL,NYPTL,IFLL,LOC,ITRKL,IRB,IIB) PTA00330 CALL LOCATE(NFL4, ETE, NNUPR,NTNUP,NYNUP,NFL4,LOC,ITRK4,IR4,II4) PTA00340 ICT=ICT+1 PTA00350 C PTA00360 IF(WATE(K,3).EQ.0.0) GO TO 265 PTA00370 FILEB(IRB+IZZ)=FILEB(IRB+IZZ)+WATE(K,3) PTA00380 ETE(IR4+IZ)=ETE(IR4+IZ)-(FILEC(IRC+2)-FILEB(IRB+3))*WATE(K,3) PTA00390 ICZ=ICZ+1 PTA00400 C PTA00410 265 CONTINUE PTA00420 C PTA00430 270 JERR=0 PTA00440 IF(ICX.GE.2) GO TO 275 PTA00450 WRITE(IPR,5102) PTA00460 JERR=1 PTA00470 275 IF(ICY.GE.2) GO TO 280 PTA00480 IF(JERR.EQ.0) WRITE(IPR,2) PTA00490 WRITE(IPR,5103) PTA00500 JERR=1 PTA00510 C PTA00520 280 IF(ITER.EQ.0) GO TO 300 PTA00530 C PTA00540 IF(ICZ.GE.3) GO TO 285 PTA00550 IF(JERR.EQ.0) WRITE(IPR,2) PTA00560 WRITE(IPR,5104) PTA00570 C PTA00580 285 IF(NTRK(IFLL).NE.0) CALL BPUT(IFLL,ITRKL,FILEB,NPTRL) PTA00590 IF(ICT.EQ.0) GO TO 290 PTA00600 IF(NTRK(NFL4).NE.0) CALL BPUT(NFL4,ITRK4, ETE, NNUPR) PTA00610 C PTA00620 C INVERT (A22) PTA00630 C PTA00640 290 IGL=0 PTA00650 C PTA00660 DO 295 KPT=1,NPTU PTA00670 CALL BRING(IFLL,FILEB,NPTRL,NYPTL,IGL,IFLL,ITRKL,NRL,IPL,IRB,IIB) PTA00680 295 CONTINUE PTA00690 C PTA00700 IF(ITRKL.EQ.NTRK(IFLL)) CALL BPUT(IFLL,ITRKL,FILEB,NPTRL) PTA00710 C PTA00720 C SET UP REDUCED NORMAL EQUATION MATRIX PTA00730 C PTA00740 300 CALL OPEN(NFL1,NDAGR,NYDAG) PTA00750 CALL OPEN(NFL3,NCTLR,NYCTL) PTA00760 IF(NUP.NE.0) CALL OPEN(NFL2,NOFFR,NYOFF) PTA00770 C PTA00780 IGE=0 PTA00790 IGI=0 PTA00800 ITRKA=0 PTA00810 ITRKB=0 PTA00820 ITRKC=0 PTA00830 ITRKD=0 PTA00840 ITRKL=0 PTA00850 ITRK4=0 PTA00860 ITRK5=0 PTA00870 C PTA00880 KPH=0 PTA00890 IPH=0 PTA00900 JPH=0 PTA00910 MPH=0 PTA00920 IA=-NYDAG PTA00930 ID=-NYCTL PTA00940 IUSED=0 PTA00950 C PTA00960 310 KPH=KPH+1 PTA00970 C PTA00980 IF(ITER.EQ.0) GO TO 315 PTA00990 CALL BRING(IFLE,FILEE,NPHRE,NYPHE,IGE,0,ITRKE,NRE,IPE,IRE,IIE) PTA01000 CALL BRING(IFLI,FILED,NPHRI,NYPHI,IGI,0,ITRKI,NRI,IPI,IRD,IID) PTA01010 ISPT=INTFE(IIE+2)-1 PTA01020 IEPT=ISPT+INTFE(IIE+1) PTA01030 IPHSTA=INTFE(IIE+3) PTA01040 GO TO 320 PTA01050 C PTA01060 315 CALL LOCATE(IFLD,FILED,NPHR,NTPH,NYPH,0,KPH,ITRKD,IRD,IID) PTA01070 CALL BRING(IFLI,FILEE,NPHRI,NYPHI,IGI,0,ITRKI,NRE,IPE,IRE,IIE) PTA01080 ISPT=INTFD(IID+2)-1 PTA01090 IEPT=ISPT+INTFD(IID+1) PTA01100 IPHSTA=INTFD(IID+3) PTA01110 X0=FILED(IRD+2) PTA01120 Y0=FILED(IRD+3) PTA01130 C PTA01140 320 CALL APUT(NFL1,ATA,NDAGR,IPH,1, 0,0, IA,II) PTA01150 IPH=IPH+1 PTA01160 IA=IA+NYDAG PTA01170 CALL RCLEAR(ATA,NDAGR,IA+1,NYDAG) PTA01180 C PTA01190 CALL APUT(NFL3,DTD,NCTLR,MPH,1, 0,0, ID,KK) PTA01200 MPH=MPH+1 PTA01210 ID=ID+NYCTL PTA01220 CALL RCLEAR(DTD,NCTLR,ID+1,NYCTL) PTA01230 C PTA01240 IEND=1 PTA01250 IF(ITER.EQ.0) NOFF=INTFE(IIE) PTA01260 IF(ITER.NE.0) NOFF=INTFD(IID) PTA01270 IF(NUP.EQ.0 .OR. NOFF.EQ.0) GO TO 370 PTA01280 C PTA01290 IF(IUSED.LT.NOFFR) GO TO 325 PTA01300 CALL APUT(NFL2,BTB,NOFFR,JPH,1, 0,0, JB,JJ) PTA01310 IUSED=0 PTA01320 C PTA01330 325 NEED=NYOFF*NOFF PTA01340 LEFT=IUSED+NEED-NOFFR PTA01350 C PTA01360 IF(LEFT.LE.0) GO TO 350 PTA01370 C PTA01380 CALL DIRECT(NOFF,NTOFF,NUT,LUT,JS,JE) PTA01390 KS=1-LUT PTA01400 KE=0 PTA01410 C PTA01420 330 IF(NUT.EQ.0) GO TO 335 PTA01430 IEND=0 PTA01440 NUT=NUT-1 PTA01450 KS=KS+LUT PTA01460 KE=KE+LUT PTA01470 GO TO 340 PTA01480 C PTA01490 335 IEND=1 PTA01500 KS=JS PTA01510 KE=JE PTA01520 C PTA01530 340 IF(IUSED.LT.NOFFR) GO TO 345 PTA01540 CALL APUT(NFL2,BTB,NOFFR,JPH,1, 0,0, JB,JJ) PTA01550 IUSED=0 PTA01560 C PTA01570 345 NEED=NYOFF*(KE-KS+1) PTA01580 LEFT=IUSED+NEED-NOFFR PTA01590 IF(LEFT.LE.0) GO TO 355 PTA01600 CALL RCLEAR(CTC,NOFFR,1,NEED) PTA01610 IS=-NYOFF PTA01620 GO TO 360 PTA01630 C PTA01640 350 KS=1 PTA01650 KE=NOFF PTA01660 C PTA01670 355 CALL RCLEAR(BTB,NOFFR,IUSED+1,NEED) PTA01680 IS=IUSED-NYOFF PTA01690 C PTA01700 360 IF(ITER.EQ.0) GO TO 365 PTA01710 LOW=IABS(INTFD(IID+KS))-IPHSTA PTA01720 IHI=IABS(INTFD(IID+KE))-IPHSTA PTA01730 GO TO 370 PTA01740 C PTA01750 365 LOW=IABS(INTFE(IIE+KS))-IPHSTA PTA01760 IHI=IABS(INTFE(IIE+KE))-IPHSTA PTA01770 C PTA01780 370 KPT=ISPT PTA01790 C PTA01800 400 KPT=KPT+1 PTA01810 C PTA01820 C SET UP (NFL1)=(A11) : DIAGONAL SUBMATRICES (UPPER TRIANGLE ZONE ONLY) PTA01830 C (NFL3)=(B1) : CONSTANT VECTOR PTA01840 C PTA01850 CALL LOCATE(IFLB,FILEB,NPTR,NTPT,NYPT,0,KPT,ITRKB,IRB,IIB) PTA01860 MULT=INTFB(IIB+2) PTA01870 C PTA01880 IF(ITER.NE.0) GO TO 405 PTA01890 C PTA01900 X=FILEB(IRB+2)-X0 PTA01910 Y=FILEB(IRB+3)-Y0 PTA01920 AM=DFLOAT(MULT) PTA01930 ICT=INTFB(IIB+3)/1000 PTA01940 IF(ICT.GE.2) AM=AM+1.D0 PTA01950 AM=1.D0/AM PTA01960 C PTA01970 IF(IEND.EQ.0) GO TO 415 PTA01980 EM=1.D0-AM PTA01990 XEM=X*EM PTA02000 YEM=Y*EM PTA02010 C PTA02020 ATA(IA+1)=ATA(IA+1)+X*XEM+Y*YEM PTA02030 ATA(IA+4)=ATA(IA+4)+XEM PTA02040 ATA(IA+6)=ATA(IA+6)+EM PTA02050 ATA(IA+7)=ATA(IA+7)+YEM PTA02060 C PTA02070 IF(ICT.LE.1) GO TO 415 PTA02080 C PTA02090 CALL LOCATE(IFLC,FILEC,NPTR,NTPT,NYPT,0,INTFB(IIB),ITRKC,IRC,IIC) PTA02100 C PTA02110 IF(INTFC(IIC+1).LT.0) GO TO 415 PTA02120 XGAM=FILEC(IRC+1)*AM PTA02130 YGAM=FILEC(IRC+2)*AM PTA02140 C PTA02150 DTD(ID+1)=DTD(ID+1)+X*XGAM+Y*YGAM PTA02160 DTD(ID+2)=DTD(ID+2)-Y*XGAM+X*YGAM PTA02170 DTD(ID+3)=DTD(ID+3)+XGAM PTA02180 DTD(ID+4)=DTD(ID+4)+YGAM PTA02190 GO TO 415 PTA02200 C PTA02210 405 CALL LOCATE(IFLL,FILEA,NPTRL,NTPTL,NYPTL,0,INTFB(IIB),ITRKL,IRA, PTA02220 * IIA) PTA02230 C PTA02240 IF(IDIST.EQ.0) CALL SETAND(FILEB,IRB,FILEA,IRA,FILEE,IRE,A,IEND, PTA02250 * NU0NUP,NULIST,NPTDIM,NPTDIM,NPHDIM) PTA02260 IF(IDIST.NE.0) CALL SETADS(FILEB,IRB,FILEA,IRA,FILEE,IRE,A,Q,R, PTA02270 * IEND,NU0NUP,NULIST,NPTDIM,NPTDIM,NPHDIM) PTA02280 C PTA02290 IF(IEND.EQ.0) GO TO 410 PTA02300 C PTA02310 IS0=0 PTA02320 CALL ATPAW(IS0,NU0,IDIST,A,0,NW,P,R,ATA,IA,DTD,ID,NORDIM,NOIDIM) PTA02330 C PTA02340 410 IF(NUP.EQ.0) GO TO 455 PTA02350 C PTA02360 CALL ATPAN(NU0,NUP,IDIST,A,P,R,TEMPB,0,48) PTA02370 CALL A12A22(TEMPB,FILEA,IRA+4,NU0,NUP,TEMPA,NPTDIM) PTA02380 C PTA02390 IF(IEND.EQ.0) GO TO 415 PTA02400 C PTA02410 CALL ACCXXT(TEMPA,TEMPB,NU0,NUP,ATA,IA,NORDIM) PTA02420 CALL LOCATE(NFL4,ETE,NNUPR,NTNUP,NYNUP,0,INTFB(IIB),ITRK4,IR4,II4)PTA02430 CALL ACCXV(TEMPA,1,ETE,IR4,NU0,NUP,DTD,ID+1,48,NOIDIM) PTA02440 C PTA02450 415 IF(NOFF.EQ.0) GO TO 455 PTA02460 C PTA02470 C SET UP (NFL2)=(A12) : OFF-DIAGONAL SUBMATRICES (RECTANGULAR ZONE) PTA02480 C PTA02490 LOC=INTFB(IIB+1) PTA02500 C PTA02510 DO 450 I=1,MULT PTA02520 C PTA02530 MOC=LOC+I-1 PTA02540 C PTA02550 IF(ITER.EQ.0) GO TO 430 PTA02560 C PTA02570 CALL LOCATE(IFLC,FILEC,NPTRC,NTPTC,NYPTC,0,MOC,ITRKC,IRC,IIC) PTA02580 LPH=INTFC(IIC+1) PTA02590 C PTA02600 IF(LPH.GT.IHI) GO TO 455 PTA02610 IF(LPH.LT.LOW) GO TO 450 PTA02620 C PTA02630 DO 420 J=KS,KE PTA02640 IF(LPH+IPHSTA.EQ.INTFD(IID+J)) GO TO 425 PTA02650 420 CONTINUE PTA02660 GO TO 450 PTA02670 C PTA02680 425 CALL LOCATE(NFL5,FTF,NFTFR,NTFTF,NYFTF,0,MOC,ITRK5,IR5,II5) PTA02690 C PTA02700 IB=IS+NYOFF*(J-KS+1) PTA02710 C PTA02720 IF(LEFT.LE.0) CALL ACCXYT(FTF,IR5,TEMPA,NU0,NUP,BTB,IB,NORDIM) PTA02730 IF(LEFT.GT.0) CALL ACCXYT(FTF,IR5,TEMPA,NU0,NUP,CTC,IB,NORDIM) PTA02740 GO TO 450 PTA02750 C PTA02760 430 CALL LOCATE(IFLA,FILEA,NPTR,NTPT,NYPT,0,MOC,ITRKA,IRA,IIA) PTA02770 LPH=INTFA(IIA+1) PTA02780 C PTA02790 IF(LPH.GT.IHI) GO TO 455 PTA02800 IF(LPH.LT.LOW) GO TO 450 PTA02810 C PTA02820 DO 435 J=KS,KE PTA02830 IF(LPH+IPHSTA.EQ.INTFE(IIE+J)) GO TO 440 PTA02840 435 CONTINUE PTA02850 GO TO 450 PTA02860 C PTA02870 440 CALL LOCATE(IFLD,FILED,NPHR,NTPH,NYPH,0,LPH,ITRKD,IRD,IID) PTA02880 C PTA02890 IB=IS+NYOFF*(J-KS+1) PTA02900 C PTA02910 S=FILEA(IRA+2)-FILED(IRD+2) PTA02920 T=FILEA(IRA+3)-FILED(IRD+3) PTA02930 AAM=S*AM PTA02940 BAM=T*AM PTA02950 XAM=X*AM PTA02960 YAM=Y*AM PTA02970 C PTA02980 IF(LEFT.GT.0) GO TO 445 PTA02990 BTB(IB+1)=BTB(IB+1)-S*XAM-T*YAM PTA03000 BTB(IB+2)=BTB(IB+2)-S*YAM+T*XAM PTA03010 BTB(IB+3)=BTB(IB+3)-XAM PTA03020 BTB(IB+4)=BTB(IB+4)-YAM PTA03030 BTB(IB+9)=BTB(IB+9)-AAM PTA03040 BTB(IB+10)=BTB(IB+10)+BAM PTA03050 BTB(IB+11)=BTB(IB+11)-AM PTA03060 GO TO 450 PTA03070 445 CTC(IB+1)=CTC(IB+1)-S*XAM-T*YAM PTA03080 CTC(IB+2)=CTC(IB+2)-S*YAM+T*XAM PTA03090 CTC(IB+3)=CTC(IB+3)-XAM PTA03100 CTC(IB+4)=CTC(IB+4)-YAM PTA03110 CTC(IB+9)=CTC(IB+9)-AAM PTA03120 CTC(IB+10)=CTC(IB+10)+BAM PTA03130 CTC(IB+11)=CTC(IB+11)-AM PTA03140 C PTA03150 450 CONTINUE PTA03160 C PTA03170 455 IF(KPT.NE.IEPT) GO TO 400 PTA03180 C PTA03190 IF(NOFF.EQ.0) GO TO 493 PTA03200 C PTA03210 IF(ITER.NE.0) IS=IS+NYOFF*(KE-KS+1) PTA03220 C PTA03230 IF(LEFT.GT.0) GO TO 470 PTA03240 C PTA03250 IF(ITER.NE.0) GO TO 465 PTA03260 C PTA03270 DO 460 I=KS,KE PTA03280 IS=IS+NYOFF PTA03290 BTB(IS+5)=-BTB(IS+2) PTA03300 BTB(IS+6)= BTB(IS+1) PTA03310 BTB(IS+7)=-BTB(IS+4) PTA03320 BTB(IS+8)= BTB(IS+3) PTA03330 BTB(IS+13)=-BTB(IS+10) PTA03340 BTB(IS+14)= BTB(IS+9) PTA03350 460 BTB(IS+16)= BTB(IS+11) PTA03360 C PTA03370 465 JPH=JPH+KE-KS+1 PTA03380 IUSED=IUSED+NEED PTA03390 GO TO 490 PTA03400 C PTA03410 470 IF(ITER.NE.0) GO TO 480 PTA03420 C PTA03430 DO 475 I=KS,KE PTA03440 IS=IS+NYOFF PTA03450 CTC(IS+5)=-CTC(IS+2) PTA03460 CTC(IS+6)= CTC(IS+1) PTA03470 CTC(IS+7)=-CTC(IS+4) PTA03480 CTC(IS+8)= CTC(IS+3) PTA03490 CTC(IS+13)=-CTC(IS+10) PTA03500 CTC(IS+14)= CTC(IS+9) PTA03510 475 CTC(IS+16)= CTC(IS+11) PTA03520 C PTA03530 480 IFILL=NEED-LEFT PTA03540 DO 485 I=1,IFILL PTA03550 485 BTB(IUSED+I)=CTC(I) PTA03560 JPH=NTOFF PTA03570 CALL APUT(NFL2,BTB,NOFFR,JPH,1, 0,0, JB,JJ) PTA03580 DO 487 I=1,LEFT PTA03590 487 BTB(I)=CTC(IFILL+I) PTA03600 JPH=LEFT/NYOFF PTA03610 IUSED=LEFT PTA03620 C PTA03630 490 IF(IEND.EQ.0) GO TO 330 PTA03640 C PTA03650 493 IF(ITER.NE.0) GO TO 495 PTA03660 C PTA03670 ATA(IA+3)=ATA(IA+1) PTA03680 ATA(IA+5)=-ATA(IA+7) PTA03690 ATA(IA+8)=ATA(IA+4) PTA03700 ATA(IA+10)=ATA(IA+6) PTA03710 C PTA03720 495 IF(KPH.NE.NACCPH) GO TO 310 PTA03730 C PTA03740 CALL ACLOSE(NFL1,ATA,NDAGR,IPH) PTA03750 CALL ACLOSE(NFL3,DTD,NCTLR,MPH) PTA03760 IF(NUP.NE.0) CALL ACLOSE(NFL2,BTB,NOFFR,JPH) PTA03770 IF(ITER.EQ.0) CALL STORE(IFLC,FILEC,NPTR) PTA03780 IF(ITER.NE.0 .AND. NUP.NE.0) CALL STORE(NFL4,ETE,NNUPR) PTA03790 C PTA03800 C SOLUTION OF REDUCED NORMAL EQUATIONS FOR (X1) PTA03810 C PTA03820 CALL SOLVE(NU0,NUP,NACCPH,ATA,BTB,CTC,DTD,ETE,FILEB,FILEC,FILED, PTA03830 * FILEE,INTFD,INTFE,INTCTC,NORDIM,NOIDIM,NPTDIM,NPHDIM, PTA03840 * IPHDIM,IORDIM) PTA03850 C PTA03860 C SOLVE (X2) BY BACK SUBSTITUTION OF (A12)T AND (X1) PTA03870 C PTA03880 IF(ITER.NE.0) GO TO 600 PTA03890 C PTA03900 C PREPARE WORK FILES FOR SUBSEQUENT ITERATION STEPS PTA03910 C PTA03920 C SET UP (IFLL)=(UNKNOWN OBJECT POINT COORDINATES) PTA03930 C PTA03940 CALL OPEN(IFLL,NPTRL,NYPTL) PTA03950 MPT=0 PTA03960 IRB=1-NYPTL PTA03970 IIB=1-IYPTL PTA03980 C PTA03990 KPT=NPTU PTA04000 IGA=0 PTA04010 IGC=0 PTA04020 ITRKD=0 PTA04030 ITRK3=0 PTA04040 C PTA04050 DO 520 I=1,2 PTA04060 520 ATA(I)=0.0 PTA04070 C PTA04080 530 CALL BRING(IFLC,FILEC,NPTR,NYPT,IGC, 0,ITRKC,NRC,IPC,IRC,IIC) PTA04090 C PTA04100 KPT=KPT-1 PTA04110 MULT=IABS(INTFC(IIC+1)) PTA04120 ICT=MULT/1000 PTA04130 IF(ICT.GE.1) MULT=MULT-ICT*1000 PTA04140 LPT=MULT PTA04150 IF(ICT.GE.2 .AND. INTFC(IIC+1).GT.0) MULT=MULT+1 PTA04160 AM=1.D0/DFLOAT(MULT) PTA04170 INTFC(IIC+1)=IABS(INTFC(IIC+1)) PTA04180 C PTA04190 CALL APUT(IFLL,FILEB,NPTRL, MPT,1, 1,1, IRB,IIB) PTA04200 MPT=MPT+1 PTA04210 IRB=IRB+NYPTL PTA04220 C PTA04230 540 CALL BRING(IFLA,FILEA,NPTR,NYPT,IGA,0,ITRKA,NRA,IPA,IRA,IIA) PTA04240 C PTA04260 LPT=LPT-1 PTA04250 CALL LOCATE(IFLD,FILED,NPHR,NTPH,NYPH,0,INTFA(IIA+1),ITRKD,IRD,IIDPTA04270 * )PTA04280 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,0,INTFA(IIA+1),ITRK3,IR3, PTA04290 * II3)PTA04300 X=FILEA(IRA+2)-FILED(IRD+2) PTA04310 Y=FILEA(IRA+3)-FILED(IRD+3) PTA04320 FILEC(IRC+1)=FILEC(IRC+1)+X*DTD(IR3)-Y*DTD(IR3+1)+DTD(IR3+2) PTA04330 FILEC(IRC+2)=FILEC(IRC+2)+Y*DTD(IR3)+X*DTD(IR3+1)+DTD(IR3+3) PTA04340 C PTA04350 IF(LPT.NE.0) GO TO 540 PTA04360 C PTA04370 FILEB(IRB)=FILEC(IRC) PTA04380 DO 545 I=1,2 PTA04390 FILEB(IRB+I)=FILEC(IRC+I)*AM PTA04400 IF(DABS(FILEB(IRB+I)).GE.DABS(ATA(I))) ATA(I)=FILEB(IRB+I) PTA04410 545 CONTINUE PTA04420 FILEB(IRB+3)=FILEC(IRC+3) PTA04430 C PTA04440 IF(KPT.NE.0) GO TO 530 PTA04450 C PTA04460 CALL ACLOSE(IFLL,FILEB,NPTRL,MPT) PTA04470 CALL STORE(IFLL,FILEB,NPTRL) PTA04480 C PTA04490 C SET UP (FILEC)=(POINT-PHOTO ADDRESS ON FILEA) PTA04500 C PTA04510 NYPTC=1 PTA04520 CALL SETDIM(NPTDIM,NYPTC, NPTRC,NTPTC,IPTRC,IYPTC) PTA04530 C PTA04540 CALL OPEN(IFLC,NPTRC,NYPTC) PTA04550 C PTA04560 IGA=0 PTA04570 IPT=0 PTA04580 IRC=1-NYPTC PTA04590 IIC=1-ITPTC PTA04600 C PTA04610 DO 550 I=1,NACCPT PTA04620 C PTA04630 CALL BRING(IFLA,FILEA,NPTR,NYPT,IGA,0,ITRKA,NRA,IPA,IRA,IIA) PTA04640 C PTA04650 CALL APUT(IFLC,FILEC,NPTRC, IPT,1, 1,1, IRC,IIC) PTA04660 IPT=IPT+1 PTA04670 IRC=IRC+NYPTC PTA04680 C PTA04690 FILEC(IRC)=FILEA(IRA) PTA04700 C PTA04710 550 CONTINUE PTA04720 C PTA04730 CALL ACLOSE(IFLC,FILEC,NPTRC,IPT) PTA04740 C PTA04750 C SET UP (FILEE)=(APPROXIMATED PHOTO ORIENTATION DATA) PTA04760 C PTA04770 CALL SETDIM(NPHDIM,NYPHE, NPHRE,NTPHE,IPHRE,IYPHE) PTA04780 CALL OPEN(IFLE,NPHRE,NYPHE) PTA04790 C PTA04800 IGD=0 PTA04810 IG3=0 PTA04820 IPH=0 PTA04830 IRE=1-NYPHE PTA04840 IIE=1-IYPHE PTA04850 C PTA04860 DO 555 I=1,4 PTA04870 555 SUBA(I)=0.0 PTA04880 C PTA04890 DO 570 KPH=1,NACCPH PTA04900 C PTA04910 CALL BRING(IFLD,FILED,NPHR,NYPH,IGD,0,ITRKD,NRD,IPD,IRD,IID) PTA04920 CALL BRING(NFL3,DTD,NCTLR,NYCTL,IG3,0,ITRK3,NR3,IP3,IR3,II3) PTA04930 C PTA04940 CALL APUT(IFLE,FILEE,NPHRE, IPH,1, 1,1, IRE,IIE) PTA04950 IPH=IPH+1 PTA04960 IRE=IRE+NYPHE PTA04970 IIE=IIE+IYPHE PTA04980 C PTA04990 FILEE(IRE)=FILED(IRD) PTA05000 FILEE(IRE+1)=FILED(IRD+1) PTA05010 C PTA05020 FILEE(IRE+2)=DTD(IR3+2) PTA05030 FILEE(IRE+3)=DTD(IR3+3) PTA05040 SCALE=DSQRT(DTD(IR3)**2+DTD(IR3+1)**2) PTA05050 FILEE(IRE+4)=FILED(IRD+4)*SCALE PTA05060 C PTA05070 FILEE(IRE+5)=0.0 PTA05080 FILEE(IRE+6)=0.0 PTA05090 FILEE(IRE+7)=DARSIN(DTD(IR3+1)/SCALE) PTA05100 C PTA05110 CALL ROTMAT(FILEE,IRE,NPHRE) PTA05120 C PTA05130 FILEE(IRE+26)=FILED(IRD+2) PTA05140 FILEE(IRE+27)=FILED(IRD+3) PTA05150 FILEE(IRE+28)=FILED(IRD+4) PTA05160 C PTA05170 DO 560 I=29,35 PTA05180 560 FILEE(IRE+I)=0.0 PTA05190 C PTA05200 DO 565 J=2,3 PTA05210 IF(DABS(FILEE(IRE+J)).GE.DABS(SUBA(J-1))) SUBA(J-1)=FILEE(IRE+J) PTA05220 565 CONTINUE PTA05230 IF(DABS(FILEE(IRE+7)).GE.DABS(SUBA(3))) SUBA(3)=FILEE(IRE+7) PTA05240 IF(SCALE.GE.SUBA(4)) SUBA(4)=SCALE PTA05250 C PTA05260 570 CONTINUE PTA05270 C PTA05280 CALL ACLOSE(IFLE,FILEE,NPHRE,IPH) PTA05290 C PTA05300 CALL STORE(IFLA,FILEA,NPTR) PTA05310 CALL STORE(IFLC,FILEC,NPTRC) PTA05320 CALL STORE(IFLE,FILEE,NPHRE) PTA05330 C PTA05340 WRITE(IPR,3200) PTA05350 WRITE(IPR,3107) (SUBA(J),J=1,4) PTA05360 WRITE(IPR,3108) (ATA(J),J=1,2) PTA05370 C PTA05380 GO TO 640 PTA05390 C PTA05400 600 IPASS=1 PTA05410 IGE=0 PTA05420 IG3=0 PTA05430 C PTA05440 DO 605 I=1,NU0 PTA05450 605 SUBA(I)=0.0 PTA05460 C PTA05470 C PTA05480 DO 615 KPH=1,NACCPH PTA05490 C PTA05500 CALL BRING(NFL3,DTD,NCTLR,NYCTL,IG3,0,ITRK3,NR3,IP3,IR3,II3) PTA05510 IF(LASTIT.EQ.0) CALL BRING(IFLE,FILEE,NPHRE,NYPHE,IGE,IFLE,ITRKE, PTA05520 * NRE,IPE,IRE,IIE) PTA05530 C PTA05540 DO 610 I=1,NU0 PTA05550 K=NU11(I) PTA05560 IF(DABS(DTD(IR3+I-1)).GE.DABS(SUBA(I))) SUBA(I)=DTD(IR3+I-1) PTA05570 IF(LASTIT.EQ.0) FILEE(IRE+K)=FILEE(IRE+K)-DTD(IR3+I-1) PTA05580 610 CONTINUE PTA05590 C PTA05600 IF(LASTIT.EQ.0) CALL ROTMAT(FILEE,IRE,NPHRE) PTA05610 C PTA05620 615 CONTINUE PTA05630 C PTA05640 IF(LASTIT.EQ.0 .AND. ITRKE.EQ.NTRK(IFLE)) CALL BPUT(IFLE,ITRKE, PTA05650 * FILEE,NPHRE) PTA05660 C PTA05670 WRITE(IPR,3200) PTA05680 IE=0 PTA05690 DO 620 L=1,6 PTA05700 IF(ISET(L).EQ.0) GO TO 620 PTA05710 IS=IE+1 PTA05720 IE=IS+ISET(L)-1 PTA05730 IF(L.EQ.1) WRITE(IPR,3201) (ISET(10),NAME11(J),SUBA(J),J=IS,IE) PTA05740 IF(L.EQ.2) WRITE(IPR,3202) (ISET(10),NAME11(J),SUBA(J),J=IS,IE) PTA05750 IF(L.EQ.3) WRITE(IPR,3203) (ISET(10),NAME11(J),SUBA(J),J=IS,IE) PTA05760 IF(L.GE.4) WRITE(IPR,3204) ISET(L+3),(ISET(10),NAME11(J),SUBA(J), PTA05770 * J=IS,IE)PTA05780 620 CONTINUE PTA05790 C PTA05800 IF(NUP.EQ.0) GO TO 640 PTA05810 C PTA05820 IGC=0 PTA05830 IGL=0 PTA05840 IG4=0 PTA05850 IG5=0 PTA05860 ITRK3=0 PTA05870 C PTA05880 DO 625 I=1,NUP PTA05890 625 ATA(I)=0.0 PTA05900 C PTA05910 DO 635 KPT=1,NPTU PTA05920 C PTA05930 CALL BRING(NFL4,ETE,NNUPR,NYNUP,IG4,0,ITRK4,NR4,IP4,IR4,II4) PTA05940 CALL BRING(IFLL,FILEA,NPTRL,NYPTL,IGL,IFLL,ITRKL,NRL,IPL,IRA,IIA) PTA05950 MULT=INTFA(IIA+1)-(INTFA(IIA+1)/1000)*1000 PTA05960 C PTA05970 DO 630 LPT=1,MULT PTA05980 CALL BRING(IFLC,FILEC,NPTRC,NYPTC,IGC,0,ITRKC,NRC,IPC,IRC,IIC) PTA05990 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,0,INTFC(IIC+1),ITRK3,IR3, PTA06000 * II3) PTA06010 CALL BRING(NFL5,FTF,NFTFR,NYFTF,IG5,0,ITRK5,NR5,IP5,IR5,II5) PTA06020 CALL ACCXTV(FTF,IR5,DTD,IR3,NU0,NUP,ETE,IR4,NORDIM,NOIDIM) PTA06030 630 CONTINUE PTA06040 C PTA06050 CALL MULTXV(FILEA,IRA+4,ETE,IR4,SUBA,NUP,NPTDIM,NOIDIM) PTA06060 C PTA06070 DO 635 I=1,NUP PTA06080 K=NU22(I) PTA06090 FILEA(IRA+K)=FILEA(IRA+K)-SUBA(I) PTA06100 IF(LASTIT.NE.0) FILEA(IRA+K+3)= SUBA(I) PTA06110 IF(DABS(SUBA(I)).GE.DABS(ATA(I))) ATA(I)=SUBA(I) PTA06120 C PTA06130 635 CONTINUE PTA06140 C PTA06150 IF(ITRKL.EQ.NTRK(IFLL)) CALL BPUT(IFLL,ITRKL,FILEA,NPTRL) PTA06160 C PTA06170 WRITE(IPR,3205) (ISET(10),NAME22(J),ATA(J),J=1,NUP) PTA06180 C PTA06190 640 IGF=0 PTA06200 ITRKL=0 PTA06210 KHO=NREC(IFLF) PTA06220 IF(LASTIT.EQ.0) MFLL=0 PTA06230 IF(LASTIT.NE.0) MFLL=IFLL PTA06240 C PTA06250 DO 645 I=1,6 PTA06260 645 RMSG(I)=0.0 PTA06270 C PTA06280 DO 650 L=1,KHO PTA06290 C PTA06300 CALL BRING(IFLF,FILEB,NHOR,NYHO,IGF,0,ITRKF,NRF,IPF,IRB,IIB) PTA06310 CALL LOCATE(IFLL,FILEC,NPTRL,NTPTL,NYPTL,MFLL,INTFB(IIB),ITRKL,IRCPTA06320 * ,IIC)PTA06330 DO 647 I=1,2 PTA06340 SUBA(I)=FILEC(IRC+I)-FILEB(IRB+I+1) PTA06350 IF(DABS(SUBA(I)).LT.DABS(RMSG(I))) GO TO 647 PTA06360 RMSG(I)=SUBA(I) PTA06370 IMS(I)=INTFB(IIB+2) PTA06380 647 RMSG(I+3)=RMSG(I+3)+SUBA(I)**2 PTA06390 C PTA06400 IF(MFLL.EQ.0) GO TO 650 PTA06410 FILEC(IRC+7)=SUBA(1) PTA06420 FILEC(IRC+8)=SUBA(2) PTA06430 INTFC(IIC+1)=INTFC(IIC+1)+INTFB(IIB+1)*100000 PTA06440 650 CONTINUE PTA06450 C PTA06460 DO 655 I=1,2 PTA06470 655 RMSG(I+3)=DSQRT(RMSG(I+3)/DFLOAT(KHO)) PTA06480 C PTA06490 IGG=0 PTA06500 KVE=NREC(IFLG) PTA06510 C PTA06520 DO 660 L=1,KVE PTA06530 C PTA06540 CALL BRING(IFLG,FILEB,NVER,NYVE,IGG,0,ITRKG,NRG,IPG,IRB,IIB) PTA06550 CALL LOCATE(IFLL,FILEC,NPTRL,NTPTL,NYPTL,MFLL,INTFB(IIB),ITRKL,IRCPTA06560 * ,IIC)PTA06570 DH=FILEC(IRC+3)-FILEB(IRB+2) PTA06580 IF(DABS(DH).LT.DABS(RMSG(3))) GO TO 657 PTA06590 RMSG(3)=DH PTA06600 IMS(3)=INTFB(IIB+2) PTA06610 657 RMSG(6)=RMSG(6)+DH**2 PTA06620 C PTA06630 IF(MFLL.EQ.0) GO TO 660 PTA06640 FILEC(IRC+9)=DH PTA06650 INTFC(IIC+1)=INTFC(IIC+1)+INTFB(IIB+1)*10000 PTA06660 660 CONTINUE PTA06670 C PTA06680 IF(MFLL.NE.0.AND.NTRK(IFLL).NE.0) CALL BPUT(IFLL,ITRKL,FILEC,NPTRLPTA06690 * )PTA06700 C PTA06710 RMSG(6)=DSQRT(RMSG(6)/DFLOAT(KVE)) PTA06720 C PTA06730 WRITE(6,3206) (RMSG(J),J=1,6) PTA06740 C PTA06750 700 IF(LASTIT.EQ.0) GO TO 100 PTA06760 C PTA06770 WRITE(IPR,3207) PTA06780 IF(IPASS.NE.0) RETURN PTA06790 WRITE(IPR,5001) PTA06800 CALL ERRSTP(IPR) PTA06810 STOP PTA06820 C PTA06830 1 FORMAT(80A1) PTA06840 2 FORMAT(1H ) PTA06850 C PTA06860 3000 FORMAT(1H1,//, 5X,'UNBASC2-PROGRAM: ',20A4,'(PART-3)',/) PTA06870 C PTA06880 3101 FORMAT(1H0,/,10X,'ITERATION',I3,/,10X,'------------') PTA06890 3102 FORMAT(1H0,/,10X,'ITERATION',I3,3X,'(INITIAL APPROXIMATION STEP)',PTA06900 * /,10X,'------------') PTA06910 3103 FORMAT(1H0, 9X,'TOTAL NUMBER OF UNKNOWNS IN THIS STEP =',I6,//,13XPTA06920 * ,'UNKNOWNS FOR PHOTO ORIENTATIONS',4X,'=',I6) PTA06930 3104 FORMAT(1H ,12X,'UNKNOWNS FOR OBJECT POINTS', 9X,'=',I6) PTA06940 3105 FORMAT(1H+,57X,12A4) PTA06950 3106 FORMAT(1H+,57X,'XC YC KP SCALE') PTA06960 3107 FORMAT(1H ,12X,'PROJ. CENTER ....... DXC =',D11.5,5X,'DYC =',D11.5PTA06970 * ,/,13X,'PHOTO TILT ......... DKP =',D11.5, /,13X,'SCALE FA'PTA06980 * ,'CTOR ....... DSC =',D11.5) PTA06990 3108 FORMAT(1H ,12X,'OBJECT POINT ....... DX =',D11.5,5X,'DY =',D11.5PTA07000 * )PTA07010 3109 FORMAT(1H+,57X,'X Y') PTA07020 C PTA07030 3200 FORMAT(1H0, 9X,'MAXIMUM CORRECTION VALUES:',/) PTA07040 3201 FORMAT(1H ,12X,'PROJ. CENTER ....... ',3(A1,A3,'=',D11.5,5X)) PTA07050 3202 FORMAT(1H ,12X,'PHOTO TILT ......... ',3(A1,A3,'=',D11.5,5X)) PTA07060 3203 FORMAT(1H ,12X,'INT. ORIENTATION ... ',3(A1,A3,'=',D11.5,5X)) PTA07070 3204 FORMAT(1H ,12X,A3,'. DISTORTION .... ',3(A1,A3,'=',D11.5,5X)) PTA07080 3205 FORMAT(1H ,12X,'OBJECT POINT ....... ',3(A1,A3,'=',D11.5,5X)) PTA07090 3206 FORMAT(1H0, 9X,'DEVIATION FROM CONTROL COORDINATES',//,13X, PTA07100 * 'MAX. X =',F12.5,3X,'MAX. Y =',F12.5,3X,'MAX. Z =',F12.5,/,PTA07110 * 13X,'RMS. X =',F12.5,3X,'RMS. Y =',F12.5,3X,'RMS. Z =',F12.5) PTA07120 3207 FORMAT(1H0,/,10X,'END OF BUNDLE ADJUSTMENT',/,10X,'--------------'PTA07130 * ,'----------') PTA07140 C PTA07150 5001 FORMAT(1H0, 9X,'***(ERROR)*** ITERATIVE SOLUTION IS INCOMPLETE') PTA07160 C PTA07170 5101 FORMAT(1H0, 9X,'***(WARNING)*** NO UNKNOWN PARAMETERS FOR PHOTO O'PTA07180 * ,'RIENTATIONS',/,26X,'THIS STEP IS BYPASSED') PTA07190 5102 FORMAT(1H0, 9X,'***(WARNING)*** INSUFFICIENT CONTROL RESTRAINTS I'PTA07200 * ,'N X') PTA07210 5103 FORMAT(1H , 9X,'***(WARNING)*** INSUFFICIENT CONTROL RESTRAINTS I'PTA07220 * ,'N Y') PTA07230 5104 FORMAT(1H , 9X,'***(WARNING)*** INSUFFICIENT CONTROL RESTRAINTS I'PTA07240 * ,'N Z') PTA07250 C PTA07260 END PTA07270 SUBROUTINE OUTPUT(FILEA,FILEB,FILEC,FILED,FILEE,INTFA,INTFB,INTFC,PTA00010 * INTFD,INTFE,ATA,BTB,CTC,DTD,ETE,FTF,INTCTC, PTA00020 * NPTDIM,IPTDIM,NPHDIM,IPHDIM,NORDIM,NOIDIM,IORDIMPTA00030 * )PTA00040 IMPLICIT REAL*8(A-H,O-Z) PTA00050 C PTA00060 DIMENSION FILEA(NPTDIM),FILEB(NPTDIM),FILEC(NPTDIM),FILED(NPHDIM),PTA00070 * FILEE(NPHDIM),INTFA(IPTDIM),INTFB(IPTDIM),INTFC(IPTDIM),PTA00080 * INTFD(IPHDIM),INTFE(IPHDIM) PTA00090 C PTA00100 DIMENSION ATA(NORDIM),BTB(NORDIM),CTC(NORDIM),DTD(NOIDIM), PTA00110 * ETE(NOIDIM),FTF(NORDIM),INTCTC(IORDIM) PTA00120 C PTA00130 DIMENSION A(2,22),TEMPC(04),TEMPE(36),P(3),Q(3),R(3),GRV(3),AXW(2)PTA00140 * ,SUBA(16),RMSVP(4),RMSPG(6),RMSVG(11,6),SXYZ(6) PTA00150 DIMENSION FMTPT(16),FMTDS(6) PTA00160 DIMENSION NUL(22),ICH(5),KCH(08),IMSVP(4),IMSPG(6),INDEXH(9), PTA00170 * INDEXV(9),INDEX(9),NULL(9,2),IMSVG(11,3),NMSVG(11,3) PTA00180 * ,ISUBA(18) PTA00190 C PTA00200 REAL*4 SXYZ PTA00210 DATA ICH/2HOB,2HVE,2HHO,2HHV,4HPC 1/ PTA00220 DATA KCH/4H VXP,4H VYP,4H PXG,4H PYG,4H PZG,4H VXG,4H VYG, PTA00230 * 4H VZG/ PTA00240 DATA FMTPT/8H(1H ,I13,4H,1X,,3*1H ,1H,,3*1H ,1H,,3*1H ,1H,, PTA00250 * 8H3F7.5,1X,8H,2F12.5)/ PTA00260 DATA FMTDS/8H16H ---,8H-- ----,8H- ,8H2F8.5,1X,2*1H /PTA00270 C PTA00280 COMMON /BLOCKA/WATE(11,5) PTA00290 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00300 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00310 COMMON /MARIKO/RMS(6), NU1(16),NU2(3),ISET(10),MA1(12),MA2(3), PTA00320 * MAM,NUSUM,IMS(3) PTA00330 C PTA00340 EQUIVALENCE (SXYZ(1),ISUBA(1),SUBA(1)) PTA00350 C PTA00360 EQUIVALENCE (IAUX(21),NPTREC),(IAUX(22),NPHREC),(IAUX(23),INTDGT) PTA00370 * ,(IAUX(24), NYPT),(IAUX(26), NYHO),(IAUX(27), NYVE) PTA00380 * ,(IAUX(31),NACCPT),(IAUX(32),NACCPH),(IAUX(34), NYPHE) PTA00390 * ,(IAUX(35), NYPTL),(IAUX(36), NPTU),(IAUX(37),GRV(1)) PTA00400 * ,(IAUX(48), NYDTD) PTA00410 EQUIVALENCE (IAUX(51), NU0),(IAUX(52), NUP),(IAUX(53), IDIST) PTA00420 * ,(IAUX(54),NUL(1)) PTA00430 C PTA00440 DATA IFLA, IFLC,IFLD,IFLE,IFLF,IFLG,IFLH/1, 3,4,5,6,7,8/PTA00450 DATA IFLL,NFL3,NFL4,NFL5/12,14,16,17/ PTA00460 DATA IBLK,IPLUS,MINUS/1H ,1H+,1H-/ PTA00470 C PTA00480 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA00490 C PTA00500 C SET UP FILE DIMENSION PTA00510 C PTA00520 NYPH=4 PTA00530 NYETE=NYVE PTA00540 NYFTF=3 PTA00550 NYPTP=8 PTA00560 NYPTP1=NYPTP-1 PTA00570 C PTA00580 CALL SETDIM(NPTDIM,NYPT, NPTR,NTPT,IPTR,IYPT) PTA00590 CALL SETDIM(NPHDIM,NYPH, NPHR,NTPH,IPHR,IYPH) PTA00600 CALL SETDIM(NPTDIM,NYHO, NHOR,NTHO,IHOR,IYHO) PTA00610 CALL SETDIM(NPTDIM,NYVE, NVER,NTVE,IVER,IYVE) PTA00620 CALL SETDIM(NPHDIM,NYPHE, NPHRE,NTPHE,IPHRE,IYPHE) PTA00630 CALL SETDIM(NPTDIM,NYPTL, NPTRL,NTPTL,IPTRL,IYPTL) PTA00640 CALL SETDIM(NOIDIM,NYDTD, NDTDR,NTDTD,IDTDR,IYDTD) PTA00650 CALL SETDIM(NOIDIM,NYETE, NETER,NTETE,IETER,IYETE) PTA00660 CALL SETDIM(NORDIM,NYFTF, NFTFR,NTFTF,IFTFR,IYFTF) PTA00670 CALL SETDIM(NPTDIM,NYPTP, NPTRP,NTPTP,IPTRP,IYPTP) PTA00680 C PTA00690 C READ-IN OUTPUT OPTIONS PTA00700 C PTA00710 READ(ICD,1) IPRNTA,IPRNTB,IPRNTC,ICARDA,ICARDB,IPCADD PTA00720 READ(ICD,1) IFILE PTA00730 READ(ICD,1) KFILE,IFCODE,IFDGTA,IFDGTB, IPCODE,IPDGTA,IPDGTB PTA00740 C PTA00750 KERR=0 PTA00760 IERR=0 PTA00770 C PTA00780 CALL TESTOU(IERR,IPRNTA,IPRNTB,IPRNTC,ICARDA,ICARDB,IFILE,KFILE) PTA00790 IF(IERR.NE.0) KERR=1 PTA00800 C PTA00810 IF(KFILE.EQ.0) GO TO 115 PTA00820 C PTA00830 CALL TESTCD(1,IFCODE,IFDGTA,IFDGTB,IFID,IHI,LOW,IERR) PTA00840 IF(IHI.LT.0 .OR. IERR.NE.0) GO TO 105 PTA00850 C PTA00860 IFDIVL=10**(LOW-1) PTA00870 IFDIVH=10**(IHI-LOW+1) PTA00880 INPP=IFCODE*IFDIVL PTA00890 IF(IFCODE/IFDIVH.EQ.0) GO TO 105 PTA00900 IF(IHI.EQ.LOW) WRITE(IPR,5001) IFCODE,IHI PTA00910 IF(IHI.NE.LOW) WRITE(IPR,5002) IFCODE,LOW,IHI PTA00920 IERR=1 PTA00930 C PTA00940 105 IF(IERR.NE.0) KERR=1 PTA00950 C PTA00960 CALL TESTCD(2,IPCODE,IPDGTA,IPDGTB,IPID,IHI,LOW,IERR) PTA00970 IF(IHI.LT.0 .OR. IERR.NE.0) GO TO 115 PTA00980 C PTA00990 IPDIVL=10**(LOW-1) PTA01000 IPDIVH=10**(IHI-LOW+1) PTA01010 INPD=IPCODE*IPDIVL PTA01020 IF(IPCODE/IPDIVH.EQ.0) GO TO 110 PTA01030 IF(IHI.EQ.LOW) WRITE(IPR,5003) IPCODE,IHI PTA01040 IF(IHI.NE.LOW) WRITE(IPR,5004) IPCODE,LOW,IHI PTA01050 IERR=1 PTA01060 C PTA01070 110 IF(IFID.EQ.0 .OR. IPID.EQ.0) GO TO 115 PTA01080 IF(IFCODE.NE.IPCODE) GO TO 115 PTA01090 WRITE(IPR,5005) IFCODE PTA01100 IERR=1 PTA01110 C PTA01120 115 IF(IERR.NE.0) KERR=1 PTA01130 C PTA01140 IF(KERR.NE.0) CALL ERRSTP(IPR) PTA01150 C PTA01160 IPRNT=0 PTA01170 ICARD=0 PTA01180 IOUTA=0 PTA01190 KOUTA=0 PTA01200 NTYPE=4001 PTA01210 M99=-99 PTA01220 IZERO=0 PTA01230 ZERO=0.0 PTA01240 C PTA01250 IF(IPRNTA.EQ.1.OR.IPRNTA.EQ.3) IPRNT=1 PTA01260 IF(ICARDA.EQ.1.OR.ICARDA.EQ.3) ICARD=1 PTA01270 IF(IPRNT.EQ.1.OR.ICARD.EQ.1) IOUTA=1 PTA01280 IF(IPRNTA.EQ.2.OR.ICARDA.EQ.2) KOUTA=1 PTA01290 IF(IFILE.EQ.0) GO TO 120 PTA01300 IOUTA=1 PTA01310 REWIND IFILE PTA01320 120 IF(KFILE.NE.0.AND.KFILE.NE.IPUNCH) REWIND KFILE PTA01330 C PTA01340 C SET UP WORK FILES FOR ADJUSTMENT RESULTS PTA01350 C PTA01360 CALL OPEN(IFLC,NPTR,NYPT) PTA01370 LPTC=0 PTA01380 IRC= -NYPT PTA01390 IIC= -IYPT PTA01400 C PTA01410 CALL OPEN(IFLF,NHOR,NYHO) PTA01420 LPTF=0 PTA01430 IRB= -NYHO PTA01440 IIB= -IYHO PTA01450 C PTA01460 CALL OPEN(NFL4,NETER,NYETE) PTA01470 LPT4=0 PTA01480 IR4= -NYETE PTA01490 II4= -IYETE PTA01500 C PTA01510 CALL OPEN(NFL5,NFTFR,NYFTF) PTA01520 LPT5=0 PTA01530 IR5= -NYFTF PTA01540 II5= -IYFTF PTA01550 C PTA01560 IGL=0 PTA01570 C PTA01580 DO 130 I=1,9 PTA01590 INDEXH(I)=0 PTA01600 130 INDEXV(I)=0 PTA01610 C PTA01620 DO 160 KPT=1,NPTU PTA01630 C PTA01640 CALL BRING(IFLL,FILEA,NPTRL,NYPTL,IGL,0,ITRKL,NRL,IPL,IRA,IIA) PTA01650 C PTA01660 CALL APUT(NFL5,FTF,NFTFR, LPT5,1, 0,0, IR5,II5) PTA01670 LPT5=LPT5+1 PTA01680 IR5=IR5+NYFTF PTA01690 C PTA01700 DO 135 J=1,3 PTA01710 135 FTF(IR5+J)=FILEA(IRA+J+3) PTA01720 C PTA01730 CALL APUT(IFLC,FILEC,NPTR, LPTC,1, 0,0, IRC,IIC) PTA01740 LPTC=LPTC+1 PTA01750 IRC=IRC+NYPT PTA01760 C PTA01770 DO 140 J=1,4 PTA01780 140 FILEC(IRC+J)=FILEA(IRA+J-1) PTA01790 C PTA01800 INDH=INTFA(IIA+1)/100000 PTA01810 IF(INDH.EQ.0) GO TO 155 PTA01820 C PTA01830 CALL APUT(IFLF,FILEB,NHOR, LPTF,1, 0,0, IRB,IIB) PTA01840 LPTF=LPTF+1 PTA01850 IRB=IRB+NYHO PTA01860 C PTA01870 FILEB(IRB+1)=FILEA(IRA) PTA01880 DO 145 J=2,3 PTA01890 145 FILEB(IRB+J)=FILEA(IRA+J-1)+GRV(J-1) PTA01900 C PTA01910 DO 150 J=1,2 PTA01920 150 SXYZ(J)=FILEA(IRA+J+6) PTA01930 FILEB(IRB+4)=SUBA(1) PTA01940 INDEXH(INDH)=INDEXH(INDH)+1 PTA01950 C PTA01960 155 INDV=(INTFA(IIA+1)-INDH*100000)/10000 PTA01970 IF(INDV.EQ.0) GO TO 160 PTA01980 C PTA01990 CALL APUT(NFL4,ETE,NETER, LPT4,1, 0,0, IR4,II4) PTA02000 LPT4=LPT4+1 PTA02010 IR4=IR4+NYETE PTA02020 C PTA02030 ETE(IR4+1)=FILEA(IRA) PTA02040 ETE(IR4+2)=FILEA(IRA+3)+GRV(3) PTA02050 ETE(IR4+3)=FILEA(IRA+9) PTA02060 INDEXV(INDV)=INDEXV(INDV)+1 PTA02070 C PTA02080 160 CONTINUE PTA02090 C PTA02100 CALL ACLOSE(IFLC,FILEC,NPTR,LPTC) PTA02110 CALL ACLOSE(IFLF,FILEB,NHOR,LPTF) PTA02120 CALL ACLOSE(NFL4,ETE,NETER,LPT4) PTA02130 CALL ACLOSE(NFL5,FTF,NFTFR,LPT5) PTA02140 CALL STORE(IFLF,FILEB,NHOR) PTA02150 C PTA02160 DO 170 I=1,3 PTA02170 P(I)=WATE(10,I) PTA02180 170 Q(I)=WATE(11,I) PTA02190 NU0NUP=NU0+NUP PTA02200 C PTA02210 CALL RCLEAR(RMSVP,4,1,4) PTA02220 CALL RCLEAR(RMSPG,6,1,6) PTA02230 C PTA02240 IF(IOUTA.EQ.0) GO TO 180 PTA02250 C PTA02260 NPTPRC=(NACCPT-1)/NTPTP+1 PTA02270 CALL SETFIL(IFLA,NPTPRC,NPTRP,1) PTA02280 C PTA02290 CALL OPEN(IFLA,NPTRP,NYPTP) PTA02300 LPT=0 PTA02310 IRA=1-NYPTP PTA02320 IIA=1-IYPTP PTA02330 C PTA02340 180 IGE=0 PTA02350 IGH=0 PTA02360 IG3=0 PTA02370 ITRKC=0 PTA02380 ITRK5=0 PTA02390 MFLE=0 PTA02400 MFLH=0 PTA02410 IF(IPRNTC.NE.0) MFLE=IFLE PTA02420 IF(IPRNTC.GE.2.AND.IDIST.NE.0) MFLH=IFLH PTA02430 IF(KFILE.NE.0) MFLH=IFLH PTA02440 C PTA02450 CALL OPEN(IFLD,NPHR,NYPH) PTA02460 LPH=0 PTA02470 IRD=-NYPH PTA02480 IID=-IYPH PTA02490 C PTA02500 DO 290 KPH=1,NACCPH PTA02510 C PTA02520 CALL BRING(IFLE,FILEE,NPHRE,NYPHE,IGE,MFLE,ITRKE,NRE,IPE,IRE,IIE) PTA02530 CALL BRING(NFL3,DTD,NDTDR,NYDTD,IG3,0,ITRK3,NR3,IP3,IR3,II3) PTA02540 NPT=INTFE(IIE+1) PTA02550 C PTA02560 DO 200 I=1,36 PTA02570 200 TEMPE(I)=FILEE(IRE+I-1) PTA02580 DO 205 I=1,NU0 PTA02590 K=NU1(I) PTA02600 205 FILEE(IRE+K)=FILEE(IRE+K)-DTD(IR3+I-1) PTA02610 CALL ROTMAT(FILEE,IRE,NPHRE) PTA02620 C PTA02630 DO 275 KPT=1,NPT PTA02640 C PTA02650 CALL BRING(IFLH,FILEB,NPTR,NYPT,IGH,MFLH,ITRKH,NRH,IPH,IRB,IIB) PTA02660 CALL LOCATE(IFLC,FILEC,NPTR,NTPT,NYPT,0,INTFB(IIB),ITRKC,IRC,IIC) PTA02670 CALL LOCATE(NFL5,FTF,NFTFR,NTFTF,NYFTF,0,INTFB(IIB),ITRK5,IR5,II5)PTA02680 C PTA02690 XX0=FILEB(IRB+2)-FILEE(IRE+26) PTA02700 YY0=FILEB(IRB+3)-FILEE(IRE+27) PTA02710 C PTA02720 DX=0.0 PTA02730 DY=0.0 PTA02740 C PTA02750 IF(IDIST.EQ.0) GO TO 220 PTA02760 C PTA02770 C COMPUTE DISTORTION COMPONENTS PTA02780 C PTA02790 C1=XX0**2 PTA02800 C2=YY0**2 PTA02810 C3=C1+C2 PTA02820 C PTA02830 IF(ISET(4).EQ.0) GO TO 210 PTA02840 RAD= FILEE(IRE+29)*C3+FILEE(IRE+30)*(C3**2)+FILEE(IRE+31)*(C3**3) PTA02850 DX=DX+XX0*RAD PTA02860 DY=DY+YY0*RAD PTA02870 C PTA02880 210 IF(ISET(5).EQ.0) GO TO 215 PTA02890 C4=C1+C1+C3 PTA02900 C5=C2+C2+C3 PTA02910 C6=XX0*YY0*2.0 PTA02920 DX=DX+FILEE(IRE+32)*C4+FILEE(IRE+33)*C6 PTA02930 DY=DY+FILEE(IRE+33)*C5+FILEE(IRE+32)*C6 PTA02940 C PTA02950 215 IF(ISET(6).EQ.0) GO TO 220 PTA02960 DX=DX+FILEE(IRE+34)*YY0 PTA02970 DY=DY+FILEE(IRE+35)*YY0 PTA02980 C PTA02990 C COMPUTE RESIDUALS (V) PTA03000 C PTA03010 220 DO 225 I=1,4 PTA03020 225 TEMPC(I)=FILEC(IRC+I-1) PTA03030 IF(NUP.EQ.0) GO TO 235 PTA03040 DO 230 I=1,NUP PTA03050 K=NU2(I) PTA03060 230 TEMPC(K+1)=TEMPC(K+1)+FTF(IR5+K-1) PTA03070 C PTA03080 235 IF(IDIST.EQ.0) CALL SETAND(FILEB,IRB,TEMPC,1,TEMPE,1,A,1,NU0NUP, PTA03090 * NUL,NPTDIM,4,36) PTA03100 IF(IDIST.NE.0) CALL SETADS(FILEB,IRB,TEMPC,1,TEMPE,1,A,Q,R,1, PTA03110 * NU0NUP,NUL,NPTDIM,4,36) PTA03120 C PTA03130 DO 250 K=1,2 PTA03140 AXW(K)=A(K,NU0NUP+1) PTA03150 DO 240 I=1,NU0 PTA03160 240 AXW(K)=AXW(K)-A(K,I)*DTD(IR3+I-1) PTA03170 IF(NUP.EQ.0) GO TO 250 PTA03180 DO 245 I=1,NUP PTA03190 L=NU2(I) PTA03200 245 AXW(K)=AXW(K)-A(K,NU0+I)*FTF(IR5+L-1) PTA03210 250 CONTINUE PTA03220 C PTA03230 IF(IDIST.EQ.0) GO TO 260 PTA03240 C PTA03250 CORR1=-R(1)*AXW(1) PTA03260 CORR2=-R(2)*AXW(2) PTA03270 IF(R(3).EQ.0.0) GO TO 255 PTA03280 CORR1=CORR1-R(3)*AXW(2) PTA03290 CORR2=CORR2-R(3)*AXW(1) PTA03300 C PTA03310 255 AXW(1)= (A(1,21)*CORR1+A(2,21)*CORR2)*Q(1) PTA03320 IF(Q(3).EQ.0.0) GO TO 260 PTA03330 AXW(2)= (A(1,22)*CORR1+A(2,22)*CORR2)*Q(2) PTA03340 AXW(1)=AXW(1)+(A(1,22)*CORR1+A(2,22)*CORR2)*Q(3) PTA03350 AXW(2)=AXW(2)+(A(1,21)*CORR1+A(2,21)*CORR2)*Q(3) PTA03360 C PTA03370 260 SXYZ(4)=AXW(1) PTA03380 SXYZ(5)=AXW(2) PTA03390 CALL SETRMS(SXYZ,3, RMSVP,IMSVP,2, INTFB(IIB+2),INTFE(IIE), 6,4,4)PTA03400 C PTA03410 C COMPUTE RESIDUAL PARALLAXES PTA03420 C PTA03430 XV=XX0+DX PTA03440 YV=YY0+DY PTA03450 ZV=-FILEE(IRE+28) PTA03460 C PTA03470 XSL=XV*FILEE(IRE+08)+YV*FILEE(IRE+11)+ZV*FILEE(IRE+14) PTA03480 YSL=XV*FILEE(IRE+09)+YV*FILEE(IRE+12)+ZV*FILEE(IRE+15) PTA03490 ZSL=XV*FILEE(IRE+10)+YV*FILEE(IRE+13)+ZV*FILEE(IRE+16) PTA03500 C PTA03510 SA=FILEC(IRC+1)-FILEE(IRE+2) PTA03520 SB=FILEC(IRC+2)-FILEE(IRE+3) PTA03530 SC=FILEC(IRC+3)-FILEE(IRE+4) PTA03540 C PTA03550 SCL=(SA*XSL+SB*YSL+SC*ZSL)/(XSL**2+YSL**2+ZSL**2) PTA03560 C PTA03570 SXYZ(1)=SCL*XSL-SA PTA03580 SXYZ(2)=SCL*YSL-SB PTA03590 SXYZ(3)=SCL*ZSL-SC PTA03600 CALL SETRMS(SXYZ,0, RMSPG,IMSPG,3, INTFB(IIB+2),INTFE(IIE), 6,6,6)PTA03610 C PTA03620 IF(MFLH.NE.0) INTFB(IIB+1)=INTFE(IIE) PTA03630 C PTA03640 IF(IOUTA.EQ.0) GO TO 275 PTA03650 C PTA03660 CALL APUT(IFLA,FILEA,NPTRP, LPT,1, 1,1, IRA,IIA) PTA03670 LPT=LPT+1 PTA03680 IRA=IRA+NYPTP PTA03690 IIA=IIA+IYPTP PTA03700 C PTA03710 DO 265 J=1,3 PTA03720 265 FILEA(IRA+J)=FILEC(IRC+J)+GRV(J) PTA03730 C PTA03740 DO 270 J=4,6 PTA03750 270 FILEA(IRA+J)=SUBA(J-3) PTA03760 C PTA03770 FILEA(IRA)=FILEB(IRB+1) PTA03780 INTFA(IIA+13)=INTFE(IIE) PTA03790 FILEA(IRA+NYPTP1)=DFLOAT(INTFA(IIA)) PTA03800 C PTA03810 275 CONTINUE PTA03820 C PTA03830 CALL APUT(IFLD,FILED,NPHR, LPH,1, 0,0, IRD,IID) PTA03840 LPH=LPH+1 PTA03850 IRD=IRD+NYPH PTA03860 C PTA03870 FILED(IRD+1)=FILEE(IRE) PTA03880 DO 280 J=2,4 PTA03890 280 FILED(IRD+J)=FILEE(IRE+J)+GRV(J-1) PTA03900 C PTA03910 IF(MFLE.EQ.0) GO TO 290 PTA03920 DO 285 J=2,4 PTA03930 285 FILEE(IRE+J)=FILED(IRD+J) PTA03940 C PTA03950 290 CONTINUE PTA03960 C PTA03970 IF(MFLE.NE.0.AND.ITRKE.EQ.NTRK(IFLE)) CALL BPUT(IFLE,ITRKE,FILEE, PTA03980 * NPHRE) PTA03990 IF(MFLH.NE.0.AND.ITRKH.EQ.NTRK(IFLH)) CALL BPUT(IFLH,ITRKH,FILEB, PTA04000 * NPTR) PTA04010 IF(IOUTA.NE.0) CALL ACLOSE(IFLA,FILEA,NPTRP,LPT) PTA04020 CALL ACLOSE(IFLD,FILED,NPHR,LPH) PTA04030 IF(IOUTA.NE.0.OR.KOUTA.NE.0) CALL SORTD(IFLD,1,FILED,FILEE,INTFD, PTA04040 * INTFE,SUBA,NPHR,IPHR,NYPH,IYPH) PTA04050 C PTA04060 C PRINT ADJUSTED COORDINATES OF OBJECT POINTS IN PHOTO-NUMBER SEQUENCE PTA04070 C PTA04080 WRITE(IPR,3001) PTA04090 IF(IPRNTA.EQ.0) WRITE(IPR,3002) PTA04100 C PTA04110 IF(IOUTA.EQ.0) GO TO 325 PTA04120 C PTA04130 CALL SORTD(IFLA,14,FILEA,FILEB,INTFA,INTFB,SUBA,NPTRP,IPTRP,NYPTP,PTA04140 * IYPTP)PTA04150 C PTA04160 PHADD=10.D0**(INTDGT+1) PTA04170 ADD=-PHADD PTA04180 IGA=0 PTA04190 IGD=0 PTA04200 C PTA04210 DO 300 KPH=1,NACCPH PTA04220 CALL BRING(IFLD,FILED,NPHR,NYPH,IGD,0,ITRKD,NRD,IPD,IRD,IID) PTA04230 NPT=INTFD(IID+1) PTA04240 ADD=ADD+PHADD PTA04250 DO 300 KPT=1,NPT PTA04260 CALL BRING(IFLA,FILEA,NPTRP,NYPTP,IGA,IFLA,ITRKA,NRA,IPA,IRA,IIA) PTA04270 300 FILEA(IRA+NYPTP1)=FILEA(IRA+NYPTP1)+ADD PTA04280 C PTA04290 IF(ITRKA.EQ.NTRK(IFLA)) CALL BPUT(IFLA,ITRKA,FILEA,NPTRP) PTA04300 C PTA04310 CALL SORTC(IFLA,8,FILEA,FILEB,SUBA,NPTRP,NYPTP) PTA04320 C PTA04330 IGA=0 PTA04340 IGD=0 PTA04350 C PTA04360 DO 320 KPH=1,NACCPH PTA04370 C PTA04380 CALL BRING(IFLD,FILED,NPHR,NYPH,IGD,0,ITRKD,NRD,IPD,IRD,IID) PTA04390 NPT=INTFD(IID+1) PTA04400 C PTA04410 IF(IPRNT.NE.0) WRITE(IPR,3101) INTFD(IID) PTA04420 C PTA04430 DO 315 KPT=1,NPT PTA04440 C PTA04450 CALL BRING(IFLA,FILEA,NPTRP,NYPTP,IGA,0,ITRKA,NRA,IPA,IRA,IIA) PTA04460 C PTA04470 IF(ICARD.NE.0) WRITE(IPUNCH,3109) INTFD(IID),INTFA(IIA) PTA04480 * ,INTFA(IIA+1),(FILEA(IRA+J),J=1,3) PTA04490 C PTA04500 DO 305 J=1,3 PTA04510 305 SUBA(J)=FILEA(IRA+J+3) PTA04520 C PTA04530 IF(IFILE.EQ.0) GO TO 313 PTA04540 DO 310 J=1,5 PTA04550 310 SUBA(J+3)=SXYZ(J) PTA04560 WRITE(IFILE) INTFD(IID),INTFA(IIA),INTFA(IIA+1),(FILEA(IRA+J) PTA04570 * ,J=1,3),(SUBA(J),J=4,8) PTA04580 C PTA04590 313 IF(IPRNT.EQ.0) GO TO 315 PTA04600 ITYPE=INTFA(IIA+1)/1000 PTA04610 MULT=INTFA(IIA+1)-ITYPE*1000 PTA04620 WRITE(IPR,3102) INTFA(IIA),ICH(ITYPE+1),MULT,(FILEA(IRA+J),J=1,3) PTA04630 * ,(SXYZ(J),J=1,5) PTA04640 C PTA04650 315 CONTINUE PTA04660 C PTA04670 NPCPT=INTFD(IID)+IPCADD PTA04680 IF(IPRNT.NE.0) WRITE(IPR,3103) NPCPT,ICH(5),(FILED(IRD+J),J=1,3) PTA04690 IF(ICARD.NE.0) WRITE(IPUNCH,3110) NPCPT,NTYPE,(FILED(IRD+J),J=1,3)PTA04700 IF(IFILE.EQ.0) GO TO 320 PTA04710 WRITE(IFILE) IZERO,NPCPT,NTYPE,(FILED(IRD+J),J=1,3),ZERO,ZERO,ZEROPTA04720 * ,ZERO,ZEROPTA04730 WRITE(IFILE) M99,M99,M99,ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ZERO PTA04740 C PTA04750 320 CONTINUE PTA04760 C PTA04770 C PRINT ADJUSTED COORDINATES OF OBJECT POINTS IN POINT-NUMBER SEQUENCE PTA04780 C PTA04790 325 IF(KOUTA.EQ.0) GO TO 345 PTA04800 C PTA04810 IF(IPRNTA.EQ.2) WRITE(IPR,3108) PTA04820 C PTA04830 CALL SORTD(IFLC,1,FILEC,FILEA,INTFC,INTFA,SUBA,NPTR,IPTR,NYPT, PTA04840 * IYPT) PTA04850 IGC=0 PTA04860 C PTA04870 DO 335 KPT=1,NPTU PTA04880 C PTA04890 CALL BRING(IFLC,FILEC,NPTR,NYPT,IGC,0,ITRKC,NRC,IPC,IRC,IIC) PTA04900 C PTA04910 DO 330 J=1,3 PTA04920 330 SUBA(J)=FILEC(IRC+J)+GRV(J) PTA04930 C PTA04940 ITYPE0=INTFC(IIC+1)-(INTFC(IIC+1)/10000)*10000 PTA04950 ITYPE=ITYPE0/1000 PTA04960 MULT=ITYPE0-ITYPE*1000 PTA04970 C PTA04980 IF(ICARDA.EQ.2) WRITE(IPUNCH,3110) INTFC(IIC),ITYPE0,(SUBA(J), PTA04990 * J=1,3) PTA05000 IF(IPRNTA.EQ.2) WRITE(IPR,3102) INTFC(IIC),ICH(ITYPE+1),MULT, PTA05010 * (SUBA(J),J=1,3) PTA05020 C PTA05030 335 CONTINUE PTA05040 C PTA05050 IGD=0 PTA05060 C PTA05070 DO 340 KPH=1,NACCPH PTA05080 CALL BRING(IFLD,FILED,NPHR,NYPH,IGD,0,ITRKD,NRD,IPD,IRD,IID) PTA05090 NPCPT=INTFD(IID)+IPCADD PTA05100 IF(ICARDA.EQ.2) WRITE(IPUNCH,3110) NPCPT,NTYPE,(FILED(IRD+J) PTA05110 * ,J=1,3) PTA05120 IF(IPRNTA.EQ.2) WRITE(IPR,3103) NPCPT,ICH(5),(FILED(IRD+J),J=1,3) PTA05130 340 CONTINUE PTA05140 C PTA05150 C COMPUTE CONTROL POINT RESIDUALS PTA05160 C PTA05170 345 DO 355 I=1,11 PTA05180 DO 350 J=1,6 PTA05190 350 RMSVG(I,J)=0.0 PTA05200 DO 355 J=1,3 PTA05210 355 NMSVG(I,J)=0 PTA05220 C PTA05230 NINDEX=0 PTA05240 C PTA05250 DO 365 I=1,9 PTA05260 C PTA05270 INDEX(I)=INDEXH(I)+INDEXV(I) PTA05280 IF(INDEX(I).NE.0) NINDEX=NINDEX+1 PTA05290 C PTA05300 NULL(I,1)=0 PTA05310 NULL(I,2)=0 PTA05320 C PTA05330 IF(WATE(I,5).EQ.0.0) GO TO 365 PTA05340 C PTA05350 DO 360 J=1,2 PTA05360 IF(WATE(I,J).NE.0.0) NULL(I,1)=1 PTA05370 360 CONTINUE PTA05380 IF(WATE(I,4).NE.0.0) NULL(I,1)=1 PTA05390 C PTA05400 IF(WATE(I,3).NE.0.0) NULL(I,2)=1 PTA05410 C PTA05420 365 CONTINUE PTA05430 C PTA05440 C PRINT ADJUSTED COORDINATES OF HORIZONTAL CONTROL POINTS PTA05450 C PTA05460 WRITE(IPR,3003) PTA05470 C PTA05480 IPRNT=0 PTA05490 ICARD=0 PTA05500 IOUTH=0 PTA05510 IF(IPRNTB.EQ.1.OR.IPRNTB.EQ.3) IPRNT=1 PTA05520 IF(ICARDB.EQ.1.OR.ICARDB.EQ.3) ICARD=1 PTA05530 IF(IPRNT.NE.0.OR.ICARD.NE.0) IOUTH=1 PTA05540 IF(IFILE.NE.0) IOUTH=1 PTA05550 C PTA05560 IF(IPRNT.EQ.0) WRITE(IPR,3004) PTA05570 IF(IPRNT.NE.0) WRITE(IPR,3104) PTA05580 C PTA05590 CALL BGET(IFLF,1,FILEA,NHOR,KHO) PTA05600 C PTA05610 IRA=1-NYHO PTA05620 IIA=1-IYHO PTA05630 C PTA05640 IF(IOUTH.NE.0) CALL SORTB1(FILEA,INTFA,1,KHO,1,SUBA,NHOR,IHOR, PTA05650 * NYHO,IYHO) PTA05660 C PTA05670 DO 375 KPT=1,KHO PTA05680 C PTA05690 IRA=IRA+NYHO PTA05700 IIA=IIA+IYHO PTA05710 SUBA(1)=FILEA(IRA+3) PTA05720 INDH=INTFA(IIA+1)/100000 PTA05730 C PTA05740 IF(NINDEX.EQ.1) GO TO 370 PTA05750 CALL RMSSET(INDH,SXYZ,RMSVG,IMSVG,NMSVG,1,2,INTFA(IIA)) PTA05760 IF(NULL(INDH,1).NE.0) CALL RMSSET(10,SXYZ,RMSVG,IMSVG,NMSVG,1,2, PTA05770 * INTFA(IIA)) PTA05780 IF(NULL(INDH,1).EQ.0) CALL RMSSET(11,SXYZ,RMSVG,IMSVG,NMSVG,1,2, PTA05790 * INTFA(IIA)) PTA05800 C PTA05810 370 IF(IOUTH.EQ.0) GO TO 375 PTA05820 ITYPE0=INTFA(IIA+1)-(INTFA(IIA+1)/10000)*10000 PTA05830 ITYPE=ITYPE0/1000 PTA05840 MULT=ITYPE0-ITYPE*1000 PTA05850 C PTA05860 IF(ICARD.NE.0) WRITE(IPUNCH,3109) INDH,INTFA(IIA),ITYPE0, PTA05870 * (FILEA(IRA+J),J=1,2) PTA05880 IF(IPRNT.NE.0) WRITE(IPR,3105) INTFA(IIA),ICH(ITYPE+1),MULT PTA05890 * ,(FILEA(IRA+J),J=1,2),(SXYZ(J),J=1,2),INDH PTA05900 IF(IFILE.EQ.0) GO TO 375 PTA05910 DO 373 J=1,2 PTA05920 373 SUBA(J+1)=SXYZ(J) PTA05930 WRITE(IFILE) INDH,INTFA(IIA),ITYPE0,(FILEA(IRA+J),J=1,2),ZERO PTA05940 * ,(SUBA(J),J=2,3),ZERO,ZERO,ZERO PTA05950 C PTA05960 375 CONTINUE PTA05970 C PTA05980 IF(IFILE.NE.0) WRITE(IFILE) M99,M99,M99,ZERO,ZERO,ZERO,ZERO,ZERO PTA05990 * ,ZERO,ZERO,ZERO PTA06000 IF(KFILE.NE.0) CALL BPUT(IFLF,1,FILEA,NHOR) PTA06010 C PTA06020 C PRINT ADJUSTED COORDINATES OF VERTICAL CONTROL POINTS PTA06030 C PTA06040 WRITE(IPR,3005) PTA06050 C PTA06060 IOUTV=0 PTA06070 IF(IPRNTB.GE.2) IOUTV=1 PTA06080 IF(ICARDB.GE.2) IOUTV=1 PTA06090 IF(IFILE.NE.0) IOUTV=1 PTA06100 C PTA06110 IF(IPRNTB.LE.1) WRITE(IPR,3006) PTA06120 IF(IPRNTB.GE.2) WRITE(IPR,3106) PTA06130 C PTA06140 IG4=0 PTA06150 KVE=NREC(IFLG) PTA06160 IRB=-NYETE PTA06170 C PTA06180 DO 380 KPT=1,KVE PTA06190 C PTA06200 CALL BRING(NFL4,ETE,NETER,NYETE,IG4,0,ITRK4,NR4,IP4,IR4,II4) PTA06210 C PTA06220 IRB=IRB+NYETE PTA06230 DO 380 J=1,NYETE PTA06240 380 FILEB(IRB+J)=ETE(IR4+J-1) PTA06250 C PTA06260 IF(IOUTV.NE.0) CALL SORTB1(FILEB,INTFB,1,KVE,1,SUBA,NVER,IVER, PTA06270 * NYVE,IYVE) PTA06280 C PTA06290 IRB=1-NYVE PTA06300 IIB=1-IYVE PTA06310 C PTA06320 DO 390 KPT=1,KVE PTA06330 C PTA06340 IRB=IRB+NYVE PTA06350 IIB=IIB+IYVE PTA06360 C PTA06370 ITYPE0=INTFB(IIB+1)-(INTFB(IIB+1)/100000)*100000 PTA06380 INDV=ITYPE0/10000 PTA06390 C PTA06400 IF(NINDEX.EQ.1) GO TO 385 PTA06410 SXYZ(3)=FILEB(IRB+2) PTA06420 CALL RMSSET(INDV,SXYZ,RMSVG,IMSVG,NMSVG,3,3,INTFB(IIB)) PTA06430 IF(NULL(INDV,2).NE.0) CALL RMSSET(10,SXYZ,RMSVG,IMSVG,NMSVG,3,3, PTA06440 * INTFB(IIB)) PTA06450 IF(NULL(INDV,2).EQ.0) CALL RMSSET(11,SXYZ,RMSVG,IMSVG,NMSVG,3,3, PTA06460 * INTFB(IIB)) PTA06470 C PTA06480 385 IF(IOUTV.EQ.0) GO TO 390 PTA06490 ITYPE0=ITYPE0-(ITYPE0/10000)*10000 PTA06500 ITYPE=ITYPE0/1000 PTA06510 MULT=ITYPE0-ITYPE*1000 PTA06520 C PTA06530 IF(ICARDB.GE.2) WRITE(IPUNCH,3111) INDV,INTFB(IIB),ITYPE0 PTA06540 * ,FILEB(IRB+1) PTA06550 IF(IPRNTB.GE.2) WRITE(IPR,3107) INTFB(IIB),ICH(ITYPE+1),MULT PTA06560 * ,(FILEB(IRB+J),J=1,2),INDV PTA06570 IF(IFILE.NE.0) WRITE(IFILE) INDV,INTFB(IIB),ITYPE0,ZERO,ZERO PTA06580 * ,FILEB(IRB+1),ZERO,ZERO,FILEB(IRB+2),ZERO,ZERO PTA06590 C PTA06600 390 CONTINUE PTA06610 C PTA06620 IF(IFILE.NE.0) WRITE(IFILE) M99,M99,M99,ZERO,ZERO,ZERO,ZERO,ZERO PTA06630 * ,ZERO,ZERO,ZERO PTA06640 IF(KFILE.NE.0) CALL BPUT(IFLG,1,FILEB,NVER) PTA06650 C PTA06660 C PRINT SUMMARY OF STATISTICS PTA06670 C PTA06680 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA06690 WRITE(IPR,3201) PTA06700 C PTA06710 WRITE(IPR,3202) (MA1(I),I=1,MAM) PTA06720 IF(NUP.NE.0) WRITE(IPR,3203) (MA2(I),I=1,NUP) PTA06730 WRITE(IPR,3204) NUSUM PTA06740 C PTA06750 WRITE(IPR,3301) PTA06760 DO 400 K=1,2 PTA06770 RMSVP(K)=DSQRT(RMSVP(K)/DFLOAT(NACCPT)) PTA06780 WRITE(IPR,3401) KCH(K),RMSVP(K),NACCPT,KCH(K),RMSVP(K+2) PTA06790 * ,IMSVP(K),IMSVP(K+2) PTA06800 400 CONTINUE PTA06810 C PTA06820 WRITE(IPR,3302) PTA06830 DO 405 K=1,3 PTA06840 RMSPG(K)=DSQRT(RMSPG(K)/DFLOAT(NACCPT)) PTA06850 WRITE(IPR,3401) KCH(K+2),RMSPG(K),NACCPT,KCH(K+2),RMSPG(K+3) PTA06860 * ,IMSPG(K),IMSPG(K+3) PTA06870 405 CONTINUE PTA06880 C PTA06890 WRITE(IPR,3303) PTA06900 C PTA06910 IF(NINDEX.GE.2) GO TO 425 PTA06920 C PTA06930 DO 420 K=1,2 PTA06940 420 WRITE(IPR,3402) KCH(K+5),RMS(K+3),KHO,KCH(K+5),RMS(K),IMS(K) PTA06950 WRITE(IPR,3402) KCH(8),RMS(6),KVE,KCH(8),RMS(3),IMS(3) PTA06960 GO TO 500 PTA06970 C PTA06980 425 DO 430 K=1,3 PTA06990 RMSVG(10,K)=DSQRT(RMSVG(10,K)/DFLOAT(NMSVG(10,K))) PTA07000 WRITE(IPR,3402) KCH(K+5),RMSVG(10,K),NMSVG(10,K),KCH(K+5), PTA07010 * RMSVG(10,K+3),IMSVG(10,K) PTA07020 430 CONTINUE PTA07030 C PTA07040 DO 435 K=1,3 PTA07050 IF(NMSVG(11,K).NE.0) GO TO 440 PTA07060 435 CONTINUE PTA07070 GO TO 460 PTA07080 C PTA07090 440 WRITE(IPR,3304) PTA07100 DO 450 K=1,3 PTA07110 IF(NMSVG(11,K).EQ.0) GO TO 445 PTA07120 RMSVG(11,K)=DSQRT(RMSVG(11,K)/DFLOAT(NMSVG(11,K))) PTA07130 WRITE(IPR,3402) KCH(K+5),RMSVG(11,K),NMSVG(11,K),KCH(K+5), PTA07140 * RMSVG(11,K+3),IMSVG(11,K) PTA07150 GO TO 450 PTA07160 445 WRITE(IPR,3403) KCH(K+5),RMSVG(11,K),NMSVG(11,K) PTA07170 450 CONTINUE PTA07180 C PTA07190 WRITE(IPR,3305) PTA07200 DO 455 K=1,2 PTA07210 455 WRITE(IPR,3402) KCH(K+5),RMS(K+3),KHO,KCH(K+5),RMS(K),IMS(K) PTA07220 WRITE(IPR,3402) KCH(8),RMS(6),KVE,KCH(8),RMS(3),IMS(3) PTA07230 C PTA07240 IF(NINDEX.EQ.2) GO TO 500 PTA07250 C PTA07260 460 DO 480 I=1,9 PTA07270 C PTA07280 IF(INDEX(I).EQ.0) GO TO 480 PTA07290 C PTA07300 WRITE(IPR,3306) I PTA07310 DO 470 K=1,3 PTA07320 IF(NMSVG(I,K).EQ.0) GO TO 465 PTA07330 RMSVG(I,K)=DSQRT(RMSVG(I,K)/DFLOAT(NMSVG(I,K))) PTA07340 WRITE(IPR,3402) KCH(K+5),RMSVG(I,K),NMSVG(I,K),KCH(K+5), PTA07350 * RMSVG(I,K+3),IMSVG(I,K) PTA07360 GO TO 470 PTA07370 465 WRITE(IPR,3403) KCH(K+5),RMSVG(I,K),NMSVG(I,K) PTA07380 470 CONTINUE PTA07390 C PTA07400 480 CONTINUE PTA07410 C PTA07420 C PRINT ADJUSTED COORDINATES OF OBJECT POINTS IN POINT NUMBER SEQUENCE PTA07430 C PTA07440 500 IF(IPRNTA.EQ.3) GO TO 505 PTA07450 IF(ICARDA.EQ.3) GO TO 510 PTA07460 IF(IFILE.NE.0) GO TO 510 PTA07470 GO TO 600 PTA07480 C PTA07490 505 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA07500 WRITE(IPR,3001) PTA07510 WRITE(IPR,3108) PTA07520 C PTA07530 510 IF(KOUTA.EQ.0) CALL SORTD(IFLC,1,FILEC,FILEA,INTFC,INTFA,SUBA,NPTRPTA07540 * ,IPTR,NYPT,IYPT)PTA07550 C PTA07560 IGC=0 PTA07570 DO 520 KPT=1,NPTU PTA07580 C PTA07590 CALL BRING(IFLC,FILEC,NPTR,NYPT,IGC,0,ITRKC,NRC,IPC,IRC,IIC) PTA07600 C PTA07610 DO 515 J=1,3 PTA07620 515 SUBA(J)=FILEC(IRC+J)+GRV(J) PTA07630 C PTA07640 ITYPE0=INTFC(IIC+1)-(INTFC(IIC+1)/10000)*10000 PTA07650 ITYPE=ITYPE0/1000 PTA07660 MULT=ITYPE0-ITYPE*1000 PTA07670 C PTA07680 IF(ICARDA.EQ.3) WRITE(IPUNCH,3110) INTFC(IIC),ITYPE0,(SUBA(J), PTA07690 * J=1,3) PTA07700 IF(IPRNTA.EQ.3) WRITE(IPR,3102) INTFC(IIC),ICH(ITYPE+1),MULT, PTA07710 * (SUBA(J),J=1,3) PTA07720 IF(IFILE.NE.0) WRITE(IFILE) IZERO,INTFC(IIC),ITYPE0,(SUBA(J) PTA07730 * ,J=1,3),ZERO,ZERO,ZERO,ZERO,ZERO PTA07740 C PTA07750 520 CONTINUE PTA07760 C PTA07770 IGD=0 PTA07780 DO 530 KPH=1,NACCPH PTA07790 C PTA07800 CALL BRING(IFLD,FILED,NPHR,NYPH,IGD,0,ITRKD,NRD,IPD,IRD,IID) PTA07810 NPCPT=INTFD(IID)+IPCADD PTA07820 C PTA07830 IF(ICARDA.EQ.3) WRITE(IPUNCH,3110) NPCPT,NTYPE,(FILED(IRD+J) PTA07840 * ,J=1,3) PTA07850 IF(IPRNTA.EQ.3) WRITE(IPR,3103) NPCPT,ICH(5),(FILED(IRD+J),J=1,3) PTA07860 IF(IFILE.NE.0) WRITE(IFILE) IZERO,NPCPT,NTYPE,(FILED(IRD+J),J=1,3)PTA07870 * ,ZERO,ZERO,ZERO,ZERO,ZEROPTA07880 C PTA07890 530 CONTINUE PTA07900 C PTA07910 IF(IFILE.EQ.0) GO TO 600 PTA07920 WRITE(IFILE) M99,M99,M99,ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ZERO PTA07930 END FILE IFILE PTA07940 C PTA07950 C PRINT PHOTO ORIENTATION/CALIBRATION PARAMETERS PTA07960 C KEEP INPUT DATA ON PUNCHED CARDS OR TAPE/DISK PTA07970 C PTA07980 600 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA07990 C PTA08000 IPRNT=IPRNTC PTA08010 IPRNTD=0 PTA08020 IF(IPRNT.EQ.2) IPRNTC=0 PTA08030 IF(IPRNT.GE.2.AND.IDIST.NE.0) IPRNTD=1 PTA08040 C PTA08050 IF(IDIST.EQ.0) WRITE(IPR,3501) PTA08060 IF(IDIST.NE.0) WRITE(IPR,3517) PTA08070 C PTA08080 IF(IPRNTC.EQ.0) WRITE(IPR,3502) PTA08090 IF(IPRNTD.EQ.0.AND.IDIST.NE.0) WRITE(IPR,3516) PTA08100 C PTA08110 IF(IPRNTC.EQ.0.AND.IPRNTD.EQ.0.AND.KFILE.EQ.0) GO TO 700 PTA08120 C PTA08130 CALL SORTD(IFLE,1,FILEE,FILED,INTFE,INTFD,TEMPE,NPHRE,IPHRE,NYPHE,PTA08140 * IYPHE)PTA08150 IF(KFILE.NE.0.OR.IPRNTD.NE.0) CALL SORTD(IFLH,2,FILEA,FILEB,INTFA,PTA08160 * INTFB,SUBA,NPTR,IPTR,NYPT,IYPT)PTA08170 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3510) PTA08180 C PTA08190 IF(IPRNTD.EQ.0) GO TO 605 PTA08200 C PTA08210 NE=0 PTA08220 K=-2 PTA08230 C PTA08240 DO 603 I=4,6 PTA08250 K=K+4 PTA08260 L=0 PTA08270 IF(ISET(I).EQ.0) GO TO 602 PTA08280 NE=NE+2 PTA08290 L=3 PTA08300 602 DO 603 J=1,3 PTA08310 FMTPT(K+J)=FMTDS(L+J) PTA08320 603 CONTINUE PTA08330 C PTA08340 605 IGE=0 PTA08350 IGH=0 PTA08360 C PTA08370 DO 650 KPH=1,NACCPH PTA08380 C PTA08390 CALL BRING(IFLE,FILEE,NPHRE,NYPHE,IGE,0,ITRKE,NRE,IPE,IRE,IIE) PTA08400 C PTA08410 IF(IPRNTC.NE.0.OR.IPRNTD.NE.0) WRITE(IPR,3503) INTFE(IIE) PTA08420 IF(IPRNTC.EQ.0) GO TO 625 PTA08430 C PTA08440 DO 607 K=5,7 PTA08450 CALL RADDMS(FILEE(IRE+K),ISUBA,K-4) PTA08460 607 CONTINUE PTA08470 C PTA08480 WRITE(IPR,3509) (FILEE(IRE+K),K=2,4),(ISUBA(K),K=1,18) PTA08490 * ,(FILEE(IRE+K),K=26,28) PTA08500 C PTA08510 IF(IDIST.EQ.0) GO TO 625 PTA08520 C PTA08530 IF(ISET(4).EQ.0) GO TO 615 PTA08540 C PTA08550 DO 610 I=29,31 PTA08560 ISUBA(I-28)=IPLUS PTA08570 IF(FILEE(IRE+I).LT.0.0) ISUBA(I-28)=MINUS PTA08580 610 TEMPC(I-28)=DABS(FILEE(IRE+I)) PTA08590 IF(ISUBA(1).EQ.IPLUS) ISUBA(1)=IBLK PTA08600 C PTA08610 WRITE(IPR,3504) (ISUBA(I),TEMPC(I),I=1,3) PTA08620 C PTA08630 615 IF(ISET(5).EQ.0) GO TO 620 PTA08640 C PTA08650 THETA=DATAN(-FILEE(IRE+32)/FILEE(IRE+33)) PTA08660 CALL RADDMS(THETA,ISUBA,1) PTA08670 DEC=DSQRT(FILEE(IRE+32)**2+FILEE(IRE+33)**2) PTA08680 C PTA08690 WRITE(IPR,3505) (ISUBA(I),I=1,6) PTA08700 WRITE(IPR,3506) DEC PTA08710 C PTA08720 620 IF(ISET(6).EQ.0) GO TO 625 PTA08730 C PTA08740 BETA=DATAN(FILEE(IRE+34)/(FILEE(IRE+35)+1.D0)) PTA08750 CALL RADDMS(BETA,ISUBA,1) PTA08760 DSY=DSQRT(FILEE(IRE+34)**2+(FILEE(IRE+35)+1.D0)**2) PTA08770 C PTA08780 WRITE(IPR,3507) (ISUBA(I),I=1,6) PTA08790 WRITE(IPR,3508) DSY PTA08800 C PTA08810 625 IF(IPRNTD.EQ.0.AND.KFILE.EQ.0) GO TO 650 PTA08820 C PTA08830 IF(IPRNTC.NE.0) WRITE(IPR,2) PTA08840 IF(IPRNTD.NE.0) WRITE(IPR,3518) PTA08850 C PTA08860 NPT=INTFE(IIE+1) PTA08870 IRB=-NYPT PTA08880 C PTA08890 DO 630 KPT=1,NPT PTA08900 CALL BRING(IFLH,FILEA,NPTR,NYPT,IGH,0,ITRKH,NRH,IPH,IRA,IIA) PTA08910 IRB=IRB+NYPT PTA08920 DO 630 J=1,NYPT PTA08930 630 FILEB(IRB+J)=FILEA(IRA+J-1) PTA08940 C PTA08950 CALL SORTB1(FILEB,INTFB,1,NPT,3,SUBA,NPTR,IPTR,NYPT,IYPT) PTA08960 C PTA08970 IRB=1-NYPT PTA08980 IIB=1-IYPT PTA08990 C PTA09000 DO 645 KPT=1,NPT PTA09010 C PTA09020 IRB=IRB+NYPT PTA09030 IIB=IIB+IYPT PTA09040 C PTA09050 IF(IPRNTD.EQ.0) GO TO 640 PTA09060 C PTA09070 XX0=FILEB(IRB+2)-FILEE(IRE+26) PTA09080 YY0=FILEB(IRB+3)-FILEE(IRE+27) PTA09090 C1=XX0**2 PTA09100 C2=YY0**2 PTA09110 C3=C1+C2 PTA09120 C PTA09130 ND=0 PTA09140 SUBA(NE+1)=0.0 PTA09150 SUBA(NE+2)=0.0 PTA09160 C PTA09170 IF(ISET(4).EQ.0) GO TO 632 PTA09180 RAD= FILEE(IRE+29)*C3+FILEE(IRE+30)*(C3**2)+FILEE(IRE+31)*(C3**3) PTA09190 SUBA(ND+1)=XX0*RAD PTA09200 SUBA(ND+2)=YY0*RAD PTA09210 SUBA(NE+1)=SUBA(NE+1)+SUBA(ND+1) PTA09220 SUBA(NE+2)=SUBA(NE+2)+SUBA(ND+2) PTA09230 ND=ND+2 PTA09240 C PTA09250 632 IF(ISET(5).EQ.0) GO TO 633 PTA09260 C4=C1+C1+C3 PTA09270 C5=C2+C2+C3 PTA09280 C6=XX0*YY0*2.0 PTA09290 SUBA(ND+1)=FILEE(IRE+32)*C4+FILEE(IRE+33)*C6 PTA09300 SUBA(ND+2)=FILEE(IRE+33)*C5+FILEE(IRE+32)*C6 PTA09310 SUBA(NE+1)=SUBA(NE+1)+SUBA(ND+1) PTA09320 SUBA(NE+2)=SUBA(NE+2)+SUBA(ND+2) PTA09330 ND=ND+2 PTA09340 C PTA09350 633 IF(ISET(6).EQ.0) GO TO 635 PTA09360 SUBA(ND+1)=FILEE(IRE+34)*YY0 PTA09370 SUBA(ND+2)=FILEE(IRE+35)*YY0 PTA09380 SUBA(NE+1)=SUBA(NE+1)+SUBA(ND+1) PTA09390 SUBA(NE+2)=SUBA(NE+2)+SUBA(ND+2) PTA09400 ND=ND+2 PTA09410 C PTA09420 635 SUBA(NE+3)=DSQRT(SUBA(NE+1)**2+SUBA(NE+2)**2) PTA09430 SUBA(NE+4)=XX0+SUBA(NE+1) PTA09440 SUBA(NE+5)=YY0+SUBA(NE+2) PTA09450 ND=NE+5 PTA09460 WRITE(IPR,FMTPT) INTFB(IIB+2),(SUBA(K),K=1,ND) PTA09470 IF(IPRNTC.NE.0.AND.KPT.EQ.NPT.AND.KPH.NE.NACCPH) WRITE(IPR,2) PTA09480 C PTA09490 640 IF(KFILE.EQ.0) GO TO 645 PTA09500 C PTA09510 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3511) (INTFB(IIB+J),J=1,2) PTA09520 * ,(FILEB(IRB+J),J=2,3) PTA09530 IF(KFILE.NE.IPUNCH) WRITE(KFILE) (INTFB(IIB+J),J=1,2) PTA09540 * ,(FILEB(IRB+J),J=2,3) PTA09550 645 CONTINUE PTA09560 C PTA09570 IF(KFILE.EQ.0) GO TO 650 PTA09580 C PTA09590 IF(IFID.EQ.0) GO TO 647 PTA09600 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3511) INTFE(IIE),INPP PTA09610 * ,(FILEE(IRE+J),J=26,27) PTA09620 IF(KFILE.NE.IPUNCH) WRITE(KFILE) INTFE(IIE),INPP,(FILEE(IRE+J) PTA09630 * ,J=26,27) PTA09640 647 IF(IPID.EQ.0) GO TO 650 PTA09650 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3511) INTFE(IIE),INPD PTA09660 * ,FILEE(IRE+28) PTA09670 IF(KFILE.NE.IPUNCH) WRITE(KFILE) INTFE(IIE),INPD,FILEE(IRE+28) PTA09680 * ,ZERO PTA09690 C PTA09700 650 CONTINUE PTA09710 C PTA09720 IF(KFILE.EQ.0) GO TO 700 PTA09730 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3110) M99 PTA09740 IF(KFILE.NE.IPUNCH) WRITE(KFILE) IZERO,M99,ZERO,ZERO PTA09750 C PTA09760 IGF=0 PTA09770 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3512) PTA09780 DO 660 KPT=1,KHO PTA09790 C PTA09800 CALL BRING(IFLF,FILEA,NHOR,NYHO,IGF,0,ITRKF,NRF,IPF,IRA,IIA) PTA09810 INDH=INTFA(IIA+1)/100000 PTA09820 SUBA(1)=FILEA(IRA+3) PTA09830 DO 655 I=1,2 PTA09840 655 SUBA(I+1)=FILEA(IRA+I)-SXYZ(I) PTA09850 C PTA09860 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3513) INTFA(IIA),(SUBA(I),I=2,3) PTA09870 * ,INDH PTA09880 IF(KFILE.NE.IPUNCH) WRITE(KFILE) INTFA(IIA),(SUBA(I),I=2,3),INDH PTA09890 C PTA09900 660 CONTINUE PTA09910 C PTA09920 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3513) M99 PTA09930 IF(KFILE.NE.IPUNCH) WRITE(KFILE) M99,ZERO,ZERO,IZERO PTA09940 C PTA09950 IGG=0 PTA09960 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3514) PTA09970 C PTA09980 DO 665 KPT=1,KVE PTA09990 C PTA10000 CALL BRING(IFLG,FILEB,NVER,NYVE,IGG,0,ITRKG,NRG,IPG,IRB,IIB) PTA10010 INDH=INTFB(IIB+1)/10000 PTA10020 INDV=INDH-(INDH/10)*10 PTA10030 ZV=FILEB(IRB+1)-FILEB(IRB+2) PTA10040 C PTA10050 IF(KFILE.EQ.IPUNCH) WRITE(IPUNCH,3515) INTFB(IIB),ZV,INDV PTA10060 IF(KFILE.NE.IPUNCH) WRITE(KFILE) INTFB(IIB),ZV,INDV PTA10070 C PTA10080 665 CONTINUE PTA10090 C PTA10100 IF(KFILE.NE.IPUNCH) GO TO 670 PTA10110 WRITE(IPUNCH,3515) M99 PTA10120 GO TO 700 PTA10130 670 WRITE(KFILE) M99,ZERO,IZERO PTA10140 END FILE KFILE PTA10150 C PTA10160 C PRINT LIST OF ADDITIONAL OUTPUTS PTA10170 C PTA10180 700 WRITE(IPR,3000) (IAUX(I),I=1,20) PTA10190 WRITE(IPR,3600) PTA10200 C PTA10210 IF(ICARDA.EQ.0.AND.ICARDB.EQ.0.AND.KFILE.NE.IPUNCH)WRITE(IPR,3601)PTA10220 IF(ICARDA.EQ.1.OR.ICARDA.EQ.3) WRITE(IPR,3602) PTA10230 IF(ICARDA.EQ.2) WRITE(IPR,3603) PTA10240 IF(ICARDB.EQ.1.OR.ICARDB.EQ.3) WRITE(IPR,3604) PTA10250 IF(ICARDB.GE.2) WRITE(IPR,3605) PTA10260 IF(ICARDA.EQ.3) WRITE(IPR,3603) PTA10270 IF(KFILE.EQ.IPUNCH) WRITE(IPR,3606) PTA10280 C PTA10290 IF(IFILE.EQ.0.AND.KFILE.EQ.0) GO TO 730 PTA10300 IF(IFILE.EQ.0.AND.KFILE.EQ.IPUNCH) GO TO 730 PTA10310 C PTA10320 IF(IFILE.GT.KFILE) GO TO 705 PTA10330 IGO=1 PTA10340 GO TO 710 PTA10350 705 IGO=2 PTA10360 GO TO 720 PTA10370 C PTA10380 710 IF(IFILE.EQ.0) GO TO 715 PTA10390 WRITE(IPR,3611) IFILE PTA10400 WRITE(IPR,3602) PTA10410 WRITE(IPR,3604) PTA10420 WRITE(IPR,3605) PTA10430 WRITE(IPR,3603) PTA10440 715 GO TO (720,750),IGO PTA10450 C PTA10460 720 IF(KFILE.EQ.0.OR.KFILE.EQ.IPUNCH) GO TO 725 PTA10470 WRITE(IPR,3611) KFILE PTA10480 WRITE(IPR,3606) PTA10490 725 GO TO (750,710),IGO PTA10500 C PTA10510 730 WRITE(IPR,3610) PTA10520 C PTA10530 750 RETURN PTA10540 C PTA10550 1 FORMAT(8I10) PTA10560 2 FORMAT(1H ) PTA10570 C PTA10580 3000 FORMAT(1H1,//, 5X,'UNBASC2-PROGRAM: ',20A4,'(PART-4)',/) PTA10590 3001 FORMAT(1H0,/,6X,'ADJUSTED COORDINATES OF OBJECT POINTS',/,6X,'---'PTA10600 * ,'----------------------------------') PTA10610 3002 FORMAT(1H0,/ ,6X,'NO PRINTOUT OF ADJUSTED COORDINATES OF OBJECT P'PTA10620 * ,'OINTS',//) PTA10630 3003 FORMAT(1H0,//,6X,'ADJUSTED COORDINATES OF HORIZONTAL CONTROL POIN'PTA10640 * ,'TS',/,6X,'-------------------------------------------------')PTA10650 3004 FORMAT(1H0,/,6X,'NO PRINTOUT OF ADJUSTED COORDINATES OF HORIZONTA'PTA10660 * ,'L CONTROL POINTS',//) PTA10670 3005 FORMAT(1H0,//,6X,'ADJUSTED COORDINATES OF VERTICAL CONTROL POINTS'PTA10680 * ,/,6X,'-----------------------------------------------') PTA10690 3006 FORMAT(1H0,/,6X,'NO PRINTOUT OF ADJUSTED COORDINATES OF VERTICAL 'PTA10700 * ,'CONTROL POINTS',//) PTA10710 C PTA10720 3101 FORMAT(1H0,/,6X,'PHOTO NUMBER',I10,/,6X,'----------------------', PTA10730 * //,6X,'(POINT NUMBER)',8X,'(X)',11X,'(Y)',10X,'(Z)', 8X, PTA10740 * '(PXG)', 4X,'(PYG)', 4X,'(PZG)', 6X,'(VXP)', 3X,'(VYP)',/) PTA10750 3102 FORMAT(1H ,I11,' (',A2,I2,')',2F14.5,F13.5,2X,3F10.5,3X,2F10.5) PTA10760 3103 FORMAT(1H ,I11,' (',A4,')',2F14.5,F13.5) PTA10770 3104 FORMAT(1H0,5X,'(POINT NUMBER)',8X,'(X)',11X,'(Y)',21X,'(VXG)',4X, PTA10780 * '(VYG)',14X,'(WEIGHT INDEX)',/) PTA10790 3105 FORMAT(1H ,I11,' (',A2,I2,')',2F14.5,15X,2F10.5,I22) PTA10800 3106 FORMAT(1H0,5X,'(POINT NUMBER)',35X,'(Z)',26X,'(VZG)', 5X,'(WEIGHT'PTA10810 * ,' INDEX)',/) PTA10820 3107 FORMAT(1H ,I11,' (',A2,I2,')',28X,F13.5,20X,F10.5,I13) PTA10830 3108 FORMAT(1H0,/,6X,'(POINT NUMBER)',8X,'(X)',11X,'(Y)',10X,'(Z)',/) PTA10840 3109 FORMAT(2I15,I5,3F15.5) PTA10850 3110 FORMAT(15X,I15,I5,3F15.5) PTA10860 3111 FORMAT(2I15,I5,30X,F15.5) PTA10870 C PTA10880 3201 FORMAT(1H0,/, 9X,'SUMMARY OF BUNDLE ADJUSTMENT STATISTICS',/, 9X, PTA10890 * '---------------------------------------',/) PTA10900 3202 FORMAT(1H0, 8X,'UNKNOWN PARAMETERS ASSIGNED TO EACH PHOTOGRAPH ..'PTA10910 * ,'... ',12A4) PTA10920 3203 FORMAT(1H0, 8X,'UNKNOWN PARAMETERS ASSIGNED TO EACH OBJECT POINT 'PTA10930 * ,'... ',3A4) PTA10940 3204 FORMAT(1H0, 8X,'TOTAL NUMBER OF UNKNOWNS IN NORMAL EQUATIONS ....'PTA10950 * ,'... ',I9) PTA10960 C PTA10970 3301 FORMAT(1H0,///,9X,'RESIDUALS OF PHOTO POINTS (IN PHOTO COORDINATE'PTA10980 * ,' UNIT)',/,9X,'--------------------------------------------'PTA10990 * ,'--------') PTA11000 3302 FORMAT(1H0,///,9X,'RESIDUAL PARALLAXES OF OBJECT POINTS (IN CONTR'PTA11010 * ,'OL COORDINATE UNIT)',/,9X,'-------------------------------'PTA11020 * ,'----------------------------------') PTA11030 3303 FORMAT(1H0,///,9X,'RESIDUALS OF CONTROL POINTS USED FOR BUNDLE AD'PTA11040 * ,'JUSTMENT (IN CONTROL COORDINATE UNIT)',/,9X,'-------------'PTA11050 * ,'----------------------------------------------------------'PTA11060 * ,'------------') PTA11070 3304 FORMAT(1H0,///,9X,'RESIDUALS OF CONTROL POINTS WEIGHTED BY NULL M'PTA11080 * ,'ATRICES (IN CONTROL COORDINATE UNIT)',/,9X,'--------------'PTA11090 * ,'----------------------------------------------------------'PTA11100 * ,'----------') PTA11110 3305 FORMAT(1H0,///,9X,'RESIDUALS OF ALL CONTROL POINTS (IN CONTROL CO'PTA11120 * ,'ORDINATE UNIT)',/,9X,'------------------------------------'PTA11130 * ,'------------------------') PTA11140 3306 FORMAT(1H0,///,9X,'RESIDUALS OF CONTROL POINTS WEIGHTED BY (PCTL 'PTA11150 * ,'NO.',I1,') (IN CONTROL COORDINATE UNIT)',/,9X,'-----------'PTA11160 * ,'----------------------------------------------------------'PTA11170 * ,'-----------') PTA11180 C PTA11190 3401 FORMAT(1H0, 8X,'RMS.',A4,' =',F9.5,5X,'N =',I6,5X,'(MAX.',A4,' =',PTA11200 * F9.5,2X,'AT POINT',I10,' IN PHOTO',I10,')') PTA11210 3402 FORMAT(1H0, 8X,'RMS.',A4,' =',F9.5,4X,'N =',I6,5X,'(MAX.',A4,' =',PTA11220 * F9.5,2X,'AT POINT',I10,')') PTA11230 3403 FORMAT(1H0, 8X,'RMS.',A4,' =',F9.5,4X,'N =',I6) PTA11240 C PTA11250 3501 FORMAT(1H0,/, 6X,'PHOTO ORIENTATION/CALIBRATION PARAMETERS',/, 6X,PTA11260 * '----------------------------------------',/) PTA11270 3502 FORMAT(1H0,/, 7X,'NO PRINTOUT OF PHOTO ORIENTATION/CALIBRATION PA'PTA11280 * ,'RAMETERS',/) PTA11290 3503 FORMAT(1H0,/, 7X,'PHOTO NUMBER',I10,/, 7X,'----------------------'PTA11300 * ,/) PTA11310 3504 FORMAT(1H0,10X,'RADIAL SYMMETRIC LENS DISTORTION FUNCTION:',//, PTA11320 * 16X,'DR = ',A1,'(',D12.6,')*(R**3) ',A1,' (',D12.6, PTA11330 * ')*(R**5) ',A1,' (',D12.6,')*(R**7)',/) PTA11340 3505 FORMAT(1H0,10X,'DECENTERING LENS DISTORTION:',//,13X,'THETA = ', PTA11350 * A4,I3,1X,2A1,1X,2A1,14X,'(DIRECTION OF MAXIMUM DISTORTION A'PTA11360 * ,'XIS)') PTA11370 3506 FORMAT(1H0,16X,'P = (',D12.6,')*(R**2)', 6X,'(DISTORTION FUNCTION'PTA11380 * ,' ALONG THIS AXIS)',/) PTA11390 3507 FORMAT(1H0,10X,'AFFINITY DISTORTION:',//,14X,'BETA = ',A4,I3,1X, PTA11400 * 2A1,1X,2A1,14X,'(DEVIATION FROM ORTHOGONALITY)') PTA11410 3508 FORMAT(1H0,15X,'SX = 1.000000',3X,'SY =',F9.6,3X,'(SCALE OF AXES)'PTA11420 * ,/)PTA11430 3509 FORMAT(1H , 10X,'XC =',F15.5,5X,'YC =',F15.5,5X,'ZC =',F15.5,//, PTA11440 * 11X,'OM =',2X,A4,I3,1X,2A1,1X,2A1,5X,'PH =',2X,A4,I3,1X,2A1,PTA11450 * 1X,2A1,5X,'KP =',2X,A4,I3,1X,2A1,1X,2A1,//,11X,'X0 =',F15.5,PTA11460 * 5X,'Y0 =',F15.5,5X,'PD =',F15.5,/) PTA11470 3510 FORMAT( 9X,'1 (2I15,2F15.5)') PTA11480 3511 FORMAT(2I15,2F15.5) PTA11490 3512 FORMAT(2X,'(I15,2F15.5,15X,I5)') PTA11500 3513 FORMAT(I15,2F15.5,15X,I5) PTA11510 3514 FORMAT(2X,'(I15,30X,F15.5,I5)') PTA11520 3515 FORMAT(I15,30X,F15.5,I5) PTA11530 3516 FORMAT(1H0,/, 7X,'NO PRINTOUT OF IMAGE DISTORTION COMPONENTS',/) PTA11540 3517 FORMAT(1H0,/, 6X,'PHOTO ORIENTATION/CALIBRATION PARAMETERS AND IM'PTA11550 * ,'AGE DISTORTION COMPONENTS',/, 6X,'------------------------'PTA11560 * ,'------------------------------------------------',/) PTA11570 3518 FORMAT(1H , 7X,'(POINT)',1X,'(RAD X)(RAD Y)',2X,'(DEC X)(DEC Y)',PTA11580 * 2X,'(AFF X)(AFF Y)',2X,'(SUM X)(SUM Y)(DIST.)',3X,'(REFINE'PTA11590 * ,'D X)',1X,'(REFINED Y)',/) PTA11600 C PTA11610 3600 FORMAT(1H0,/,10X,'ADDITIONAL OUTPUT',/,10X,'-----------------',///PTA11620 * ,10X,'PUNCHED CARDS ............') PTA11630 3601 FORMAT(1H+,36X,'NONE',//) PTA11640 3602 FORMAT(1H+,36X,'ADJUSTED COORDINATES OF OBJECT POINTS IN PHOTO NU'PTA11650 * ,'MBER SEQUENCE',//) PTA11660 3603 FORMAT(1H+,36X,'ADJUSTED COORDINATES OF OBJECT POINTS IN POINT NU'PTA11670 * ,'MBER SEQUENCE',//) PTA11680 3604 FORMAT(1H+,36X,'ADJUSTED COORDINATES OF HORIZONTAL CONTROL POINTS'PTA11690 * ,//) PTA11700 3605 FORMAT(1H+,36X,'ADJUSTED COORDINATES OF VERTICAL CONTROL POINTS', PTA11710 * //) PTA11720 3606 FORMAT(1H+,36X,'INPUT PHOTO COORDINATES AND CONTROL POINT COORDIN'PTA11730 * ,'ATES',//) PTA11740 3610 FORMAT(1H0, 9X,'TAPE/DISK ................ NONE') PTA11750 3611 FORMAT(1H0, 9X,'TAPE/DISK (FILE NO.',I2,') ...') PTA11760 C PTA11770 5001 FORMAT(1H ,9X,'***(ERROR)*** UNABLE TO PLACE IFCODE (',I10,') AT 'PTA11780 * ,'THE SPECIFIED DIGIT',I3) PTA11790 5002 FORMAT(1H ,9X,'***(ERROR)*** UNABLE TO PLACE IFCODE (',I10,') BET'PTA11800 * ,'WEEN THE SPECIFIED DIGITS',I3,' AND',I3) PTA11810 5003 FORMAT(1H ,9X,'***(ERROR)*** UNABLE TO PLACE IPCODE (',I10,') AT 'PTA11820 * ,'THE SPECIFIED DIGIT',I3) PTA11830 5004 FORMAT(1H ,9X,'***(ERROR)*** UNABLE TO PLACE IPCODE (',I10,') BET'PTA11840 * ,'WEEN THE SPECIFIED DIGITS',I3,' AND',I3) PTA11850 5005 FORMAT(1H , 9X,'***(ERROR)*** IFCODE AND IPCODE HAVE THE SAME COD'PTA11860 * ,'E (',I10,')') PTA11870 C PTA11880 END PTA11890 SUBROUTINE SETFIL(IFL,MAXREC,NTNY,N) PTA00010 IMPLICIT REAL*8(A-H,O-Z) PTA00020 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00030 COMMON /DISK02/MAXTRK PTA00040 COMMON /BUFFER/ITRKS(20),ITRKE(20),NTATE(20),NYOKO(20), PTA00050 * NETRK(20),NUNIT(20),LUNIT(20),LTAIL(20) PTA00060 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00070 C PTA00080 IF(IFL.EQ.1) NACCTK=0 PTA00090 IF(IFL.GE.2) NACCTK=ITRKE(IFL-1) PTA00100 ITRKS(IFL)=NACCTK+1 PTA00110 ITRKE(IFL)=NACCTK+((NTNY-1)/LTRK+1)*MAXREC*N PTA00120 C PTA00130 IF(ITRKE(IFL).LE.MAXTRK) RETURN PTA00140 C PTA00150 WRITE(IPR,1) IFL,MAXTRK PTA00160 STOP PTA00170 C PTA00180 1 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** UNABLE TO ALLOCATE EXTERNAL 'PTA00190 * ,'DISK SPACE FOR FILE',I3,/,31X,'MAXIMUM NUMBER OF TRACKS S'PTA00200 * ,'PECIFIED IN DEFINE FILE STATEMENT IS',I6) PTA00210 C PTA00220 END PTA00230 SUBROUTINE SETDIM(MAXDIM,NY, NTNY,NT,NTIY,IY) PTA00240 IMPLICIT REAL*8(A-H,O-Z) PTA00250 C PTA00260 NT=MAXDIM/NY PTA00270 NTNY=NT*NY PTA00280 NTIY=NTNY+NTNY PTA00290 IY=NY+NY PTA00300 C PTA00310 RETURN PTA00320 END PTA00330 SUBROUTINE OPEN(IFL,NTNY,NY) PTA00340 IMPLICIT REAL*8(A-H,O-Z) PTA00350 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00360 COMMON /BUFFER/ITRKS(20),ITRKE(20),NTATE(20),NYOKO(20), PTA00370 * NETRK(20),NUNIT(20),LUNIT(20),LTAIL(20) PTA00380 C PTA00390 NTRK(IFL)=0 PTA00400 NREC(IFL)=0 PTA00410 NTATE(IFL)=NTNY/NY PTA00420 NYOKO(IFL)=NY PTA00430 C PTA00440 NETRK(IFL)=0 PTA00450 CALL DIRECT(NTNY,LTRK,NUNIT(IFL),LUNIT(IFL),LTAIL(IFL),KK) PTA00460 RETURN PTA00470 END PTA00480 SUBROUTINE APUT(IFL,FILE,NTNY,IT,IDT, IRS,IIS, IR,II) PTA00490 IMPLICIT REAL*8(A-H,O-Z) PTA00500 DIMENSION FILE(NTNY) PTA00510 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00520 COMMON /BUFFER/ITRKS(20),ITRKE(20),NTATE(20),NYOKO(20), PTA00530 * NETRK(20),NUNIT(20),LUNIT(20),LTAIL(20) PTA00540 C PTA00550 IF(IT+IDT.LE.NTATE(IFL)) RETURN PTA00560 C PTA00570 NREC(IFL)=NREC(IFL)+IT PTA00580 NTRK(IFL)=NTRK(IFL)+1 PTA00590 CALL BPUT(IFL,NTRK(IFL),FILE,NTNY) PTA00600 C PTA00610 IT=0 PTA00620 IR=IRS-NYOKO(IFL) PTA00630 II=IIS-NYOKO(IFL)-NYOKO(IFL) PTA00640 C PTA00650 RETURN PTA00660 END PTA00670 SUBROUTINE BPUT(IFL,ITRK,FILE,NTNY) PTA00680 IMPLICIT REAL*8(A-H,O-Z) PTA00690 DIMENSION FILE(NTNY) PTA00700 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00710 COMMON /BUFFER/ITRKS(20),ITRKE(20),NTATE(20),NYOKO(20), PTA00720 * NETRK(20),NUNIT(20),LUNIT(20),LTAIL(20) PTA00730 C PTA00740 M=ITRKS(IFL)+(NUNIT(IFL)+1)*(ITRK-1) PTA00750 C PTA00760 IF(ITRK.EQ.NTRK(IFL)) GO TO 50 PTA00770 CALL LOADER(1,FILE,NTNY,M,NUNIT(IFL),LUNIT(IFL),0,LTAIL(IFL),NTNY,PTA00780 * ITRKE(IFL),IFL) PTA00790 RETURN PTA00800 C PTA00810 50 NR=NREC(IFL)-(NTRK(IFL)-1)*NTATE(IFL) PTA00820 NRNY=NR*NYOKO(IFL) PTA00830 CALL DIRECT(NRNY,LTRK,NUT,LUT,JS,JE) PTA00840 CALL LOADER(1,FILE,NTNY,M,NUT,LUT,0,JS,JE,ITRKE(IFL),IFL) PTA00850 RETURN PTA00860 END PTA00870 SUBROUTINE DPUT(IFL,FILE,FILES,KK,NTNY) PTA00880 IMPLICIT REAL*8(A-H,O-Z) PTA00890 DIMENSION FILE(NTNY),FILES(NTNY) PTA00900 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00910 COMMON /BUFFER/ITRKS(20),ITRKE(20),NTATE(20),NYOKO(20), PTA00920 * NETRK(20),NUNIT(20),LUNIT(20),LTAIL(20) PTA00930 C PTA00940 KKNY=KK*NYOKO(IFL) PTA00950 C PTA00960 IF(NTRK(IFL).NE.0) GO TO 100 PTA00970 C PTA00980 M=ITRKS(IFL) PTA00990 CALL DIRECT(KKNY,LTRK,NUT,LUT,JS,JE) PTA01000 CALL LOADER(1,FILE,NTNY,M,NUT,LUT,0,JS,JE,ITRKE(IFL),IFL) PTA01010 NREC(IFL)=KKNY PTA01020 NTRK(IFL)=1 PTA01030 RETURN PTA01040 C PTA01050 100 LEFT=NTNY-NREC(IFL) PTA01060 IF(LEFT.EQ.0) GO TO 130 PTA01070 C PTA01080 ITRK=NREC(IFL)/LTRK PTA01090 IREC=NREC(IFL)-ITRK*LTRK PTA01100 M=ITRKS(IFL)+(NUNIT(IFL)+1)*(NTRK(IFL)-1)+ITRK PTA01110 IF(IREC.NE.0) CALL LOADER(2,FILES,NTNY,M,0,0,0,1,IREC,ITRKE(IFL) PTA01120 * ,IFL) PTA01130 C PTA01140 IF(KKNY.GT.LEFT) GO TO 120 PTA01150 DO 110 I=1,KKNY PTA01160 110 FILES(IREC+I)=FILE(I) PTA01170 IREC=IREC+KKNY PTA01180 CALL DIRECT(IREC,LTRK,NUT,LUT,JS,JE) PTA01190 CALL LOADER(1,FILES,NTNY,M,NUT,LUT,0,JS,JE,ITRKE(IFL),IFL) PTA01200 NREC(IFL)=NREC(IFL)+KKNY PTA01210 RETURN PTA01220 C PTA01230 120 DO 125 I=1,LEFT PTA01240 125 FILES(IREC+I)=FILE(I) PTA01250 IREC=IREC+LEFT PTA01260 CALL DIRECT(IREC,LTRK,NUT,LUT,JS,JE) PTA01270 CALL LOADER(1,FILES,NTNY,M,NUT,LUT,0,JS,JE,ITRKE(IFL),IFL) PTA01280 C PTA01290 130 NTRK(IFL)=NTRK(IFL)+1 PTA01300 IREC=KKNY-LEFT PTA01310 M=ITRKS(IFL)+(NUNIT(IFL)+1)*(NTRK(IFL)-1) PTA01320 CALL DIRECT(IREC,LTRK,NUT,LUT,JS,JE) PTA01330 CALL LOADER(1,FILE,NTNY,M,NUT,LUT,LEFT,JS,JE,ITRKE(IFL),IFL) PTA01340 NREC(IFL)=IREC PTA01350 RETURN PTA01360 END PTA01370 SUBROUTINE ACLOSE(IFL,FILE,NTNY,IT) PTA01380 IMPLICIT REAL*8(A-H,O-Z) PTA01390 DIMENSION FILE(NTNY) PTA01400 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA01410 C PTA01420 NREC(IFL)=NREC(IFL)+IT PTA01430 IF(NTRK(IFL).EQ.0) RETURN PTA01440 C PTA01450 IF(IT.EQ.0) RETURN PTA01460 C PTA01470 NTRK(IFL)=NTRK(IFL)+1 PTA01480 CALL BPUT(IFL,NTRK(IFL),FILE,NTNY) PTA01490 RETURN PTA01500 END PTA01510 SUBROUTINE DCLOSE(IFL) PTA01520 IMPLICIT REAL*8(A-H,O-Z) PTA01530 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA01540 COMMON /BUFFER/ITRKS(20),ITRKE(20),NTATE(20),NYOKO(20), PTA01550 * NETRK(20),NUNIT(20),LUNIT(20),LTAIL(20) PTA01560 C PTA01570 NREC(IFL)=NREC(IFL)/NYOKO(IFL)+(NTRK(IFL)-1)*NTATE(IFL) PTA01580 RETURN PTA01590 END PTA01600 SUBROUTINE BGET(IFL,ITRK,FILE,NTNY,NR) PTA01610 IMPLICIT REAL*8(A-H,O-Z) PTA01620 DIMENSION FILE(NTNY) PTA01630 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA01640 COMMON /BUFFER/ITRKS(20),ITRKE(20),NTATE(20),NYOKO(20), PTA01650 * NETRK(20),NUNIT(20),LUNIT(20),LTAIL(20) PTA01660 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA01670 C PTA01680 IF(ITRK.GT.NTRK(IFL)) GO TO 8888 PTA01690 C PTA01700 M=ITRKS(IFL)+(NUNIT(IFL)+1)*(ITRK-1) PTA01710 C PTA01720 IF(ITRK.EQ.NTRK(IFL)) GO TO 60 PTA01730 NR=NTATE(IFL) PTA01740 CALL LOADER(2,FILE,NTNY,M,NUNIT(IFL),LUNIT(IFL),0,LTAIL(IFL),NTNY,PTA01750 * ITRKE(IFL),IFL) PTA01760 RETURN PTA01770 C PTA01780 60 NR=NREC(IFL)-(NTRK(IFL)-1)*NTATE(IFL) PTA01790 NRNY=NR*NYOKO(IFL) PTA01800 CALL DIRECT(NRNY,LTRK,NUT,LUT,JS,JE) PTA01810 CALL LOADER(2,FILE,NTNY,M,NUT,LUT,0,JS,JE,ITRKE(IFL),IFL) PTA01820 RETURN PTA01830 C PTA01840 8888 WRITE(IPR,888) IFL PTA01850 STOP PTA01860 C PTA01870 888 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** UNABLE TO FIND ACCESS TO FI',PTA01880 * 'LE',I3) PTA01890 C PTA01900 END PTA01910 SUBROUTINE DIRECT(MREC,LTRK,NUT,LUT,JS,JE) PTA01920 C PTA01930 NUT=(MREC-1)/LTRK PTA01940 LUT=LTRK PTA01950 IF(MREC.LT.LTRK) LUT=MREC PTA01960 JS=LUT*NUT+1 PTA01970 JE=MREC PTA01980 RETURN PTA01990 END PTA02000 SUBROUTINE LOADER(INOUT,FILE,NDIM,M,NUT,LUT,NS,JS,JE,LIM,IFL) PTA02010 IMPLICIT REAL*8(A-H,O-Z) PTA02020 DIMENSION FILE(NDIM) PTA02030 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA02040 C PTA02050 GO TO (200,300),INOUT PTA02060 C PTA02070 200 IF(NUT.EQ.0) GO TO 220 PTA02080 IS=1-LUT+NS PTA02090 IE=NS PTA02100 C PTA02110 DO 210 N=1,NUT PTA02120 IF(M.GT.LIM) GO TO 7777 PTA02130 IS=IS+LUT PTA02140 IE=IE+LUT PTA02150 WRITE(11,*) (FILE(I),I=IS,IE) PTA02160 210 M=M+1 PTA02170 C PTA02180 220 IF(M.GT.LIM) GO TO 7777 PTA02190 KS=JS+NS PTA02200 KE=JE+NS PTA02210 WRITE(11,*) (FILE(I),I=KS,KE) PTA02220 RETURN PTA02230 C PTA02240 300 IF(NUT.EQ.0) GO TO 320 PTA02250 IS=1-LUT+NS PTA02260 IE=NS PTA02270 C PTA02280 DO 310 N=1,NUT PTA02290 IS=IS+LUT PTA02300 IE=IE+LUT PTA02310 IF(M.GT.LIM) GO TO 8888 PTA02320 READ(11,*,END=8888) (FILE(I),I=IS,IE) PTA02330 310 M=M+1 PTA02340 C PTA02350 320 IF(M.GT.LIM) GO TO 8888 PTA02360 KS=JS+NS PTA02370 KE=JE+NS PTA02380 READ(11,*,END=8888) (FILE(I),I=KS,KE) PTA02390 RETURN PTA02400 C PTA02410 7777 WRITE(IPR,777) IFL PTA02420 STOP PTA02430 C PTA02440 8888 WRITE(IPR,888) IFL PTA02450 STOP PTA02460 C PTA02470 777 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** EXTERNAL FILE',I3,' OVERFLOW'PTA02480 * )PTA02490 888 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** UNABLE TO FIND ACCESS TO FI',PTA02500 * 'LE',I3) PTA02510 C PTA02520 END PTA02530 SUBROUTINE BRING(IFL,FILE,NTNY,NY,IG,KFL,ITRK,NR,IP,IR,II) PTA02540 IMPLICIT REAL*8(A-H,O-Z) PTA02550 DIMENSION FILE(NTNY) PTA02560 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA02570 C PTA02580 IF(IG.NE.0) GO TO 110 PTA02590 C PTA02600 IG=1 PTA02610 ITRK=1 PTA02620 NR=NREC(IFL) PTA02630 IF(NTRK(IFL).EQ.0) GO TO 105 PTA02640 C PTA02650 100 CALL BGET(IFL,ITRK,FILE,NTNY,NR) PTA02660 C PTA02670 105 IP=0 PTA02680 IR=1-NY PTA02690 II=IR-NY PTA02700 C PTA02710 110 IP=IP+1 PTA02720 IR=IR+NY PTA02730 II=II+NY+NY PTA02740 C PTA02750 IF(IP.LE.NR) RETURN PTA02760 IF(NTRK(IFL).EQ.0) RETURN PTA02770 C PTA02780 IF(KFL.NE.0) CALL BPUT(KFL,ITRK,FILE,NTNY) PTA02790 ITRK=ITRK+1 PTA02800 IF(ITRK.LE.NTRK(IFL)) GO TO 100 PTA02810 C PTA02820 RETURN PTA02830 END PTA02840 SUBROUTINE LOCATE(IFL,FILE,NTNY,NT,NY,KFL,LOC,ITRK,IR,II) PTA02850 IMPLICIT REAL*8(A-H,O-Z) PTA02860 DIMENSION FILE(NTNY) PTA02870 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA02880 C PTA02890 IF(NTRK(IFL).EQ.0) GO TO 100 PTA02900 IF(NTRK(IFL).NE.1) GO TO 110 PTA02910 IF(ITRK.EQ.1) GO TO 100 PTA02920 C PTA02930 CALL BGET(IFL,1,FILE,NTNY,NR) PTA02940 ITRK=1 PTA02950 C PTA02960 100 IR=(LOC-1)*NY+1 PTA02970 II=IR+IR-1 PTA02980 RETURN PTA02990 C PTA03000 110 KTRK=(LOC-1)/NT+1 PTA03010 IR=(LOC-(KTRK-1)*NT-1)*NY+1 PTA03020 II=IR+IR-1 PTA03030 C PTA03040 IF(ITRK.EQ.KTRK) RETURN PTA03050 C PTA03060 IF(KFL.EQ.0) GO TO 120 PTA03070 IF(ITRK.NE.0) CALL BPUT(KFL,ITRK,FILE,NTNY) PTA03080 120 CALL BGET(IFL,KTRK,FILE,NTNY,NR) PTA03090 ITRK=KTRK PTA03100 C PTA03110 RETURN PTA03120 END PTA03130 SUBROUTINE RCLEAR(FILE,NTNY,NS,NR) PTA03140 IMPLICIT REAL*8(A-H,O-Z) PTA03150 DIMENSION FILE(NTNY) PTA03160 C PTA03170 NE=NS+NR-1 PTA03180 DO 100 I=NS,NE PTA03190 100 FILE(I)=0.0 PTA03200 C PTA03210 RETURN PTA03220 END PTA03230 SUBROUTINE STORE(IFL,FILE,NTNY) PTA03240 IMPLICIT REAL*8(A-H,O-Z) PTA03250 DIMENSION FILE(NTNY) PTA03260 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA03270 C PTA03280 IF(NTRK(IFL).NE.0) RETURN PTA03290 C PTA03300 NTRK(IFL)=1 PTA03310 CALL BPUT(IFL,1,FILE,NTNY) PTA03320 C PTA03330 RETURN PTA03340 END PTA03350 SUBROUTINE COPYFL(IFLA,IFLB, FILEA,NTNY,NY) PTA03360 IMPLICIT REAL*8(A-H,O-Z) PTA03370 DIMENSION FILEA(NTNY) PTA03380 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA03390 C PTA03400 CALL OPEN(IFLB,NTNY,NY) PTA03410 C PTA03420 NTRK(IFLB)=NTRK(IFLA) PTA03430 NREC(IFLB)=NREC(IFLA) PTA03440 C PTA03450 IF(NTRK(IFLA).NE.0) GO TO 100 PTA03460 C PTA03470 NTRK(IFLB)=1 PTA03480 CALL BPUT(IFLB,1,FILEA,NTNY) PTA03490 RETURN PTA03500 C PTA03510 100 ITRKA=NTRK(IFLA) PTA03520 C PTA03530 DO 150 ITRK=1,ITRKA PTA03540 CALL BGET(IFLA,ITRK,FILEA,NTNY,NRA) PTA03550 CALL BPUT(IFLB,ITRK,FILEA,NTNY) PTA03560 150 CONTINUE PTA03570 C PTA03580 RETURN PTA03590 END PTA03600 SUBROUTINE SORTA(FILE,NS,NR,INDEX,TEMP,NTNY,NY) PTA03610 IMPLICIT REAL*8(A-H,O-Z) PTA03620 DIMENSION FILE(NTNY),TEMP(NY) PTA03630 C PTA03640 IF(NR.LE.1) RETURN PTA03650 AMAXNR=9.9D50 PTA03660 C PTA03670 JEND=NS+NR*NY-1 PTA03680 IEND=JEND-NY PTA03690 IS=NS+INDEX-1 PTA03700 C PTA03710 DO 200 I=IS,IEND,NY PTA03720 C PTA03730 AM=AMAXNR PTA03740 C PTA03750 DO 100 J=I,JEND,NY PTA03760 IF(FILE(J).GE.AM) GO TO 100 PTA03770 AM=FILE(J) PTA03780 K=J PTA03790 100 CONTINUE PTA03800 C PTA03810 IF(K.EQ.I) GO TO 200 PTA03820 C PTA03830 DO 150 L=1,NY PTA03840 KL=K+L-INDEX PTA03850 IL=I+L-INDEX PTA03860 TEMP(L)=FILE(KL) PTA03870 FILE(KL)=FILE(IL) PTA03880 150 FILE(IL)=TEMP(L) PTA03890 C PTA03900 200 CONTINUE PTA03910 C PTA03920 RETURN PTA03930 END PTA03940 SUBROUTINE SORTB(IFILE,NS,NR,INDEX,ITEMP,NTIY,IY) PTA03950 IMPLICIT REAL*8(A-H,O-Z) PTA03960 DIMENSION IFILE(NTIY),ITEMP(IY) PTA03970 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA03980 EQUIVALENCE (IAUX(23),INTDGT) PTA03990 C PTA04000 IF(NR.LE.1) RETURN PTA04010 C PTA04020 MAXNR=10**INTDGT+1 PTA04030 JEND=NS+NR*IY-1 PTA04040 IEND=JEND-IY PTA04050 IS=NS+INDEX-1 PTA04060 C PTA04070 DO 400 I=IS,IEND,IY PTA04080 C PTA04090 M=MAXNR PTA04100 C PTA04110 DO 300 J=I,JEND,IY PTA04120 IF(IFILE(J).GE.M) GO TO 300 PTA04130 M=IFILE(J) PTA04140 K=J PTA04150 300 CONTINUE PTA04160 C PTA04170 IF(K.EQ.I) GO TO 400 PTA04180 C PTA04190 DO 350 L=1,IY PTA04200 KL=K+L-INDEX PTA04210 IL=I+L-INDEX PTA04220 ITEMP(L)=IFILE(KL) PTA04230 IFILE(KL)=IFILE(IL) PTA04240 350 IFILE(IL)=ITEMP(L) PTA04250 C PTA04260 400 CONTINUE PTA04270 C PTA04280 RETURN PTA04290 END PTA04300 SUBROUTINE SORTB1(FILE,IFILE,NS,NR,INDEX,TEMP,NTNY,NTIY,NY,IY) PTA04310 IMPLICIT REAL*8(A-H,O-Z) PTA04320 DIMENSION FILE(NTNY),IFILE(NTIY),TEMP(NY) PTA04330 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA04340 EQUIVALENCE (IAUX(23),INTDGT) PTA04350 C PTA04360 IF(NR.LE.1) RETURN PTA04370 C PTA04380 MAXNR=10**INTDGT+1 PTA04390 JEND=NS+NR*IY-1 PTA04400 IEND=JEND-IY PTA04410 IS=NS+INDEX-1 PTA04420 C PTA04430 DO 20 I=IS,IEND,IY PTA04440 C PTA04450 M=MAXNR PTA04460 C PTA04470 DO 10 J=I,JEND,IY PTA04480 IF(IFILE(J).GE.M) GO TO 10 PTA04490 M=IFILE(J) PTA04500 K=J PTA04510 10 CONTINUE PTA04520 C PTA04530 IF(K.EQ.I) GO TO 20 PTA04540 C PTA04550 II=(I-INDEX+2)/2-1 PTA04560 KK=(K-INDEX+2)/2-1 PTA04570 C PTA04580 DO 15 L=1,NY PTA04590 KL=KK+L PTA04600 IL=II+L PTA04610 TEMP(L)=FILE(KL) PTA04620 FILE(KL)=FILE(IL) PTA04630 15 FILE(IL)=TEMP(L) PTA04640 C PTA04650 20 CONTINUE PTA04660 C PTA04670 RETURN PTA04680 END PTA04690 SUBROUTINE SORTB2(FILE,IFILE,NS,NR,INDEX,TEMP,NTNY,NTIY,NY,IY) PTA04700 IMPLICIT REAL*8(A-H,O-Z) PTA04710 DIMENSION FILE(NTNY),IFILE(NTIY),TEMP(NY) PTA04720 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA04730 EQUIVALENCE (IAUX(23),INTDGT) PTA04740 C PTA04750 IF(NR.LE.1) RETURN PTA04760 C PTA04770 MINNR=-(10**INTDGT+1) PTA04780 JEND=NS+NR*IY-1 PTA04790 IEND=JEND-IY PTA04800 IS=NS+INDEX-1 PTA04810 C PTA04820 DO 40 I=IS,IEND,IY PTA04830 C PTA04840 M=MINNR PTA04850 C PTA04860 DO 30 J=I,JEND,IY PTA04870 IF(IFILE(J).LE.M) GO TO 30 PTA04880 M=IFILE(J) PTA04890 K=J PTA04900 30 CONTINUE PTA04910 C PTA04920 IF(K.EQ.I) GO TO 40 PTA04930 C PTA04940 II=(I-INDEX+2)/2-1 PTA04950 KK=(K-INDEX+2)/2-1 PTA04960 C PTA04970 DO 35 L=1,NY PTA04980 KL=KK+L PTA04990 IL=II+L PTA05000 TEMP(L)=FILE(KL) PTA05010 FILE(KL)=FILE(IL) PTA05020 35 FILE(IL)=TEMP(L) PTA05030 C PTA05040 40 CONTINUE PTA05050 C PTA05060 RETURN PTA05070 END PTA05080 SUBROUTINE SORTC(IFLA,INDEX,FILEA,FILEB,TEMP,NTNY,NY) PTA05090 IMPLICIT REAL*8(A-H,O-Z) PTA05100 DIMENSION FILEA(NTNY),FILEB(NTNY),TEMP(NY) PTA05110 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA05120 C PTA05130 IF(INDEX.EQ.0) RETURN PTA05140 C PTA05150 NRA=NREC(IFLA) PTA05160 MTRK=NTRK(IFLA) PTA05170 C PTA05180 IF(MTRK.GE.1) GO TO 100 PTA05190 C PTA05200 C SORT IN CORE PTA05210 C PTA05220 50 CALL SORTA(FILEA,1,NRA,INDEX,TEMP,NTNY,NY) PTA05230 IF(MTRK.EQ.1) CALL BPUT(IFLA,MTRK,FILEA,NTNY) PTA05240 RETURN PTA05250 C PTA05260 C SORT ON EXTERNAL DISK PTA05270 C PTA05280 100 CALL BGET(IFLA,1,FILEA,NTNY,NRA) PTA05290 IF(MTRK.EQ.1) GO TO 50 PTA05300 CALL SORTA(FILEA,1,NRA,INDEX,TEMP,NTNY,NY) PTA05310 IAS=INDEX PTA05320 IBS=INDEX PTA05330 C PTA05340 DO 400 IBTRK=2,MTRK PTA05350 C PTA05360 CALL BGET(IFLA,IBTRK,FILEB,NTNY,NRB) PTA05370 IBE=NRB*NY PTA05380 KTRK=IBTRK-1 PTA05390 C PTA05400 DO 300 IATRK=1,KTRK PTA05410 C PTA05420 IF(IBTRK.NE.2) CALL BGET(IFLA,IATRK,FILEA,NTNY,NRA) PTA05430 IAE=NRA*NY PTA05440 C PTA05450 DO 200 IA=IAS,IAE,NY PTA05460 C PTA05470 SMALL=FILEA(IA) PTA05480 C PTA05490 DO 110 IB=IBS,IBE,NY PTA05500 IF(FILEB(IB).GE.SMALL) GO TO 110 PTA05510 SMALL=FILEB(IB) PTA05520 KK=IB PTA05530 110 CONTINUE PTA05540 C PTA05550 IF(SMALL.EQ.FILEA(IA)) GO TO 200 PTA05560 C PTA05570 DO 150 L=1,NY PTA05580 KL=KK+L-INDEX PTA05590 IL=IA+L-INDEX PTA05600 TEMP(L)=FILEB(KL) PTA05610 FILEB(KL)=FILEA(IL) PTA05620 150 FILEA(IL)=TEMP(L) PTA05630 C PTA05640 200 CONTINUE PTA05650 C PTA05660 CALL BPUT(IFLA,IATRK,FILEA,NTNY) PTA05670 C PTA05680 300 CONTINUE PTA05690 C PTA05700 CALL SORTA(FILEB,1,NRB,INDEX,TEMP,NTNY,NY) PTA05710 CALL BPUT(IFLA,IBTRK,FILEB,NTNY) PTA05720 C PTA05730 400 CONTINUE PTA05740 C PTA05750 RETURN PTA05760 END PTA05770 SUBROUTINE SORTD(IFLA,INDEX,FILEA,FILEB,INTFA,INTFB,TEMP,NTNY,NTIYPTA05780 * ,NY,IY)PTA05790 IMPLICIT REAL*8(A-H,O-Z) PTA05800 DIMENSION FILEA(NTNY),FILEB(NTNY),INTFA(NTIY),INTFB(NTIY),TEMP(NY)PTA05810 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA05820 C PTA05830 IF(INDEX.EQ.0) RETURN PTA05840 C PTA05850 NRA=NREC(IFLA) PTA05860 MTRK=NTRK(IFLA) PTA05870 C PTA05880 IF(MTRK.GE.1) GO TO 100 PTA05890 C PTA05900 C SORT IN CORE PTA05910 C PTA05920 50 CALL SORTB1(FILEA,INTFA,1,NRA,INDEX,TEMP,NTNY,NTIY,NY,IY) PTA05930 IF(MTRK.EQ.1) CALL BPUT(IFLA,MTRK,FILEA,NTNY) PTA05940 RETURN PTA05950 C PTA05960 C SORT ON EXTERNAL DISK PTA05970 C PTA05980 100 CALL BGET(IFLA,1,FILEA,NTNY,NRA) PTA05990 IF(MTRK.EQ.1) GO TO 50 PTA06000 CALL SORTB1(FILEA,INTFA,1,NRA,INDEX,TEMP,NTNY,NTIY,NY,IY) PTA06010 IAS=INDEX PTA06020 IBS=INDEX PTA06030 C PTA06040 DO 400 IBTRK=2,MTRK PTA06050 C PTA06060 CALL BGET(IFLA,IBTRK,FILEB,NTNY,NRB) PTA06070 IBE=NRB*IY PTA06080 KTRK=IBTRK-1 PTA06090 C PTA06100 DO 300 IATRK=1,KTRK PTA06110 C PTA06120 IF(IBTRK.NE.2) CALL BGET(IFLA,IATRK,FILEA,NTNY,NRA) PTA06130 IAE=NRA*IY PTA06140 C PTA06150 DO 200 IA=IAS,IAE,IY PTA06160 C PTA06170 LESS=INTFA(IA) PTA06180 C PTA06190 DO 110 IB=IBS,IBE,IY PTA06200 IF(INTFB(IB).GE.LESS) GO TO 110 PTA06210 LESS=INTFB(IB) PTA06220 KB=IB PTA06230 110 CONTINUE PTA06240 C PTA06250 IF(LESS.EQ.INTFA(IA)) GO TO 200 PTA06260 C PTA06270 II=(IA-INDEX+2)/2-1 PTA06280 KK=(KB-INDEX+2)/2-1 PTA06290 C PTA06300 DO 150 L=1,NY PTA06310 KL=KK+L PTA06320 IL=II+L PTA06330 TEMP(L)=FILEB(KL) PTA06340 FILEB(KL)=FILEA(IL) PTA06350 150 FILEA(IL)=TEMP(L) PTA06360 C PTA06370 200 CONTINUE PTA06380 C PTA06390 CALL BPUT(IFLA,IATRK,FILEA,NTNY) PTA06400 C PTA06410 300 CONTINUE PTA06420 C PTA06430 CALL SORTB1(FILEB,INTFB,1,NRB,INDEX,TEMP,NTNY,NTIY,NY,IY) PTA06440 CALL BPUT(IFLA,IBTRK,FILEB,NTNY) PTA06450 C PTA06460 400 CONTINUE PTA06470 C PTA06480 RETURN PTA06490 END PTA06500 SUBROUTINE ERRSTP(IPR) PTA06510 IMPLICIT REAL*8(A-H,O-Z) PTA06520 C PTA06530 WRITE(IPR,1) PTA06540 STOP PTA06550 C PTA06560 1 FORMAT(1H0,//,10X,'PROGRAM EXECUTION IS TERMINATED DUE TO ERROR-S'PTA06570 * ,'TOP CONDITION') PTA06580 C PTA06590 END PTA06600 SUBROUTINE TESTCD(ITYPE,ICODE,IDGTA,IDGTB,ICDID,IHI,LOW,IERR) PTA06610 IMPLICIT REAL*8(A-H,O-Z) PTA06620 DIMENSION CODA(2),CODB(2),CODC(2) PTA06630 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA06640 EQUIVALENCE (IAUX(23),INTDGT) PTA06650 DATA CODA/8HIFCODE (,8HIPCODE (/,CODB/8HIFDGTA (,8HIPDGTA (/ PTA06660 * ,CODC/8HIFDGTB (,8HIPDGTB (/ PTA06670 C PTA06680 IERR=0 PTA06690 ICDID=0 PTA06700 IHI=0 PTA06710 LOW=0 PTA06720 C PTA06730 IF(IDGTA.NE.0 .OR. IDGTB.NE.0) GO TO 100 PTA06740 IHI=-1 PTA06750 RETURN PTA06760 C PTA06770 100 ICDID=1 PTA06780 IF(ICODE.GE.0) GO TO 105 PTA06790 WRITE(IPR,5101) CODA(ITYPE),ICODE PTA06800 IERR=1 PTA06810 C PTA06820 105 IF(IDGTA.GE.1 .AND. IDGTA.LE.INTDGT) GO TO 110 PTA06830 WRITE(IPR,5102) CODB(ITYPE),IDGTA,INTDGT PTA06840 IERR=1 PTA06850 C PTA06860 110 IF(IDGTB.GE.1 .AND. IDGTB.LE.INTDGT) GO TO 120 PTA06870 WRITE(IPR,5103) CODC(ITYPE),IDGTB,INTDGT PTA06880 IERR=1 PTA06890 C PTA06900 120 IF(IERR.NE.0) RETURN PTA06910 IHI=IDGTA PTA06920 LOW=IDGTB PTA06930 IF(IHI.GE.LOW) RETURN PTA06940 IHI=IDGTB PTA06950 LOW=IDGTA PTA06960 RETURN PTA06970 C PTA06980 5101 FORMAT(1H , 9X,'***(ERROR)*** READ-IN ',A8,I10,') MAY NOT BE NEGA'PTA06990 * ,'TIVE') PTA07000 5102 FORMAT(1H , 9X,'***(ERROR)*** READ-IN ',A8,I10,') MUST BE AN INTE'PTA07010 * ,'GER BETWEEN 1 AND',I3) PTA07020 5103 FORMAT(1H , 9X,'***(ERROR)*** READ-IN ',A8,I10,') MUST BE AN INTE'PTA07030 * ,'GER BETWEEN 1 AND',I3) PTA07040 END PTA07050 SUBROUTINE LISTPD(IPH,IPT,PD0,PDIN,MERR) PTA07060 IMPLICIT REAL*8(A-H,O-Z) PTA07070 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA07080 C PTA07090 IF(PDIN.NE.0.0) GO TO 100 PTA07100 WRITE(IPR,1) IPT,IPH PTA07110 MERR=1 PTA07120 RETURN PTA07130 C PTA07140 100 IF(PD0.EQ.0.0) GO TO 110 PTA07150 WRITE(IPR,2) IPH PTA07160 RETURN PTA07170 C PTA07180 110 PD0=PDIN PTA07190 RETURN PTA07200 C PTA07210 1 FORMAT(1H , 9X,'***(ERROR)*** READ-IN PRINCIPAL DISTANCE OF POINT'PTA07220 * ,I10,' IN PHOTO',I10,' MAY NOT BE ZERO') PTA07230 2 FORMAT(1H , 9X,'***(WARNING)*** READ-IN PRINCIPAL DISTANCE IN PHO'PTA07240 * ,'TO',I10,' WAS ALREADY DEFINED') PTA07250 END PTA07260 SUBROUTINE TESTPD(MPID,IPT,IPCODE,IPDIVL,IPDIVH) PTA07270 IMPLICIT REAL*8(A-H,O-Z) PTA07280 C PTA07290 IF(MPID.NE.0) RETURN PTA07300 C PTA07310 IPPT=IPT/IPDIVL PTA07320 IPCD=IPPT-(IPPT/IPDIVH)*IPDIVH PTA07330 IF(IPCD.EQ.IPCODE) MPID=2 PTA07340 C PTA07350 RETURN PTA07360 END PTA07370 SUBROUTINE TESTFD(MFID,IFLOC,IPT,IFCODE,IFDIVL,IFDIVH,NFDIVL) PTA07380 IMPLICIT REAL*8(A-H,O-Z) PTA07390 C PTA07400 IFPT=IPT/IFDIVL PTA07410 IFCD=IFPT-(IFPT/IFDIVH)*IFDIVH PTA07420 C PTA07430 IF(IFCD.NE.IFCODE) RETURN PTA07440 C PTA07450 MFID=1 PTA07460 IFNO=IPT/NFDIVL PTA07470 IFLOC=IFNO-(IFNO/10)*10 PTA07480 RETURN PTA07490 END PTA07500 SUBROUTINE LISTFD(IPH,IPT,IFLOC,NFID,LERR,FIDXY,IFIDXY,FILEC,IRC, PTA07510 * NPTR) PTA07520 IMPLICIT REAL*8(A-H,O-Z) PTA07530 DIMENSION FIDXY(5,2),FILEC(NPTR),IFIDXY(5,2) PTA07540 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA07550 C PTA07560 IF(IFLOC.GE.0 .AND. IFLOC.LE.4) GO TO 100 PTA07570 WRITE(IPR, 1) IFLOC,IPT,IPH PTA07580 LERR=1 PTA07590 RETURN PTA07600 C PTA07610 100 IP=IFLOC PTA07620 IF(IP.EQ.0) IP=5 PTA07630 IF(IFIDXY(IP,1).EQ.0) GO TO 110 PTA07640 WRITE(IPR, 2) IFLOC,IPT,IPH PTA07650 LERR=1 PTA07660 RETURN PTA07670 C PTA07680 110 IFIDXY(IP,1)=IP PTA07690 IFIDXY(IP,2)=IPT PTA07700 NFID=NFID+1 PTA07710 FIDXY(IP,1)=FILEC(IRC+2) PTA07720 FIDXY(IP,2)=FILEC(IRC+3) PTA07730 RETURN PTA07740 C PTA07750 1 FORMAT(1H , 9X,'***(WARNING)*** FIDUCIAL NUMBER (',I2,') OF POINT'PTA07760 * ,I10,' IN PHOTO',I10,' IS OUT OF RANGE ( 0, 4)') PTA07770 2 FORMAT(1H , 9X,'***(WARNING)*** FIDUCIAL NUMBER (',I2,') OF POINT'PTA07780 * ,I10,' IN PHOTO',I10,' WAS ALREADY DEFINED') PTA07790 C PTA07800 END PTA07810 SUBROUTINE FIDUPT(IPH,NFID,LERR,FIDXY,IFIDXY) PTA07820 IMPLICIT REAL*8(A-H,O-Z) PTA07830 DIMENSION FIDXY(5,2),ATA(2,3),IFIDXY(5,2) PTA07840 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA07850 C PTA07860 IF(IFIDXY(5,1).EQ.0) GO TO 105 PTA07870 C PTA07880 DO 100 J=1,4 PTA07890 IF(IFIDXY(J,1).EQ.0) GO TO 100 PTA07900 WRITE(IPR,10) IFIDXY(J,2),IFIDXY(5,2),IPH PTA07910 100 CONTINUE PTA07920 RETURN PTA07930 C PTA07940 105 DO 110 J=1,4 PTA07950 IF(IFIDXY(J,1).NE.0) GO TO 110 PTA07960 MISS=J PTA07970 WRITE(IPR,11) J,IPH PTA07980 IF(NFID.LE.2) LERR=1 PTA07990 110 CONTINUE PTA08000 C PTA08010 IF(LERR.NE.0) RETURN PTA08020 C PTA08030 IFIDXY(5,1)=NFID PTA08040 C PTA08050 DO 115 I=1,2 PTA08060 ATA(I,1)=FIDXY(I+2,2)-FIDXY(I,2) PTA08070 ATA(I,2)=FIDXY(I,1)-FIDXY(I+2,1) PTA08080 ATA(I,3)=FIDXY(I,1)*FIDXY(I+2,2)-FIDXY(I+2,1)*FIDXY(I,2) PTA08090 115 CONTINUE PTA08100 C PTA08110 IF(NFID.EQ.4) GO TO 120 PTA08120 C PTA08130 ICC=1 PTA08140 IF(MISS.EQ.2 .OR. MISS.EQ.4) ICC=2 PTA08150 NOMISS=ICC*2+2-MISS PTA08160 C PTA08170 ATA(ICC,1)=-ATA(3-ICC,2) PTA08180 ATA(ICC,2)= ATA(3-ICC,1) PTA08190 ATA(ICC,3)=FIDXY(NOMISS,1)*ATA(ICC,1)+FIDXY(NOMISS,2)*ATA(ICC,2) PTA08200 C PTA08210 120 D=ATA(1,1)*ATA(2,2)-ATA(2,1)*ATA(1,2) PTA08220 C PTA08230 IF(D.EQ.0.0) GO TO 150 PTA08240 C PTA08250 DO 140 K=1,2 PTA08260 140 FIDXY(5,K)=(ATA(3-K,3-K)*ATA(K,3)-ATA(K,3-K)*ATA(3-K,3))/D PTA08270 RETURN PTA08280 C PTA08290 150 WRITE(IPR,12) IPH PTA08300 LERR=1 PTA08310 RETURN PTA08320 C PTA08330 10 FORMAT(1H , 9X,'***(WARNING)*** FIDUCIAL POINT',I10,' WAS DELETE'PTA08340 * ,'D BY READ-IN P.P.',I10,' IN PHOTO',I10) PTA08350 11 FORMAT(1H , 9X,'***(WARNING)*** FIDUCIAL NUMBER (',I2,') OF PHOTO'PTA08360 * ,I10,' IS MISSING') PTA08370 12 FORMAT(1H , 9X,'***(WARNING)*** FIDUCIAL LINES IN PHOTO',I10,' D'PTA08380 * ,'O NOT INTERSECT') PTA08390 C PTA08400 END PTA08410 SUBROUTINE SHIFT(IFILE,IACCE,NPH,IPG,IPHR) PTA08420 IMPLICIT REAL*8(A-H,O-Z) PTA08430 DIMENSION IFILE(IPHR) PTA08440 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA08450 EQUIVALENCE (IAUX(29), IYPH),(IAUX(30), MTPH) PTA08460 C PTA08470 IF(IPG.EQ.1) GO TO 100 PTA08480 IF(NPH.LE.6) WRITE(IPR,1) NPH,IPG,(IFILE(IACCE+I),I=1,NPH) PTA08490 IF(NPH.GE.7) WRITE(IPR,2) NPH,IPG,(IFILE(IACCE+I),I=1,NPH) PTA08500 C PTA08510 100 IF(IACCE+NPH*IYPH.GT.IPHR) GO TO 160 PTA08520 C PTA08530 DO 150 I=1,NPH PTA08540 JPH=IACCE+NPH-I+1 PTA08550 N=IACCE+(NPH-I)*IYPH+1 PTA08560 150 IFILE(N)=IFILE(JPH) PTA08570 RETURN PTA08580 C PTA08590 160 WRITE(IPR,3) MTPH PTA08600 CALL ERRSTP(IPR) PTA08610 STOP PTA08620 C PTA08630 1 FORMAT(1H0,I11,' PHOTO(S) ALLOCATED IN GROUP',I3,' :',6I10) PTA08640 2 FORMAT(1H0,I11,' PHOTO(S) ALLOCATED IN GROUP',I3,' :',6I10,/, PTA08650 * (45X,6I10)) PTA08660 3 FORMAT(1H0, 9X,'***(ERROR)*** OVER FLOW - MAXIMUM NUMBER OF PHOTO'PTA08670 * ,'S IN ONE PHOTO-GROUP =',I5) PTA08680 C PTA08690 END PTA08700 SUBROUTINE FINDPH(IFLD,FILED,INTFD,FILEE,INTFE,IACCE,NPH,NPHR,IPHRPTA08710 * )PTA08720 IMPLICIT REAL*8(A-H,O-Z) PTA08730 DIMENSION FILED(NPHR),FILEE(NPHR),INTFD(IPHR),INTFE(IPHR) PTA08740 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA08750 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA08760 EQUIVALENCE (IAUX(25), NYPH),(IAUX(29), IYPH) PTA08770 C PTA08780 JJ=IACCE+1 PTA08790 JR=(JJ+1)/2-1 PTA08800 JEND=IACCE+NPH*IYPH PTA08810 IF(NTRK(IFLD).EQ.0) GO TO 200 PTA08820 MTRK=NTRK(IFLD) PTA08830 C PTA08840 DO 140 ITRK=1,MTRK PTA08850 C PTA08860 CALL BGET(IFLD,ITRK,FILED,NPHR,NRD) PTA08870 II=1 PTA08880 IR=0 PTA08890 IEND=NRD*IYPH PTA08900 C PTA08910 100 IF(INTFD(II).EQ.INTFE(JJ)) GO TO 125 PTA08920 II=II+IYPH PTA08930 IR=IR+NYPH PTA08940 IF(II.GT.IEND) GO TO 140 PTA08950 GO TO 100 PTA08960 C PTA08970 125 DO 130 L=1,NYPH PTA08980 130 FILEE(JR+L)=FILED(IR+L) PTA08990 INTFE(JJ+3)=NPH PTA09000 JJ=JJ+IYPH PTA09010 JR=JR+NYPH PTA09020 IF(JJ.GT.JEND) RETURN PTA09030 II=II+IYPH PTA09040 IR=IR+NYPH PTA09050 IF(II.LE.IEND) GO TO 100 PTA09060 C PTA09070 140 CONTINUE PTA09080 C PTA09090 RETURN PTA09100 C PTA09110 200 II=1 PTA09120 IR=0 PTA09130 IEND=NREC(IFLD)*IYPH PTA09140 C PTA09150 210 IF(INTFD(II).EQ.INTFE(JJ)) GO TO 225 PTA09160 215 II=II+IYPH PTA09170 IR=IR+NYPH PTA09180 IF(II.LE.IEND) GO TO 210 PTA09190 RETURN PTA09200 C PTA09210 225 DO 230 L=1,NYPH PTA09220 230 FILEE(JR+L)=FILED(IR+L) PTA09230 INTFE(JJ+3)=NPH PTA09240 JJ=JJ+IYPH PTA09250 JR=JR+NYPH PTA09260 IF(JJ.LE.JEND) GO TO 215 PTA09270 RETURN PTA09280 END PTA09290 SUBROUTINE SEARCH(IFL,FILE,NS,NR, FILES,NTNY,NY,NOWTRK) PTA09300 IMPLICIT REAL*8(A-H,O-Z) PTA09310 DIMENSION FILE(NTNY),FILES(NTNY) PTA09320 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA09330 C PTA09340 MTRK=NTRK(IFL) PTA09350 NT=NTNY/NY PTA09360 C PTA09370 IF(MTRK.GE.1) GO TO 100 PTA09380 NRA=NREC(IFL) PTA09390 NOWTRK=1 PTA09400 C PTA09410 100 ITRK=(NS-1)/NT+1 PTA09420 IS=NS-(ITRK-1)*NT PTA09430 IIS=(IS-1)*NY+1 PTA09440 IP=0 PTA09450 IIP=1-NY PTA09460 C PTA09470 110 IF(ITRK.EQ.NOWTRK) GO TO 120 PTA09480 CALL BGET(IFL,ITRK,FILE,NTNY,NRA) PTA09490 NOWTRK=ITRK PTA09500 C PTA09510 120 IP=IP+1 PTA09520 IIP=IIP+NY PTA09530 DO 125 L=1,NY PTA09540 125 FILES(IIP+L-1)=FILE(IIS+L-1) PTA09550 IF(IP.EQ.NR) GO TO 150 PTA09560 C PTA09570 IS=IS+1 PTA09580 IIS=IIS+NY PTA09590 IF(IS.LE.NRA) GO TO 120 PTA09600 ITRK=ITRK+1 PTA09610 IF(ITRK.GT.MTRK) GO TO 150 PTA09620 IS=1 PTA09630 IIS=1 PTA09640 GO TO 110 PTA09650 C PTA09660 150 RETURN PTA09670 END PTA09680 SUBROUTINE LINKA(INTFA,IPTR,NN,NIA,IPLOC,INC) PTA00010 IMPLICIT REAL*8(A-H,O-Z) PTA00020 DIMENSION INTFA(IPTR) PTA00030 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00040 EQUIVALENCE (IAUX(28), IYPT) PTA00050 C PTA00060 IF(INC.GT.0) GO TO 110 PTA00070 C PTA00080 DO 100 IA=NN,NIA,IYPT PTA00090 IF(INTFA(IA).LT.0) GO TO 100 PTA00100 IPLOC=IPLOC+INC PTA00110 INTFA(IA)=IPLOC PTA00120 100 CONTINUE PTA00130 RETURN PTA00140 C PTA00150 110 DO 150 IA=NN,NIA,IYPT PTA00160 IF(INTFA(IA).GT.0) GO TO 150 PTA00170 IPLOC=IPLOC+INC PTA00180 INTFA(IA)=IPLOC PTA00190 150 CONTINUE PTA00200 RETURN PTA00210 END PTA00220 SUBROUTINE LINKB(INTFP,INTFB,INTFC,IPHR,IPTR,IB,NES,NIE,NOWTRK, PTA00230 * ITRK,ICHNG)PTA00240 IMPLICIT REAL*8(A-H,O-Z) PTA00250 DIMENSION INTFP(IPHR),INTFB(IPTR),INTFC(IPTR) PTA00260 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00270 EQUIVALENCE (IAUX(29), IYPH) PTA00280 C PTA00290 DO 120 IE=NES,NIE,IYPH PTA00300 IF(INTFP(IE).NE.INTFB(IB)) GO TO 120 PTA00310 INTFB(IB)=0 PTA00320 IF(NOWTRK.EQ.ITRK) INTFC(IB)=0 PTA00330 ICHNG=1 PTA00340 120 CONTINUE PTA00350 C PTA00360 RETURN PTA00370 END PTA00380 SUBROUTINE LINKBI(INTFP,INTFC,IPHR,IPTR,IB,NES,NIE) PTA00390 IMPLICIT REAL*8(A-H,O-Z) PTA00400 DIMENSION INTFP(IPHR),INTFC(IPTR) PTA00410 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00420 EQUIVALENCE (IAUX(29), IYPH) PTA00430 C PTA00440 DO 220 IE=NES,NIE,IYPH PTA00450 IF(INTFP(IE).NE.INTFC(IB)) GO TO 220 PTA00460 INTFC(IB)=0 PTA00470 220 CONTINUE PTA00480 RETURN PTA00490 END PTA00500 SUBROUTINE LINKC(INTFP,INTFA,INTFB,INTFC,IPHR,IPTR,NN,NIA,IB,IACCEPTA00510 * ,MPH,IPG,NOWTRK,ITRK,ICHNG)PTA00520 IMPLICIT REAL*8(A-H,O-Z) PTA00530 DIMENSION INTFP(IPHR),INTFA(IPTR),INTFB(IPTR),INTFC(IPTR) PTA00540 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00550 EQUIVALENCE (IAUX(28), IYPT) PTA00560 C PTA00570 DO 130 IA=NN,NIA,IYPT PTA00580 IF(INTFA(IA+2).NE.INTFB(IB+2)) GO TO 130 PTA00590 INTFA(IA+3)=INTFA(IA+3)+1 PTA00600 IF(INTFB(IB)) 130,110,100 PTA00610 100 CALL FILLFL(INTFB(IB),INTFP,IACCE,MPH,IPG+1,IPHR) PTA00620 110 INTFB(IB)=INTFA(IA) PTA00630 IF(NOWTRK.EQ.ITRK) INTFC(IB)=INTFA(IA) PTA00640 ICHNG=1 PTA00650 130 CONTINUE PTA00660 C PTA00670 RETURN PTA00680 END PTA00690 SUBROUTINE LINKCI(INTFP,INTFC,IPHR,IPTR,NN,NIA,IB,IACCE,MPH,IPG) PTA00700 IMPLICIT REAL*8(A-H,O-Z) PTA00710 DIMENSION INTFP(IPHR),INTFC(IPTR) PTA00720 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00730 EQUIVALENCE (IAUX(28), IYPT) PTA00740 C PTA00750 DO 230 IA=NN,NIA,IYPT PTA00760 IF(INTFC(IA+2).NE.INTFC(IB+2)) GO TO 230 PTA00770 INTFC(IA+3)=INTFC(IA+3)+1 PTA00780 IF(INTFC(IB)) 230,210,200 PTA00790 200 CALL FILLFL(INTFC(IB),INTFP,IACCE,MPH,IPG+1,IPHR) PTA00800 210 INTFC(IB)=INTFC(IA) PTA00810 230 CONTINUE PTA00820 C PTA00830 RETURN PTA00840 END PTA00850 SUBROUTINE LINKD(INTFA,INTFB,IPTR,NN,NIA,MM,MIB,ICHNG) PTA00860 IMPLICIT REAL*8(A-H,O-Z) PTA00870 DIMENSION INTFA(IPTR),INTFB(IPTR) PTA00880 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00890 EQUIVALENCE (IAUX(28), IYPT) PTA00900 C PTA00910 DO 110 IB=MM,MIB,IYPT PTA00920 IF(INTFB(IB).GT.0) GO TO 110 PTA00930 DO 100 IA=NN,NIA,IYPT PTA00940 IF(INTFB(IB+2).NE.INTFA(IA+2)) GO TO 100 PTA00950 INTFB(IB)=INTFA(IA) PTA00960 ICHNG=1 PTA00970 GO TO 110 PTA00980 100 CONTINUE PTA00990 110 CONTINUE PTA01000 C PTA01010 RETURN PTA01020 END PTA01030 SUBROUTINE LINKDI(INTFA,IPTR,NN,NIA,MM,MIB) PTA01040 IMPLICIT REAL*8(A-H,O-Z) PTA01050 DIMENSION INTFA(IPTR) PTA01060 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA01070 EQUIVALENCE (IAUX(28), IYPT) PTA01080 C PTA01090 DO 210 IB=MM,MIB,IYPT PTA01100 IF(INTFA(IB).GT.0) GO TO 210 PTA01110 DO 200 IA=NN,NIA,IYPT PTA01120 IF(INTFA(IB+2).NE.INTFA(IA+2)) GO TO 200 PTA01130 INTFA(IB)=INTFA(IA) PTA01140 GO TO 210 PTA01150 200 CONTINUE PTA01160 210 CONTINUE PTA01170 C PTA01180 RETURN PTA01190 END PTA01200 SUBROUTINE FILLFL(LPH,IFILE,IACCE,NPH,IPG,IPHR) PTA01210 IMPLICIT REAL*8(A-H,O-Z) PTA01220 DIMENSION IFILE(IPHR) PTA01230 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA01240 EQUIVALENCE (IAUX(30), MTPH) PTA01250 C PTA01260 IF(NPH.EQ.0) GO TO 110 PTA01270 C PTA01280 DO 105 J=1,NPH PTA01290 IF(LPH.EQ.IFILE(IACCE+J)) RETURN PTA01300 105 CONTINUE PTA01310 C PTA01320 110 NPH=NPH+1 PTA01330 IF(IACCE+NPH.GT.IPHR) GO TO 120 PTA01340 IFILE(IACCE+NPH)=LPH PTA01350 RETURN PTA01360 C PTA01370 120 NPH=NPH-1 PTA01380 IF(NPH.LE.6) WRITE(IPR,1) NPH,IPG,(IFILE(IACCE+I),I=1,NPH) PTA01390 IF(NPH.GE.7) WRITE(IPR,2) NPH,IPG,(IFILE(IACCE+I),I=1,NPH) PTA01400 WRITE(IPR,3) MTPH PTA01410 CALL ERRSTP(IPR) PTA01420 STOP PTA01430 C PTA01440 1 FORMAT(1H0,I11,' PHOTO(S) ALLOCATED IN GROUP',I3,' :',6I10) PTA01450 2 FORMAT(1H0,I11,' PHOTO(S) ALLOCATED IN GROUP',I3,' :',6I10,/, PTA01460 * (45X,6I10)) PTA01470 3 FORMAT(1H0, 9X,'***(ERROR)*** OVER FLOW - MAXIMUM NUMBER OF PHOTO'PTA01480 * ,'S IN ONE PHOTO-GROUP =',I5) PTA01490 C PTA01500 END PTA01510 SUBROUTINE TRACEP(LPH,LPHLOC,INTFP,IIP,NTIY) PTA01520 IMPLICIT REAL*8(A-H,O-Z) PTA01530 DIMENSION INTFP(NTIY) PTA01540 C PTA01550 IF(INTFP(IIP).EQ.0) GO TO 200 PTA01560 IF(IABS(LPH).LT.IABS(INTFP(IIP+1))) GO TO 200 PTA01570 C PTA01580 NOFF=INTFP(IIP) PTA01590 DO 100 I=1,NOFF PTA01600 IF(IABS(LPH).EQ.IABS(INTFP(IIP+I))) GO TO 210 PTA01610 100 CONTINUE PTA01620 C PTA01630 200 LPHLOC=0 PTA01640 RETURN PTA01650 C PTA01660 210 LPHLOC=I PTA01670 RETURN PTA01680 END PTA01690 SUBROUTINE TRACEQ(LPH,LPHLOC,INTFP,IIP,NTIY) PTA01700 IMPLICIT REAL*8(A-H,O-Z) PTA01710 DIMENSION INTFP(NTIY) PTA01720 C PTA01730 IF(INTFP(IIP).EQ.0) GO TO 200 PTA01740 C PTA01750 NOFF=INTFP(IIP) PTA01760 DO 100 I=1,NOFF PTA01770 IF(LPH.EQ.INTFP(IIP+I)) GO TO 210 PTA01780 100 CONTINUE PTA01790 C PTA01800 200 LPHLOC=0 PTA01810 RETURN PTA01820 C PTA01830 210 LPHLOC=I PTA01840 RETURN PTA01850 END PTA01860 SUBROUTINE TRACER(LPH,LPHLOC,INTFP,IIP,IY,NTIY) PTA01870 IMPLICIT REAL*8(A-H,O-Z) PTA01880 DIMENSION INTFP(NTIY) PTA01890 C PTA01900 IF(INTFP(IIP).EQ.0) GO TO 200 PTA01910 IF(IABS(LPH).LT.IABS(INTFP(IIP+1))) GO TO 200 PTA01920 C PTA01930 NOFF=INTFP(IIP) PTA01940 DO 100 I=1,NOFF PTA01950 IF(IABS(LPH).EQ.IABS(INTFP(IIP+I))) GO TO 210 PTA01960 100 CONTINUE PTA01970 C PTA01980 200 LPHLOC=0 PTA01990 RETURN PTA02000 C PTA02010 210 LPHLOC=INTFP(IIP+IY-1)+I-1 PTA02020 RETURN PTA02030 END PTA02040 SUBROUTINE ADDXY(X,NXS,Y,NYS,NR,ISGN,NXDIM,NYDIM) PTA02050 IMPLICIT REAL*8(A-H,O-Z) PTA02060 DIMENSION X(NXDIM),Y(NYDIM) PTA02070 C PTA02080 IXS=NXS-1 PTA02090 IYS=NYS-1 PTA02100 C PTA02110 IF(ISGN.LT.0) GO TO 110 PTA02120 C PTA02130 DO 100 I=1,NR PTA02140 100 X(IXS+I)=X(IXS+I)+Y(IYS+I) PTA02150 C PTA02160 RETURN PTA02170 C PTA02180 110 DO 120 I=1,NR PTA02190 120 X(IXS+I)=X(IXS+I)-Y(IYS+I) PTA02200 C PTA02210 RETURN PTA02220 END PTA02230 SUBROUTINE ACCXTX(X,NXS,N,Z,NZS,NXDIM,NZDIM) PTA02240 IMPLICIT REAL*8(A-H,O-Z) PTA02250 DIMENSION X(NXDIM),Z(NZDIM) PTA02260 C PTA02270 KS=NXS-1 PTA02280 C PTA02290 DO 110 K=1,N PTA02300 C PTA02310 KZ=(K*K-K)/2+NZS-1 PTA02320 KB=KS+N*(K-1) PTA02330 C PTA02340 DO 110 J=1,K PTA02350 C PTA02360 JA=KS+N*(J-1) PTA02370 IZ=KZ+J PTA02380 R=0.D0 PTA02390 C PTA02400 DO 100 I=1,N PTA02410 R=R+X(JA+I)*X(KB+I) PTA02420 100 CONTINUE PTA02430 C PTA02440 Z(IZ)=Z(IZ)-R PTA02450 C PTA02460 110 CONTINUE PTA02470 C PTA02480 RETURN PTA02490 END PTA02500 SUBROUTINE ACCXTY(X,NXS,Y,NYS,N,Z,NZS,NXYDIM,NZDIM) PTA02510 IMPLICIT REAL*8(A-H,O-Z) PTA02520 DIMENSION X(NXYDIM),Y(NXYDIM),Z(NZDIM) PTA02530 C PTA02540 IZ=NZS-1 PTA02550 IK=NYS-N-1 PTA02560 C PTA02570 DO 110 K=1,N PTA02580 C PTA02590 IK=IK+N PTA02600 IX=NXS-1 PTA02610 C PTA02620 DO 110 J=1,N PTA02630 C PTA02640 IY=IK PTA02650 IZ=IZ+1 PTA02660 R=0.D0 PTA02670 C PTA02680 DO 100 I=1,N PTA02690 IX=IX+1 PTA02700 IY=IY+1 PTA02710 R=R+X(IX)*Y(IY) PTA02720 100 CONTINUE PTA02730 C PTA02740 Z(IZ)=Z(IZ)-R PTA02750 C PTA02760 110 CONTINUE PTA02770 C PTA02780 RETURN PTA02790 END PTA02800 SUBROUTINE FACTOR(ATA,NS,N,NADIM) PTA02810 IMPLICIT REAL*8(A-H,O-Z) PTA02820 DIMENSION ATA(NADIM) PTA02830 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA02840 C PTA02850 KPIV=NS-1 PTA02860 C PTA02870 DO 150 K=1,N PTA02880 C PTA02890 KPIV=KPIV+K PTA02900 IND=KPIV PTA02910 LEND=K-1 PTA02920 C PTA02930 DO 140 I=K,N PTA02940 C PTA02950 DSUM=0.0 PTA02960 C PTA02970 IF(LEND.EQ.0) GO TO 110 PTA02980 C PTA02990 DO 100 L=1,LEND PTA03000 LANF=KPIV-L PTA03010 LIND=IND-L PTA03020 DSUM=DSUM+ATA(LANF)*ATA(LIND) PTA03030 100 CONTINUE PTA03040 C PTA03050 110 DSUM=ATA(IND)-DSUM PTA03060 C PTA03070 IF(I.NE.K) GO TO 120 PTA03080 C PTA03090 IF(DSUM.LE.0.0) GO TO 500 PTA03100 C PTA03110 DPIV=DSQRT(DSUM) PTA03120 ATA(KPIV)=DPIV PTA03130 DPIV=1.D0/DPIV PTA03140 GO TO 130 PTA03150 C PTA03160 120 ATA(IND)=DSUM*DPIV PTA03170 C PTA03180 130 IND=IND+I PTA03190 C PTA03200 140 CONTINUE PTA03210 C PTA03220 150 CONTINUE PTA03230 C PTA03240 RETURN PTA03250 C PTA03260 500 WRITE(IPR,1) PTA03270 CALL ERRSTP(IPR) PTA03280 STOP PTA03290 C PTA03300 1 FORMAT(1H0, 9X,'***(ERROR)*** NORMAL EQUATION MATRIX IS NOT SYMM',PTA03310 * 'ETRIC POSITIVE DEFINITE',/,24X,'CHOLESKY',1H','S FACTORI',PTA03320 * 'ZATION FAILED') PTA03330 C PTA03340 END PTA03350 SUBROUTINE XIV(X,NXS,V,NVS,N,NXDIM,NVDIM) PTA03360 IMPLICIT REAL*8(A-H,O-Z) PTA03370 DIMENSION X(NXDIM),V(NVDIM) PTA03380 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA03390 C PTA03400 IVS=NVS+N-1 PTA03410 NM1=N-1 PTA03420 NSTA=NXS+(N*N+N)/2-1 PTA03430 C PTA03440 IF(X(NSTA).EQ.0.0) GO TO 500 PTA03450 C PTA03460 V(IVS)=V(IVS)/X(NSTA) PTA03470 C PTA03480 IF(NM1.EQ.0) RETURN PTA03490 C PTA03500 DO 120 J=1,NM1 PTA03510 C PTA03520 NSTA=NSTA-1 PTA03530 C PTA03540 DSUM=0.D0 PTA03550 L=NSTA PTA03560 LDX=-NM1 PTA03570 LL=IVS PTA03580 C PTA03590 DO 110 K=1,J PTA03600 DSUM=DSUM-X(L)*V(LL) PTA03610 LL=LL-1 PTA03620 L=L+LDX PTA03630 110 LDX=LDX+1 PTA03640 C PTA03650 IF(X(L).EQ.0.0) GO TO 500 PTA03660 C PTA03670 120 V(LL)=(DSUM+V(LL))/X(L) PTA03680 C PTA03690 RETURN PTA03700 C PTA03710 500 WRITE(IPR,1) PTA03720 CALL ERRSTP(IPR) PTA03730 STOP PTA03740 C PTA03750 1 FORMAT(1H0, 9X,'***(ERROR)*** FACTORIZED NORMAL EQUATION MATRIX ',PTA03760 * 'IS SINGULAR') PTA03770 C PTA03780 END PTA03790 SUBROUTINE XTIV(X,NXS,V,NVS,N,NXDIM,NVDIM) PTA03800 IMPLICIT REAL*8(A-H,O-Z) PTA03810 DIMENSION X(NXDIM),V(NVDIM) PTA03820 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA03830 C PTA03840 NM1=N-1 PTA03850 NSTA=NXS PTA03860 MDEL=1 PTA03870 C PTA03880 IF(X(NSTA).EQ.0.0) GO TO 500 PTA03890 C PTA03900 V(NVS)=V(NVS)/X(NSTA) PTA03910 C PTA03920 IF(NM1.EQ.0) RETURN PTA03930 C PTA03940 DO 120 J=1,NM1 PTA03950 C PTA03960 NSTA=NSTA+MDEL PTA03970 MDEL=MDEL+1 PTA03980 C PTA03990 DSUM=0.D0 PTA04000 L=NSTA PTA04010 LL=NVS PTA04020 C PTA04030 DO 110 K=1,J PTA04040 DSUM=DSUM-X(L)*V(LL) PTA04050 LL=LL+1 PTA04060 110 L=L+1 PTA04070 C PTA04080 IF(X(L).EQ.0.0) GO TO 500 PTA04090 C PTA04100 120 V(LL)=(DSUM+V(LL))/X(L) PTA04110 C PTA04120 RETURN PTA04130 C PTA04140 500 WRITE(IPR,1) PTA04150 CALL ERRSTP(IPR) PTA04160 STOP PTA04170 C PTA04180 1 FORMAT(1H0, 9X,'***(ERROR)*** FACTORIZED NORMAL EQUATION MATRIX ',PTA04190 * 'IS SINGULAR') PTA04200 C PTA04210 END PTA04220 SUBROUTINE XTIY(X,NXS,Y,NYS,NYR,N,NXYDIM) PTA04230 IMPLICIT REAL*8(A-H,O-Z) PTA04240 DIMENSION X(NXYDIM),Y(NXYDIM) PTA04250 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA04260 C PTA04270 NYE=NYS+NYR-1 PTA04280 NM1=N-1 PTA04290 NSTA=NXS PTA04300 MDEL=1 PTA04310 C PTA04320 IF(X(NSTA).EQ.0.0) GO TO 500 PTA04330 C PTA04340 DO 100 I=NYS,NYE,N PTA04350 100 Y(I)=Y(I)/X(NSTA) PTA04360 C PTA04370 IF(NM1.EQ.0) RETURN PTA04380 C PTA04390 DO 120 J=1,NM1 PTA04400 C PTA04410 NSTA=NSTA+MDEL PTA04420 MDEL=MDEL+1 PTA04430 C PTA04440 DO 120 I=NYS,NYE,N PTA04450 C PTA04460 DSUM=0.D0 PTA04470 L=NSTA PTA04480 LL=I PTA04490 C PTA04500 DO 110 K=1,J PTA04510 DSUM=DSUM-X(L)*Y(LL) PTA04520 LL=LL+1 PTA04530 110 L=L+1 PTA04540 C PTA04550 IF(X(L).EQ.0.0) GO TO 500 PTA04560 C PTA04570 120 Y(LL)=(DSUM+Y(LL))/X(L) PTA04580 C PTA04590 RETURN PTA04600 C PTA04610 500 WRITE(IPR,1) PTA04620 CALL ERRSTP(IPR) PTA04630 STOP PTA04640 C PTA04650 1 FORMAT(1H0, 9X,'***(ERROR)*** FACTORIZED NORMAL EQUATION MATRIX ',PTA04660 * 'IS SINGULAR') PTA04670 C PTA04680 END PTA04690 SUBROUTINE ADDRES(FILED,FILEE,CTC,INTFD,INTFE,INTCTC,NPHDIM,IPHDIMPTA04700 * ,NORDIM,IORDIM) PTA04710 IMPLICIT REAL*8(A-H,O-Z) PTA04720 C PTA04730 DIMENSION FILED(NPHDIM),FILEE(NPHDIM),CTC(NORDIM),INTFD(IPHDIM), PTA04740 * INTFE(IPHDIM),INTCTC(IORDIM) PTA04750 C PTA04760 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA04770 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA04780 COMMON /DISK02/MAXTRK,MXBAND PTA04790 C PTA04800 EQUIVALENCE (IAUX(32),NACCPH),(IAUX(43), NYPHI),(IAUX(44), NYPHJ) PTA04810 * ,(IAUX(45), NYPHK),(IAUX(49),NPHOFF),(IAUX(50),MAXROW) PTA04820 C PTA04830 DATA IFLI,IFLJ,IFLK/9,10,11/ PTA04840 C PTA04850 C SET UP FILE DIMENSION PTA04860 C PTA04870 CALL SETDIM(NPHDIM,NYPHI, NPHRI,NTPHI,IPHRI,IYPHI) PTA04880 C PTA04890 C SET UP (FILEJ)=(COLUMNWISE PHOTO-ADDRESS MATRIX, REGULAR) PTA04900 C PTA04910 NYPHJ=(MAXROW+3)/2 PTA04920 CALL SETDIM(NPHDIM,NYPHJ, NPHRJ,NTPHJ,IPHRJ,IYPHJ) PTA04930 C PTA04940 C (NOTE: NPHJRC TAKES MAX.VALUE WHEN NACCPH=MAXPH AND NTPHJ=NPHDIM/NNN, PTA04950 C WHERE NNN=(MXBAND+3)/2 PTA04960 C PTA04970 NPHJRC=(NACCPH-1)/NTPHJ+1 PTA04980 CALL SETFIL(IFLJ,NPHJRC,NPHRJ,1) PTA04990 C PTA05000 CALL OPEN(IFLJ,NPHRJ,NYPHJ) PTA05010 C PTA05020 IPH=0 PTA05030 IID=1-IYPHJ PTA05040 IYPHJ1=IYPHJ-1 PTA05050 C PTA05060 DO 110 ILP=1,NACCPH PTA05070 C PTA05080 KE=(ILP*ILP-ILP)/2 PTA05090 NPH=MAXROW PTA05100 IF(ILP.LE.MAXROW) NPH=ILP-1 PTA05110 KS=KE-NPH+1 PTA05120 IF(ILP.LE.2) KS=ILP-1 PTA05130 C PTA05140 CALL APUT(IFLJ,FILED,NPHRJ, IPH,1, 0,1, IRD,IID) PTA05150 IPH=IPH+1 PTA05160 IID=IID+IYPHJ PTA05170 C PTA05180 DO 100 I=1,IYPHJ1 PTA05190 100 INTFD(IID+I)=0 PTA05200 C PTA05210 INTFD(IID)=NPH PTA05220 C PTA05230 IF(NPH.EQ.0) GO TO 110 PTA05240 C PTA05250 J=0 PTA05260 DO 105 JLP=KS,KE PTA05270 J=J+1 PTA05280 105 INTFD(IID+J)=-JLP PTA05290 C PTA05300 110 CONTINUE PTA05310 C PTA05320 CALL ACLOSE(IFLJ,FILED,NPHRJ,IPH) PTA05330 C PTA05340 IGI=0 PTA05350 IGJ=0 PTA05360 C PTA05370 DO 120 I=1,NACCPH PTA05380 C PTA05390 CALL BRING(IFLI,FILEE,NPHRI,NYPHI,IGI, 0,ITRKI,NRE,IPE,IRE,IIE) PTA05400 CALL BRING(IFLJ,FILED,NPHRJ,NYPHJ,IGJ,IFLJ,ITRKJ,NRD,IPD,IRD,IID) PTA05410 C PTA05420 NPH=INTFD(IID) PTA05430 IF(NPH.EQ.0) GO TO 120 PTA05440 C PTA05450 DO 115 J=1,NPH PTA05460 C PTA05470 CALL TRACEP(INTFD(IID+J),LOC,INTFE,IIE,IPHRI) PTA05480 IF(LOC.NE.0) INTFD(IID+J)=IABS(INTFD(IID+J)) PTA05490 C PTA05500 115 CONTINUE PTA05510 120 CONTINUE PTA05520 C PTA05530 IF(ITRKJ.EQ.NTRK(IFLJ)) CALL BPUT(IFLJ,ITRKJ,FILED,NPHRJ) PTA05540 C PTA05550 C SEARCH FOR PSEUDO NULL-SUBMATRICES WITHIN A BAND PTA05560 C PTA05570 ITRKJ=0 PTA05580 KEND=1 PTA05590 C PTA05600 DO 190 KLP=1,NACCPH PTA05610 C PTA05620 IF(KLP.LE.2) GO TO 190 PTA05630 C PTA05640 KOFF=KLP-2 PTA05650 KSTA=KEND+1 PTA05660 KEND=KEND+KOFF+1 PTA05670 C PTA05680 ITC=1 PTA05690 ITB=0 PTA05700 C PTA05710 DO 180 ILP=1,KOFF PTA05720 C PTA05730 ITC=ITC+1 PTA05740 IOB=KSTA-1 PTA05750 KSPI=KSTA+ILP PTA05760 C PTA05770 CALL LOCATE(IFLJ,FILED,NPHRJ,NTPHJ,NYPHJ,IFLJ,KLP,ITRKJ,IRD,IID) PTA05780 C PTA05790 IF(KSPI.LT.IABS(INTFD(IID+1))) GO TO 150 PTA05800 C PTA05810 CALL TRACEQ(KSPI,LOC,INTFD,IID,IPHRJ) PTA05820 IF(LOC.EQ.0) GO TO 155 PTA05830 C PTA05840 150 IOB=IOB+ILP PTA05850 ITB=ITB+ILP PTA05860 GO TO 180 PTA05870 C PTA05880 155 DO 170 JLP=1,ILP PTA05890 C PTA05900 IOB=IOB+1 PTA05910 ITB=ITB+1 PTA05920 C PTA05930 CALL LOCATE(IFLJ,FILED,NPHRJ,NTPHJ,NYPHJ,IFLJ,KLP,ITRKJ,IRD,IID) PTA05940 CALL TRACEQ(IOB,LOC,INTFD,IID,IPHRJ) PTA05950 IF(LOC.EQ.0) GO TO 170 PTA05960 C PTA05970 CALL LOCATE(IFLJ,FILED,NPHRJ,NTPHJ,NYPHJ,IFLJ,ITC,ITRKJ,IRD,IID) PTA05980 CALL TRACEQ(ITB,LOC,INTFD,IID,IPHRJ) PTA05990 IF(LOC.EQ.0) GO TO 170 PTA06000 C PTA06010 CALL LOCATE(IFLJ,FILED,NPHRJ,NTPHJ,NYPHJ,IFLJ,KLP,ITRKJ,IRD,IID) PTA06020 CALL TRACEP(KSPI,LOC,INTFD,IID,IPHRJ) PTA06030 C PTA06040 IF(LOC.NE.0) GO TO 160 PTA06050 WRITE(IPR,1) PTA06060 STOP PTA06070 C PTA06080 160 INTFD(IID+LOC)=IABS(INTFD(IID+LOC)) PTA06090 C PTA06100 170 CONTINUE PTA06110 180 CONTINUE PTA06120 190 CONTINUE PTA06130 C PTA06140 IF(NTRK(IFLJ).NE.0) CALL BPUT(IFLJ,ITRKJ,FILED,NPHRJ) PTA06150 C PTA06160 IGI=0 PTA06170 IGJ=0 PTA06180 C PTA06190 DO 200 I=1,NACCPH PTA06200 C PTA06210 CALL BRING(IFLI,FILEE,NPHRI,NYPHI,IGI, 0,ITRKI,NRE,IPE,IRE,IIE) PTA06220 CALL BRING(IFLJ,FILED,NPHRJ,NYPHJ,IGJ,IFLJ,ITRKJ,NRD,IPD,IRD,IID) PTA06230 C PTA06240 NPH=INTFD(IID) PTA06250 IF(NPH.EQ.0) GO TO 200 PTA06260 C PTA06270 DO 195 K=1,NPH PTA06280 C PTA06290 IF(INTFD(IID+K).LT.0) INTFD(IID+K)=0 PTA06300 IF(INTFD(IID+K).GT.0) INTFD(IID+K)=-INTFD(IID+K) PTA06310 C PTA06320 CALL TRACEP(INTFD(IID+K),LOC,INTFE,IIE,IPHRI) PTA06330 IF(LOC.NE.0) INTFD(IID+K)=IABS(INTFD(IID+K)) PTA06340 C PTA06350 195 CONTINUE PTA06360 200 CONTINUE PTA06370 C PTA06380 IF(ITRKJ.EQ.NTRK(IFLJ)) CALL BPUT(IFLJ,ITRKJ,FILED,NPHRJ) PTA06390 C PTA06400 C SET UP (FILEI)=(COLUMNWISE PHOTO-ADDRESS MATRIX, FINAL) PTA06410 C PTA06420 NYPHI=NYPHJ PTA06430 CALL SETDIM(NPHDIM,NYPHI, NPHRI,NTPHI,IPHRI,IYPHI) PTA06440 C PTA06450 NPHIRC=NPHJRC PTA06460 CALL SETFIL(IFLI,NPHIRC,NPHRI,1) PTA06470 C PTA06480 CALL OPEN(IFLI,NPHRI,NYPHI) PTA06490 C PTA06500 IGJ=0 PTA06510 IPH=0 PTA06520 IIE=1-IYPHI PTA06530 IYPHI1=IYPHI-1 PTA06540 NPHOFF=0 PTA06550 C PTA06560 DO 220 ILP=1,NACCPH PTA06570 C PTA06580 CALL BRING(IFLJ,FILED,NPHRJ,NYPHJ,IGJ, 0,ITRKJ,NRD,IPD,IRD,IID) PTA06590 NPH=INTFD(IID) PTA06600 N=0 PTA06610 C PTA06620 CALL APUT(IFLI,FILEE,NPHRI, IPH,1, 0,1, IRE,IIE) PTA06630 IPH=IPH+1 PTA06640 IIE=IIE+IYPHI PTA06650 C PTA06660 INTFE(IIE)=N PTA06670 C PTA06680 DO 210 I=1,IYPHI1 PTA06690 210 INTFE(IIE+I)=0 PTA06700 C PTA06710 IF(NPH.EQ.0) GO TO 220 PTA06720 C PTA06730 DO 215 I=1,NPH PTA06740 IF(INTFD(IID+I).EQ.0) GO TO 215 PTA06750 N=N+1 PTA06760 INTFE(IIE+N)=INTFD(IID+I) PTA06770 215 CONTINUE PTA06780 C PTA06790 INTFE(IIE)=N PTA06800 INTFE(IIE+IYPHI1)=NPHOFF+1 PTA06810 NPHOFF=NPHOFF+N PTA06820 C PTA06830 220 CONTINUE PTA06840 C PTA06850 CALL ACLOSE(IFLI,FILEE,NPHRI,IPH) PTA06860 C PTA06870 C SET UP (FILEJ)=(DUPLICATE OF FILEI) PTA06880 C PTA06890 CALL SETFIL(IFLJ,NPHJRC,NPHRJ,1) PTA06900 C PTA06910 CALL COPYFL(IFLI,IFLJ,FILEE,NPHRI,NYPHI) PTA06920 C PTA06930 C SET UP (FILEK)=(ROWWISE PHOTO-ADDRESS MATRIX FOR BACKWARD SOLUTION) PTA06940 C PTA06950 NYPHK=1 PTA06960 CALL SETDIM(NORDIM,NYPHK, NPHRK,NTPHK,IPHRK,IYPHK) PTA06970 C PTA06980 C (NOTE: NPHKRC TAKES MAX.VALUE WHEN NACCPH=MAXPH, NPHOFF=MAXPH*MXBAND) PTA06990 C PTA07000 NPHKRC=(NACCPH+NPHOFF-1)/NTPHK+1 PTA07010 CALL SETFIL(IFLK,NPHKRC,NPHRK,1) PTA07020 C PTA07030 CALL OPEN(IFLK,NPHRK,NYPHK) PTA07040 C PTA07050 IIK=1 PTA07060 IPH=1 PTA07070 ITRKI=0 PTA07080 NM1=NACCPH-1 PTA07090 C PTA07100 INTCTC(IIK)=0 PTA07110 INTCTC(IIK+1)=0 PTA07120 C PTA07130 DO 250 ILP=1,NM1 PTA07140 C PTA07150 NMI=NACCPH-ILP PTA07160 JSTA=NMI+1 PTA07170 JEND=NMI+MAXROW PTA07180 IF(JEND.GT.NACCPH) JEND=NACCPH PTA07190 C PTA07200 DO 240 JLP=JSTA,JEND PTA07210 C PTA07220 LPH=NMI+((JLP-2)*(JLP-1))/2 PTA07230 CALL LOCATE(IFLI,FILEE,NPHRI,NTPHI,NYPHI,0,JLP,ITRKI,IRE,IIE) PTA07240 CALL TRACER(LPH,LOC,INTFE,IIE,IYPHI,IPHRI) PTA07250 C PTA07260 IF(LOC.EQ.0) GO TO 240 PTA07270 C PTA07280 CALL APUT(IFLK,CTC,NPHRK, IPH,1, 0,1, IRK,IIK) PTA07290 IPH=IPH+1 PTA07300 IIK=IIK+IYPHK PTA07310 C PTA07320 INTCTC(IIK)=JLP PTA07330 INTCTC(IIK+1)=LOC PTA07340 C PTA07350 240 CONTINUE PTA07360 C PTA07370 CALL APUT(IFLK,CTC,NPHRK, IPH,1, 0,1, IRK,IIK) PTA07380 IPH=IPH+1 PTA07390 IIK=IIK+IYPHK PTA07400 C PTA07410 INTCTC(IIK)=0 PTA07420 INTCTC(IIK+1)=0 PTA07430 C PTA07440 250 CONTINUE PTA07450 C PTA07460 CALL ACLOSE(IFLK,CTC,NPHRK,IPH) PTA07470 CALL STORE(IFLK,CTC,NPHRK) PTA07480 CALL STORE(IFLI,FILEE,NPHRI) PTA07490 C PTA07500 RETURN PTA07510 C PTA07520 1 FORMAT(1H0, 9X,'***(SYSTEM ERROR)*** ADDRESS MATRIX SETUP FAILED')PTA07530 C PTA07540 END PTA07550 SUBROUTINE SOLVE(NU0,NUP,NUREC,ATA,BTB,CTC,DTD,ETE,FILEB,FILEC, PTA00010 * FILED,FILEE,INTFD,INTFE,INTCTC,NORDIM,NOIDIM, PTA00020 * NPTDIM,NPHDIM,IPHDIM,IORDIM) PTA00030 IMPLICIT REAL*8(A-H,O-Z) PTA00040 C PTA00050 DIMENSION ATA(NORDIM),BTB(NORDIM),CTC(NORDIM),DTD(NOIDIM), PTA00060 * ETE(NOIDIM),INTCTC(IORDIM) PTA00070 DIMENSION FILEB(NPTDIM),FILEC(NPTDIM),FILED(NPHDIM),FILEE(NPHDIM) PTA00080 * ,INTFD(IPHDIM),INTFE(IPHDIM) PTA00090 C PTA00100 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00110 COMMON /DISK/LTRK,NTRK(20),NREC(20) PTA00120 C PTA00130 EQUIVALENCE (IAUX(43), NYPHI),(IAUX(44), NYPHJ),(IAUX(45), NYPHK) PTA00140 * ,(IAUX(46), NYDAG),(IAUX(47), NYOFF),(IAUX(48), NYCTL) PTA00150 C PTA00160 DATA IFLI,IFLJ,IFLK/9,10,11/ PTA00170 DATA NFL1,NFL3,NFL2/13,14,15/ PTA00180 C PTA00190 C SET UP FILE DIMENSION PTA00200 C PTA00210 CALL SETDIM(NPHDIM,NYPHI, NPHRI,NTPHI,IPHRI,IYPHI) PTA00220 CALL SETDIM(NPHDIM,NYPHJ, NPHRJ,NTPHJ,IPHRJ,IYPHJ) PTA00230 CALL SETDIM(NORDIM,NYPHK, NPHRK,NTPHK,IPHRK,IYPHK) PTA00240 C PTA00250 CALL SETDIM(NORDIM,NYDAG, NDAGR,NTDAG,IDAGR,IYDAG) PTA00260 CALL SETDIM(NORDIM,NYOFF, NOFFR,NTOFF,IOFFR,IYOFF) PTA00270 CALL SETDIM(NOIDIM,NYCTL, NCTLR,NTCTL,ICTLR,IYCTL) PTA00280 C PTA00290 C SOLUTION OF NORMAL EQUATIONS PTA00300 C PTA00310 C FACTORIZATION OF (ATA=NFL1), (BTB=NFL2), (DTD=NFL3) PTA00320 C PTA00330 ITRKI=0 PTA00340 ITRKJ=0 PTA00350 ITRK1=0 PTA00360 ITRK2=0 PTA00370 ITRK3=0 PTA00380 C PTA00390 IF(NUP.NE.0) GO TO 95 PTA00400 C PTA00410 DO 90 KLOOP=1,NUREC PTA00420 C PTA00430 CALL LOCATE(NFL1,ATA,NDAGR,NTDAG,NYDAG,NFL1,KLOOP,ITRK1,IR1,II1) PTA00440 CALL FACTOR(ATA,IR1,NU0,NORDIM) PTA00450 C PTA00460 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,KLOOP,ITRK3,IR3,II3) PTA00470 CALL XTIV(ATA,IR1,DTD,IR3,NU0,NORDIM,NOIDIM) PTA00480 C PTA00490 90 CONTINUE PTA00500 C PTA00510 GO TO 420 PTA00520 C PTA00530 C STEP 1 PTA00540 C PTA00550 95 CALL LOCATE(NFL1,ATA,NDAGR,NTDAG,NYDAG,NFL1,1,ITRK1,IR1,II1) PTA00560 CALL FACTOR(ATA,IR1,NU0,NORDIM) PTA00570 C PTA00580 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,1,ITRK3,IR3,II3) PTA00590 CALL XTIV(ATA,IR1,DTD,IR3,NU0,NORDIM,NOIDIM) PTA00600 C PTA00610 IF(NUREC.EQ.1) GO TO 420 PTA00620 C PTA00630 C STEP 2 PTA00640 C PTA00650 CALL LOCATE(IFLI,FILED,NPHRI,NTPHI,NYPHI,0,2,ITRKI,IRI,III) PTA00660 NOFF=INTFD(III) PTA00670 IF(NOFF.NE.0) GO TO 100 PTA00680 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,2,ITRK3,IR32,II3) PTA00690 GO TO 120 PTA00700 C PTA00710 100 CALL LOCATE(NFL2,BTB,NOFFR,NTOFF,NYOFF,NFL2,1,ITRK2,IR2,II2) PTA00720 CALL XTIY(ATA,IR1,BTB,IR2,NYOFF,NU0,NORDIM) PTA00730 C PTA00740 IF(NTCTL.EQ.1) GO TO 110 PTA00750 IR32=IR3+NYCTL PTA00760 CALL ACCXTV(BTB,IR2,DTD,IR3,NU0,NU0,DTD,IR32,NORDIM,NOIDIM) PTA00770 GO TO 120 PTA00780 C PTA00790 110 CALL RCLEAR(ETE,NOIDIM,1,NYCTL) PTA00800 CALL ACCXTV(BTB,IR2,DTD,IR3,NU0,NU0,ETE,1,NORDIM,NOIDIM) PTA00810 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,2,ITRK3,IR32,II3) PTA00820 CALL ADDXY(DTD,IR32,ETE,1,NYCTL,+1,NOIDIM,NOIDIM) PTA00830 C PTA00840 120 CALL LOCATE(NFL1,ATA,NDAGR,NTDAG,NYDAG,NFL1,2,ITRK1,IR1,II1) PTA00850 IF(NOFF.NE.0) CALL ACCXTX(BTB,IR2,NU0,ATA,IR1,NORDIM,NORDIM) PTA00860 C PTA00870 CALL FACTOR(ATA,IR1,NU0,NORDIM) PTA00880 CALL XTIV(ATA,IR1,DTD,IR32,NU0,NORDIM,NOIDIM) PTA00890 C PTA00900 IF(NUREC.GE.3) GO TO 200 PTA00910 IF(NOFF.EQ.0) GO TO 420 PTA00920 GO TO 410 PTA00930 C PTA00940 C STEP 3 PTA00950 C PTA00960 200 KE=1 PTA00970 C PTA00980 DO 400 KLOOP=3,NUREC PTA00990 C PTA01000 KOFF=KLOOP-2 PTA01010 KS=KE+1 PTA01020 KE=KE+KOFF+1 PTA01030 C PTA01040 ITC=1 PTA01050 ITB=0 PTA01060 KCLEAR=0 PTA01070 C PTA01080 CALL LOCATE(IFLI,FILED,NPHRI,NTPHI,NYPHI,0,KLOOP,ITRKI,IRI,III) PTA01090 IF(KS.NE.IABS(INTFD(III+1))) GO TO 210 PTA01100 C PTA01110 KLOC=INTFD(III+IYPHI-1) PTA01120 CALL LOCATE(NFL1,ATA,NDAGR,NTDAG,NYDAG,NFL1,ITC,ITRK1,IR1,II1) PTA01130 CALL LOCATE(NFL2,BTB,NOFFR,NTOFF,NYOFF,NFL2,KLOC,ITRK2,IR2,II2) PTA01140 CALL XTIY(ATA,IR1,BTB,IR2,NYOFF,NU0,NORDIM) PTA01150 C PTA01160 CALL RCLEAR(FILEB,NPTDIM,1,NYOFF) PTA01170 CALL RCLEAR(ETE,NOIDIM,1,NYCTL) PTA01180 KCLEAR=1 PTA01190 C PTA01200 CALL ACCXTX(BTB,IR2,NU0,FILEB,1,NORDIM,NPTDIM) PTA01210 C PTA01220 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,ITC,ITRK3,IR3,II3) PTA01230 CALL ACCXTV(BTB,IR2,DTD,IR3,NU0,NU0,ETE,1,NORDIM,NOIDIM) PTA01240 C PTA01250 210 DO 300 ILOOP=1,KOFF PTA01260 C PTA01270 ITC=ITC+1 PTA01280 IOB=KS-1 PTA01290 KSPI=KS+ILOOP PTA01300 C PTA01310 CALL TRACER(KSPI,ILOC,INTFD,III,IYPHI,IPHRI) PTA01320 C PTA01330 IF(ILOC.NE.0) GO TO 220 PTA01340 IOB=IOB+ILOOP PTA01350 ITB=ITB+ILOOP PTA01360 GO TO 300 PTA01370 C PTA01380 220 IALOC=ILOOP+1 PTA01390 IF(KCLEAR.NE.0) GO TO 225 PTA01400 CALL RCLEAR(FILEB,NPTDIM,1,NYOFF) PTA01410 CALL RCLEAR(ETE,NOIDIM,1,NYCTL) PTA01420 KCLEAR=1 PTA01430 225 ICLEAR=0 PTA01440 C PTA01450 DO 250 JLOOP=1,ILOOP PTA01460 C PTA01470 IOB=IOB+1 PTA01480 ITB=ITB+1 PTA01490 C PTA01500 CALL TRACER(IOB,LOCOB,INTFD,III,IYPHI,IPHRI) PTA01510 C PTA01520 IF(LOCOB.EQ.0) GO TO 250 PTA01530 C PTA01540 CALL LOCATE(IFLJ,FILEE,NPHRJ,NTPHJ,NYPHJ,0,ITC,ITRKJ,IRJ,IIJ) PTA01550 CALL TRACER(ITB,LOCTB,INTFE,IIJ,IYPHJ,IPHRJ) PTA01560 C PTA01570 IF(LOCTB.EQ.0) GO TO 250 PTA01580 C PTA01590 IF(ICLEAR.NE.0) GO TO 230 PTA01600 CALL RCLEAR(FILEC,NPTDIM,1,NYOFF) PTA01610 ICLEAR=1 PTA01620 C PTA01630 230 CALL LOCATE(NFL2,BTB,NOFFR,NTOFF,NYOFF,NFL2,LOCOB,ITRK2,IR2B,II2B)PTA01640 C PTA01650 IF(NTRK(NFL2).NE.0) GO TO 235 PTA01660 IR2C=(LOCTB-1)*NYOFF+1 PTA01670 GO TO 237 PTA01680 C PTA01690 235 IF(ITRK2.NE.(LOCTB-1)/NTOFF+1) GO TO 240 PTA01700 IR2C=(LOCTB-(ITRK2-1)*NTOFF-1)*NYOFF+1 PTA01710 237 CALL ACCXTY(BTB,IR2C,BTB,IR2B,NU0,FILEC,1,NORDIM,NPTDIM) PTA01720 GO TO 250 PTA01730 C PTA01740 240 ITRK2C=0 PTA01750 CALL LOCATE(NFL2,CTC,NOFFR,NTOFF,NYOFF,0,LOCTB,ITRK2C,IR2C,II2C) PTA01760 CALL ACCXTY(CTC,IR2C,BTB,IR2B,NU0,FILEC,1,NORDIM,NPTDIM) PTA01770 C PTA01780 250 CONTINUE PTA01790 C PTA01800 CALL LOCATE(NFL2,BTB,NOFFR,NTOFF,NYOFF,NFL2,ILOC,ITRK2,IR2,II2) PTA01810 IF(ICLEAR.NE.0) CALL ADDXY(BTB,IR2,FILEC,1,NYOFF,+1,NORDIM,NPTDIM)PTA01820 C PTA01830 CALL LOCATE(NFL1,ATA,NDAGR,NTDAG,NYDAG,NFL1,IALOC,ITRK1,IR1,II1) PTA01840 CALL XTIY(ATA,IR1,BTB,IR2,NYOFF,NU0,NORDIM) PTA01850 C PTA01860 CALL ACCXTX(BTB,IR2,NU0,FILEB,1,NORDIM,NPTDIM) PTA01870 C PTA01880 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,ITC,ITRK3,IR3,II3) PTA01890 CALL ACCXTV(BTB,IR2,DTD,IR3,NU0,NU0,ETE,1,NORDIM,NOIDIM) PTA01900 C PTA01910 300 CONTINUE PTA01920 C PTA01930 CALL LOCATE(NFL1,ATA,NDAGR,NTDAG,NYDAG,NFL1,KLOOP,ITRK1,IR1,II1) PTA01940 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,KLOOP,ITRK3,IR3,II3) PTA01950 C PTA01960 IF(KCLEAR.EQ.0) GO TO 310 PTA01970 CALL ADDXY(ATA,IR1,FILEB,1,NYDAG,+1,NORDIM,NPTDIM) PTA01980 CALL ADDXY(DTD,IR3,ETE,1,NYCTL,+1,NOIDIM,NOIDIM) PTA01990 C PTA02000 310 CALL FACTOR(ATA,IR1,NU0,NORDIM) PTA02010 CALL XTIV(ATA,IR1,DTD,IR3,NU0,NORDIM,NOIDIM) PTA02020 C PTA02030 400 CONTINUE PTA02040 C PTA02050 410 IF(NTRK(NFL2).NE.0) CALL BPUT(NFL2,ITRK2,BTB,NOFFR) PTA02060 420 IF(NTRK(NFL1).NE.0) CALL BPUT(NFL1,ITRK1,ATA,NDAGR) PTA02070 IF(NTRK(NFL3).NE.0) CALL BPUT(NFL3,ITRK3,DTD,NCTLR) PTA02080 C PTA02090 C BACK SUBSTITUTION PTA02100 C PTA02110 IGK=0 PTA02120 ITRK1=0 PTA02130 ITRK2=0 PTA02140 ITRK3=0 PTA02150 C PTA02160 IPH=NUREC+1 PTA02170 C PTA02180 500 IPH=IPH-1 PTA02190 ICLEAR=0 PTA02200 C PTA02210 IF(NUP.EQ.0) GO TO 530 PTA02220 C PTA02230 510 CALL BRING(IFLK,CTC,NORDIM,NYPHK,IGK,0,ITRKK,NRK,IPK,IRK,IIK) PTA02240 C PTA02250 IF(INTCTC(IIK).EQ.0) GO TO 530 PTA02260 LOCD=INTCTC(IIK) PTA02270 LOCB=INTCTC(IIK+1) PTA02280 C PTA02290 IF(ICLEAR.NE.0) GO TO 520 PTA02300 CALL RCLEAR(ETE,NOIDIM,1,NYCTL) PTA02310 ICLEAR=1 PTA02320 C PTA02330 520 CALL LOCATE(NFL2,BTB,NOFFR,NTOFF,NYOFF,0,LOCB,ITRK2,IR2,II2) PTA02340 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,LOCD,ITRK3,IR3,II3) PTA02350 CALL ACCXV(BTB,IR2,DTD,IR3,NU0,NU0,ETE,1,NORDIM,NOIDIM) PTA02360 GO TO 510 PTA02370 C PTA02380 530 CALL LOCATE(NFL1,ATA,NDAGR,NTDAG,NYDAG,0,IPH,ITRK1,IR1,II1) PTA02390 CALL LOCATE(NFL3,DTD,NCTLR,NTCTL,NYCTL,NFL3,IPH,ITRK3,IR3,II3) PTA02400 C PTA02410 IF(ICLEAR.NE.0) CALL ADDXY(DTD,IR3,ETE,1,NYCTL,+1,NOIDIM,NOIDIM) PTA02420 CALL XIV(ATA,IR1,DTD,IR3,NU0,NORDIM,NOIDIM) PTA02430 C PTA02440 IF(IPH.NE.1) GO TO 500 PTA02450 C PTA02460 IF(NTRK(NFL3).NE.0) CALL BPUT(NFL3,ITRK3,DTD,NCTLR) PTA02470 C PTA02480 RETURN PTA02490 END PTA02500 SUBROUTINE ROTMAT(C,K,NDIM) PTA02510 IMPLICIT REAL*8(A-H,O-Z) PTA02520 DIMENSION C(NDIM) PTA02530 REAL*8 KP PTA02540 C PTA02550 OM=C(K+5) PTA02560 PH=C(K+6) PTA02570 KP=C(K+7) PTA02580 C PTA02590 SOM=DSIN(OM) PTA02600 SPH=DSIN(PH) PTA02610 SKP=DSIN(KP) PTA02620 COM=DCOS(OM) PTA02630 CPH=DCOS(PH) PTA02640 CKP=DCOS(KP) PTA02650 C PTA02660 C(K+08)=CPH*CKP PTA02670 C(K+09)=COM*SKP+SOM*SPH*CKP PTA02680 C(K+10)=SOM*SKP-COM*SPH*CKP PTA02690 C(K+11)=-CPH*SKP PTA02700 C(K+12)=COM*CKP-SOM*SPH*SKP PTA02710 C(K+13)=SOM*CKP+COM*SPH*SKP PTA02720 C(K+14)=SPH PTA02730 C(K+15)=-SOM*CPH PTA02740 C(K+16)=COM*CPH PTA02750 C PTA02760 C(K+17)=-SPH*CKP PTA02770 C(K+18)=SOM*C(K+08) PTA02780 C(K+19)=-COM*C(K+08) PTA02790 C(K+20)=SPH*SKP PTA02800 C(K+21)=SOM*C(K+11) PTA02810 C(K+22)=-COM*C(K+11) PTA02820 C(K+23)=CPH PTA02830 C(K+24)=SOM*SPH PTA02840 C(K+25)=-COM*SPH PTA02850 C PTA02860 RETURN PTA02870 END PTA02880 SUBROUTINE SETSTM(STARM,FILEA,IRA,FILEE,IRE,NPTDIM,NPHDIM) PTA02890 IMPLICIT REAL*8(A-H,O-Z) PTA02900 DIMENSION STARM(9),DXYZ(3),FILEA(NPTDIM),FILEE(NPHDIM) PTA02910 C PTA02920 DO 100 K=1,3 PTA02930 100 DXYZ(K)=FILEA(IRA+K)-FILEE(IRE+K+1) PTA02940 C PTA02950 L=IRE+7 PTA02960 DO 110 J=1,3 PTA02970 STARM(J)=0.0 PTA02980 DO 110 K=1,3 PTA02990 L=L+1 PTA03000 110 STARM(J)=STARM(J)+FILEE(L)*DXYZ(K) PTA03010 C PTA03020 L=IRE+6 PTA03030 DO 210 J=4,6 PTA03040 L=L+3 PTA03050 210 STARM(J)=FILEE(L)*DXYZ(3)-FILEE(L+1)*DXYZ(2) PTA03060 C PTA03070 L=IRE+16 PTA03080 DO 310 J=7,9 PTA03090 STARM(J)=0.0 PTA03100 DO 310 K=1,3 PTA03110 L=L+1 PTA03120 310 STARM(J)=STARM(J)+FILEE(L)*DXYZ(K) PTA03130 C PTA03140 RETURN PTA03150 END PTA03160 SUBROUTINE SETNU0(ICH,IPARM,LASTIT,NEXT,IERR) PTA03170 IMPLICIT REAL*8(A-H,O-Z) PTA03180 DIMENSION ICH(80),JCH(80),LCH(57),IPARM(15) PTA03190 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA03200 DATA LCH/1HX,1HC,1H , 1HY,1HC,1H , 1HZ,1HC,1H , 1HO,1HM,1H , PTA03210 * 1HP,1HH,1H , 1HK,1HP,1H , 1HX,1H0,1H , 1HY,1H0,1H , PTA03220 * 1HP,1HD,1H , 1HR,1HA,1HD, 1HD,1HE,1HC, 1HA,1HF,1HF, PTA03230 * 1HX,1H ,1H , 1HY,1H ,1H , 1HZ,1H ,1H , 1HX,1HO,1H , PTA03240 * 1HY,1HO,1H , 1HC,1H ,1H , 1HE,1HN,1HD/ PTA03250 DATA IBLK/1H /,ICOM/1H,/ PTA03260 C PTA03270 IERR=0 PTA03280 IEND=0 PTA03290 ISTART=1 PTA03300 C PTA03310 IF(NEXT.NE.0) GO TO 105 PTA03320 C PTA03330 DO 100 I=1,15 PTA03340 100 IPARM(I)=0 PTA03350 C PTA03360 105 DO 110 I=ISTART,80 PTA03370 IF(ICH(I).NE.IBLK .AND. ICH(I).NE.ICOM) GO TO 115 PTA03380 110 CONTINUE PTA03390 RETURN PTA03400 C PTA03410 115 ISTART=I PTA03420 C PTA03430 DO 120 I=1,80 PTA03440 120 JCH(I)=IBLK PTA03450 C PTA03460 J=0 PTA03470 DO 125 I=ISTART,80 PTA03480 IF(ICH(I).EQ.IBLK .OR. ICH(I).EQ.ICOM) GO TO 130 PTA03490 J=J+1 PTA03500 125 JCH(J)=ICH(I) PTA03510 IEND=1 PTA03520 GO TO 135 PTA03530 C PTA03540 130 ISTART=I PTA03550 135 NJ=J PTA03560 C PTA03570 IF(NEXT.EQ.0) GO TO 150 PTA03580 C PTA03590 DO 140 J=1,3 PTA03600 IF(JCH(J).NE.LCH(J+54)) RETURN PTA03610 140 CONTINUE PTA03620 LASTIT=1 PTA03630 RETURN PTA03640 C PTA03650 150 IF(NJ.EQ.0) GO TO 165 PTA03660 L=-3 PTA03670 DO 160 I=1,19 PTA03680 L=L+3 PTA03690 DO 155 J=1,3 PTA03700 IF(JCH(J).NE.LCH(L+J)) GO TO 160 PTA03710 155 CONTINUE PTA03720 K=I PTA03730 IF(I.EQ.16) K=7 PTA03740 IF(I.EQ.17) K=8 PTA03750 IF(I.EQ.18) K=9 PTA03760 IF(K.NE.19) IPARM(K)=1 PTA03770 IF(K.EQ.19) LASTIT=1 PTA03780 GO TO 165 PTA03790 160 CONTINUE PTA03800 C PTA03810 IF(IERR.EQ.0) WRITE(IPR,1) PTA03820 WRITE(IPR,2) (JCH(J),J=1,NJ) PTA03830 IERR=1 PTA03840 C PTA03850 165 IF(IEND.EQ.0) GO TO 105 PTA03860 RETURN PTA03870 C PTA03880 1 FORMAT(1H ) PTA03890 2 FORMAT(1H , 9X,'***(ERROR)*** UNDEFINED PARAMETER CODE: ',80A1) PTA03900 C PTA03910 END PTA03920 SUBROUTINE ATPAW(IS0,NU,IDIST,A,IAS,IAE,P,S,ATPA,IRA,ATPW,IRW, PTA03930 * NADIM,NWDIM)PTA03940 IMPLICIT REAL*8(A-H,O-Z) PTA03950 DIMENSION ATPA(NADIM),ATPW(NWDIM) PTA03960 DIMENSION A(2,22),P(3),S(3) PTA03970 C PTA03980 IF(IDIST.NE.0) GO TO 200 PTA03990 C PTA04000 DO 150 I=1,NU PTA04010 C PTA04020 IA=IAS+I PTA04030 IS0=IS0+I PTA04040 M=IS0 PTA04050 C PTA04060 DO 110 J=I,NU PTA04070 C PTA04080 R=0.0 PTA04090 JA=IAS+J PTA04100 C PTA04110 DO 100 K=1,2 PTA04120 100 R=R+A(K,IA)*A(K,JA)*P(K) PTA04130 IF(P(3).NE.0.0) R=R+(A(1,JA)*A(2,IA)+A(1,IA)*A(2,JA))*P(3) PTA04140 C PTA04150 ATPA(IRA+M)=ATPA(IRA+M)+R PTA04160 M=M+J PTA04170 C PTA04180 110 CONTINUE PTA04190 C PTA04200 R=0.0 PTA04210 C PTA04220 DO 130 K=1,2 PTA04230 130 R=R+A(K,IA)*A(K,IAE)*P(K) PTA04240 IF(P(3).NE.0.0) R=R+(A(1,IAE)*A(2,IA)+A(1,IA)*A(2,IAE))*P(3) PTA04250 C PTA04260 ATPW(IRW+I)=ATPW(IRW+I)+R PTA04270 C PTA04280 150 CONTINUE PTA04290 C PTA04300 RETURN PTA04310 C PTA04320 200 DO 250 I=1,NU PTA04330 C PTA04340 IA=IAS+I PTA04350 IS0=IS0+I PTA04360 M=IS0 PTA04370 C PTA04380 DO 210 J=I,NU PTA04390 C PTA04400 R=0.0 PTA04410 JA=IAS+J PTA04420 C PTA04430 DO 205 K=1,2 PTA04440 205 R=R+A(K,IA)*A(K,JA)*S(K) PTA04450 IF(S(3).NE.0.0) R=R+(A(1,JA)*A(2,IA)+A(1,IA)*A(2,JA))*S(3) PTA04460 C PTA04470 ATPA(IRA+M)=ATPA(IRA+M)+R PTA04480 M=M+J PTA04490 C PTA04500 210 CONTINUE PTA04510 C PTA04520 R=0.0 PTA04530 C PTA04540 DO 230 K=1,2 PTA04550 230 R=R+A(K,IA)*A(K,IAE)*S(K) PTA04560 IF(S(3).NE.0.0) R=R+(A(1,IAE)*A(2,IA)+A(1,IA)*A(2,IAE))*S(3) PTA04570 C PTA04580 ATPW(IRW+I)=ATPW(IRW+I)+R PTA04590 C PTA04600 250 CONTINUE PTA04610 C PTA04620 RETURN PTA04630 END PTA04640 SUBROUTINE ATPAN(NU0,NUP,IDIST,A,P,S,ATPB,NAS,NADIM) PTA04650 IMPLICIT REAL*8(A-H,O-Z) PTA04660 DIMENSION ATPB(NADIM) PTA04670 DIMENSION A(2,22),P(3),S(3) PTA04680 C PTA04690 IF(IDIST.NE.0) GO TO 200 PTA04700 C PTA04710 DO 110 I=1,NU0 PTA04720 C PTA04730 KA=NAS+I-NU0 PTA04740 C PTA04750 DO 110 J=1,NUP PTA04760 C PTA04770 KA=KA+NU0 PTA04780 R=0.0 PTA04790 C PTA04800 DO 100 K=1,2 PTA04810 100 R=R+A(K,I)*A(K,NU0+J)*P(K) PTA04820 IF(P(3).NE.0.0) R=R+(A(1,NU0+J)*A(2,I)+A(1,I)*A(2,NU0+J))*P(3) PTA04830 ATPB(KA)=R PTA04840 C PTA04850 110 CONTINUE PTA04860 C PTA04870 RETURN PTA04880 C PTA04890 200 DO 210 I=1,NU0 PTA04900 C PTA04910 KA=NAS+I-NU0 PTA04920 C PTA04930 DO 210 J=1,NUP PTA04940 C PTA04950 KA=KA+NU0 PTA04960 R=0.0 PTA04970 C PTA04980 DO 205 K=1,2 PTA04990 205 R=R+A(K,I)*A(K,NU0+J)*S(K) PTA05000 IF(S(3).NE.0.0) R=R+(A(1,NU0+J)*A(2,I)+A(1,I)*A(2,NU0+J))*S(3) PTA05010 ATPB(KA)=R PTA05020 C PTA05030 210 CONTINUE PTA05040 C PTA05050 RETURN PTA05060 END PTA05070 SUBROUTINE SETAND(FILEA,IRA,FILEL,IRL,FILEE,IRE,A,ICT,NU0NUP, PTA05080 * NULIST,NPTDIM,LPTDIM,NPHDIM) PTA05090 IMPLICIT REAL*8(A-H,O-Z) PTA05100 DIMENSION FILEA(NPTDIM),FILEL(LPTDIM),FILEE(NPHDIM) PTA05110 DIMENSION A(2,22),STARM(9),NULIST(22) PTA05120 C PTA05130 CALL SETSTM(STARM,FILEL,IRL,FILEE,IRE,LPTDIM,NPHDIM) PTA05140 C PTA05150 XBAR= FILEA(IRA+2)-FILEE(IRE+26) PTA05160 YBAR= FILEA(IRA+3)-FILEE(IRE+27) PTA05170 F=FILEE(IRE+28)/STARM(3) PTA05180 C PTA05190 IF(ICT.EQ.0) GO TO 100 PTA05200 C PTA05210 C W PTA05220 C PTA05230 A(01,NU0NUP+1)= XBAR + F*STARM(1) PTA05240 A(02,NU0NUP+1)= YBAR + F*STARM(2) PTA05250 C PTA05260 100 XBAR=XBAR/STARM(3) PTA05270 YBAR=YBAR/STARM(3) PTA05280 L=0 PTA05290 C PTA05300 DO 230 I=1,NU0NUP PTA05310 C PTA05320 K=NULIST(I) PTA05330 L=L+1 PTA05340 C PTA05350 GO TO (110,120,130,140,150,160,170,180,190,200,210,220),K PTA05360 C PTA05370 C DF/DXC PTA05380 C PTA05390 110 A(01,L)= -FILEE(IRE+14)*XBAR-FILEE(IRE+08)*F PTA05400 A(02,L)= -FILEE(IRE+14)*YBAR-FILEE(IRE+11)*F PTA05410 GO TO 230 PTA05420 C PTA05430 C DF/DYC PTA05440 C PTA05450 120 A(01,L)= -FILEE(IRE+15)*XBAR-FILEE(IRE+09)*F PTA05460 A(02,L)= -FILEE(IRE+15)*YBAR-FILEE(IRE+12)*F PTA05470 GO TO 230 PTA05480 C PTA05490 C DF/DZC PTA05500 C PTA05510 130 A(01,L)= -FILEE(IRE+16)*XBAR-FILEE(IRE+10)*F PTA05520 A(02,L)= -FILEE(IRE+16)*YBAR-FILEE(IRE+13)*F PTA05530 GO TO 230 PTA05540 C PTA05550 C DF/DOM PTA05560 C PTA05570 140 A(01,L)= XBAR*STARM(6)+F*STARM(4) PTA05580 A(02,L)= YBAR*STARM(6)+F*STARM(5) PTA05590 GO TO 230 PTA05600 C PTA05610 C DF/DPH PTA05620 C PTA05630 150 A(01,L)= XBAR*STARM(9)+F*STARM(7) PTA05640 A(02,L)= YBAR*STARM(9)+F*STARM(8) PTA05650 GO TO 230 PTA05660 C PTA05670 C DF/DKP PTA05680 C PTA05690 160 A(01,L)= F*STARM(02) PTA05700 A(02,L)=-F*STARM(01) PTA05710 GO TO 230 PTA05720 C PTA05730 C DF/DX0 PTA05740 C PTA05750 170 A(01,L)=-1.D0 PTA05760 A(02,L)= 0.D0 PTA05770 GO TO 230 PTA05780 C PTA05790 C DF/DY0 PTA05800 C PTA05810 180 A(01,L)= 0.D0 PTA05820 A(02,L)=-1.D0 PTA05830 GO TO 230 PTA05840 C PTA05850 C DF/DPD PTA05860 C PTA05870 190 A(01,L)= STARM(1)/STARM(3) PTA05880 A(02,L)= STARM(2)/STARM(3) PTA05890 GO TO 230 PTA05900 C PTA05910 C DF/DX PTA05920 C PTA05930 200 IF(NULIST(20).EQ.0) GO TO 205 PTA05940 M=NULIST(20) PTA05950 A(01,L)= -A(01,M) PTA05960 A(02,L)= -A(02,M) PTA05970 GO TO 230 PTA05980 C PTA05990 205 A(01,L)= FILEE(IRE+14)*XBAR+FILEE(IRE+08)*F PTA06000 A(02,L)= FILEE(IRE+14)*YBAR+FILEE(IRE+11)*F PTA06010 GO TO 230 PTA06020 C PTA06030 C DF/DY PTA06040 C PTA06050 210 IF(NULIST(21).EQ.0) GO TO 215 PTA06060 M=NULIST(21) PTA06070 A(01,L)= -A(01,M) PTA06080 A(02,L)= -A(02,M) PTA06090 GO TO 230 PTA06100 C PTA06110 215 A(01,L)= FILEE(IRE+15)*XBAR+FILEE(IRE+09)*F PTA06120 A(02,L)= FILEE(IRE+15)*YBAR+FILEE(IRE+12)*F PTA06130 GO TO 230 PTA06140 C PTA06150 C DF/DZ PTA06160 C PTA06170 220 IF(NULIST(22).EQ.0) GO TO 225 PTA06180 M=NULIST(22) PTA06190 A(01,L)= -A(01,M) PTA06200 A(02,L)= -A(02,M) PTA06210 GO TO 230 PTA06220 C PTA06230 225 A(01,L)= FILEE(IRE+16)*XBAR+FILEE(IRE+10)*F PTA06240 A(02,L)= FILEE(IRE+16)*YBAR+FILEE(IRE+13)*F PTA06250 C PTA06260 230 CONTINUE PTA06270 C PTA06280 RETURN PTA06290 END PTA06300 SUBROUTINE SETADS(FILEA,IRA,FILEL,IRL,FILEE,IRE,A,Q,R,ICT,NU0NUP, PTA00010 * NULIST,NPTDIM,LPTDIM,NPHDIM) PTA00020 IMPLICIT REAL*8(A-H,O-Z) PTA00030 DIMENSION FILEA(NPTDIM),FILEL(LPTDIM),FILEE(NPHDIM) PTA00040 DIMENSION A(2,22),Q(3),R(3),STARM(9),NULIST(22) PTA00050 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA00060 C PTA00070 CALL SETSTM(STARM,FILEL,IRL,FILEE,IRE,LPTDIM,NPHDIM) PTA00080 C PTA00090 XX0= FILEA(IRA+2)-FILEE(IRE+26) PTA00100 YY0= FILEA(IRA+3)-FILEE(IRE+27) PTA00110 F= FILEE(IRE+28)/STARM(3) PTA00120 C PTA00130 C1=XX0*XX0 PTA00140 C2=YY0*YY0 PTA00150 C3=C1+C2 PTA00160 C4=C3*C3 PTA00170 C5=C3*C4 PTA00180 C6=C1+C1+C3 PTA00190 C7=C2+C2+C3 PTA00200 C8=2.D0*FILEE(IRE+32)*XX0 PTA00210 C9=2.D0*FILEE(IRE+33)*YY0 PTA00220 C10=2.D0*XX0*YY0 PTA00230 C PTA00240 RAD= 1.D0 + FILEE(IRE+29)*C3 + FILEE(IRE+30)*C4 + FILEE(IRE+31)*C5PTA00250 C PTA00260 A(1,21)= RAD + C8 + C8 + C9 PTA00270 A(2,21)= 2.D0*FILEE(IRE+32)*YY0 PTA00280 A(1,22)= 2.D0*FILEE(IRE+33)*XX0 + FILEE(IRE+34) PTA00290 A(2,22)= RAD + C8 + C9 + C9 + FILEE(IRE+35) PTA00300 C PTA00310 M=0 PTA00320 DO 50 I=1,2 PTA00330 DO 50 J=I,2 PTA00340 M=M+1 PTA00350 R(M)=0.0 PTA00360 DO 40 K=21,22 PTA00370 40 R(M)=R(M)+A(I,K)*A(J,K)*Q(K-20) PTA00380 IF(Q(3).NE.0.0) R(M)=R(M)+(A(J,21)*A(I,22)+A(I,21)*A(J,22))*Q(3) PTA00390 50 CONTINUE PTA00400 C PTA00410 R1=R(1) PTA00420 R2=R(2) PTA00430 R3=R(3) PTA00440 DET=R1*R3-R2*R2 PTA00450 IF(DET.NE.0.0) GO TO 60 PTA00460 WRITE(IPR,1) PTA00470 CALL ERRSTP(IPR) PTA00480 STOP PTA00490 60 R(1)= R3/DET PTA00500 R(2)= R1/DET PTA00510 R(3)=-R2/DET PTA00520 C PTA00530 XBAR = XX0*RAD + FILEE(IRE+32)*C6 + FILEE(IRE+33)*C10 PTA00540 * + FILEE(IRE+34)*YY0 PTA00550 C PTA00560 YBAR = YY0*RAD + FILEE(IRE+33)*C7 + FILEE(IRE+32)*C10 PTA00570 * + FILEE(IRE+35)*YY0 PTA00580 C PTA00590 IF(ICT.EQ.0) GO TO 100 PTA00600 C PTA00610 C W PTA00620 C PTA00630 A(01,NU0NUP+1)= XBAR + F*STARM(1) PTA00640 A(02,NU0NUP+1)= YBAR + F*STARM(2) PTA00650 C PTA00660 100 XBAR=XBAR/STARM(3) PTA00670 YBAR=YBAR/STARM(3) PTA00680 L=0 PTA00690 C PTA00700 DO 300 I=1,NU0NUP PTA00710 C PTA00720 K=NULIST(I) PTA00730 L=L+1 PTA00740 C PTA00750 GO TO (110,120,130,140,150,160,170,180,190,200,210,220,230,240, PTA00760 * 250,260,270,280,290),K PTA00770 C PTA00780 C DF/DXC PTA00790 C PTA00800 110 A(01,L)= -FILEE(IRE+14)*XBAR-FILEE(IRE+08)*F PTA00810 A(02,L)= -FILEE(IRE+14)*YBAR-FILEE(IRE+11)*F PTA00820 GO TO 300 PTA00830 C PTA00840 C DF/DYC PTA00850 C PTA00860 120 A(01,L)= -FILEE(IRE+15)*XBAR-FILEE(IRE+09)*F PTA00870 A(02,L)= -FILEE(IRE+15)*YBAR-FILEE(IRE+12)*F PTA00880 GO TO 300 PTA00890 C PTA00900 C DF/DZC PTA00910 C PTA00920 130 A(01,L)= -FILEE(IRE+16)*XBAR-FILEE(IRE+10)*F PTA00930 A(02,L)= -FILEE(IRE+16)*YBAR-FILEE(IRE+13)*F PTA00940 GO TO 300 PTA00950 C PTA00960 C DF/DOM PTA00970 C PTA00980 140 A(01,L)= XBAR*STARM(6)+F*STARM(4) PTA00990 A(02,L)= YBAR*STARM(6)+F*STARM(5) PTA01000 GO TO 300 PTA01010 C PTA01020 C DF/DPH PTA01030 C PTA01040 150 A(01,L)= XBAR*STARM(9)+F*STARM(7) PTA01050 A(02,L)= YBAR*STARM(9)+F*STARM(8) PTA01060 GO TO 300 PTA01070 C PTA01080 C DF/DKP PTA01090 C PTA01100 160 A(01,L)= F*STARM(02) PTA01110 A(02,L)=-F*STARM(01) PTA01120 GO TO 300 PTA01130 C PTA01140 C DF/DX0 PTA01150 C PTA01160 170 A(01,L)= -A(1,21) PTA01170 A(02,L)= -A(2,21) PTA01180 GO TO 300 PTA01190 C PTA01200 C DF/DY0 PTA01210 C PTA01220 180 A(01,L)= -A(1,22) PTA01230 A(02,L)= -A(2,22) PTA01240 GO TO 300 PTA01250 C PTA01260 C DF/DPD PTA01270 C PTA01280 190 A(01,L)= STARM(1)/STARM(3) PTA01290 A(02,L)= STARM(2)/STARM(3) PTA01300 GO TO 300 PTA01310 C PTA01320 C DF/DK1 PTA01330 C PTA01340 200 A(01,L)= XX0*C3 PTA01350 A(02,L)= YY0*C3 PTA01360 GO TO 300 PTA01370 C PTA01380 C DF/DK2 PTA01390 C PTA01400 210 A(01,L)= XX0*C4 PTA01410 A(02,L)= YY0*C4 PTA01420 GO TO 300 PTA01430 C PTA01440 C DF/DK3 PTA01450 C PTA01460 220 A(01,L)= XX0*C5 PTA01470 A(02,L)= YY0*C5 PTA01480 GO TO 300 PTA01490 C PTA01500 C DF/DP1 PTA01510 C PTA01520 230 A(01,L)= C6 PTA01530 A(02,L)= C10 PTA01540 GO TO 300 PTA01550 C PTA01560 C DF/DP2 PTA01570 C PTA01580 240 A(01,L)= C10 PTA01590 A(02,L)= C7 PTA01600 GO TO 300 PTA01610 C PTA01620 C DF/DA PTA01630 C PTA01640 250 A(01,L)= YY0 PTA01650 A(02,L)= 0.0 PTA01660 GO TO 300 PTA01670 C PTA01680 C DF/DB PTA01690 C PTA01700 260 A(01,L)= 0.0 PTA01710 A(02,L)= YY0 PTA01720 GO TO 300 PTA01730 C PTA01740 C DF/DX PTA01750 C PTA01760 270 IF(NULIST(20).EQ.0) GO TO 275 PTA01770 M=NULIST(20) PTA01780 A(01,L)= -A(01,M) PTA01790 A(02,L)= -A(02,M) PTA01800 GO TO 300 PTA01810 C PTA01820 275 A(01,L)= FILEE(IRE+14)*XBAR+FILEE(IRE+08)*F PTA01830 A(02,L)= FILEE(IRE+14)*YBAR+FILEE(IRE+11)*F PTA01840 GO TO 300 PTA01850 C PTA01860 C DF/DY PTA01870 C PTA01880 280 IF(NULIST(21).EQ.0) GO TO 285 PTA01890 M=NULIST(21) PTA01900 A(01,L)= -A(01,M) PTA01910 A(02,L)= -A(02,M) PTA01920 GO TO 300 PTA01930 C PTA01940 285 A(01,L)= FILEE(IRE+15)*XBAR+FILEE(IRE+09)*F PTA01950 A(02,L)= FILEE(IRE+15)*YBAR+FILEE(IRE+12)*F PTA01960 GO TO 300 PTA01970 C PTA01980 C DF/DZ PTA01990 C PTA02000 290 IF(NULIST(22).EQ.0) GO TO 295 PTA02010 M=NULIST(22) PTA02020 A(01,L)= -A(01,M) PTA02030 A(02,L)= -A(02,M) PTA02040 GO TO 300 PTA02050 C PTA02060 295 A(01,L)= FILEE(IRE+16)*XBAR+FILEE(IRE+10)*F PTA02070 A(02,L)= FILEE(IRE+16)*YBAR+FILEE(IRE+13)*F PTA02080 C PTA02090 300 CONTINUE PTA02100 C PTA02110 RETURN PTA02120 C PTA02130 1 FORMAT(1H0, 9X,'***(ERROR)*** NORMAL EQUATION MATRIX IS SINGULAR')PTA02140 C PTA02150 END PTA02160 SUBROUTINE DESIGN(ICH,KCH,LASTIT,NU0,MAM,NULIST,NU11,ISET,NAME11, PTA02170 * MAME11,IDIST,NUP,NU22,NAME22,IX,IY,IZ,IXX,IYY, PTA02180 * IZZ,IXY) PTA02190 IMPLICIT REAL*8(A-H,O-Z) PTA02200 DIMENSION NULIST(22),NU11(16),ISET(10),NAME11(16),MAME11(12), PTA02210 * IPARM(15),NAME(16),NU11LC(16),MAME(3),ICH(80),KCH(80) PTA02220 DIMENSION NU22(3),NAME22(3),NU22LC(6) PTA02230 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA02240 C PTA02250 DATA NAME/4HXC ,4HYC ,4HZC ,4HOM ,4HPH ,4HKP , PTA02260 * 4HX0 ,4HY0 ,4HPD ,4HK1 ,4HK2 ,4HK3 , PTA02270 * 4HP1 ,4HP2 ,4HA ,4HB / PTA02280 DATA MAME/4HRAD ,4HDEC ,4HAFF / PTA02290 DATA NU11LC/2,3,4,5,6,7,26,27,28,29,30,31,32,33,34,35/ PTA02300 DATA NU22LC/4HX ,4HY ,4HZ ,1,2,3/ PTA02310 DATA ID/1HD/ PTA02320 C PTA02330 CALL SETNU0(ICH,IPARM,LASTIT,0,IERR) PTA02340 C PTA02350 IF(LASTIT.EQ.0) GO TO 80 PTA02360 C PTA02370 DO 70 I=1,15 PTA02380 IF(IPARM(I).NE.0) GO TO 75 PTA02390 70 CONTINUE PTA02400 GO TO 80 PTA02410 C PTA02420 75 IF(IERR.EQ.0) WRITE(IPR,2) PTA02430 WRITE(IPR,3) (ICH(I),I=1,80) PTA02440 IERR=1 PTA02450 C PTA02460 80 IF(IERR.NE.0) CALL ERRSTP(IPR) PTA02470 C PTA02480 IF(LASTIT.NE.0) GO TO 85 PTA02490 C PTA02500 READ(ICD,1) (KCH(I),I=1,80) PTA02510 CALL SETNU0(KCH,IPARM,LASTIT,1,IERR) PTA02520 C PTA02530 85 NU0=0 PTA02540 IDIST=0 PTA02550 DO 90 I=1,6 PTA02560 90 ISET(I)=0 PTA02570 ISET(10)=ID PTA02580 DO 95 I=20,22 PTA02590 95 NULIST(I)=0 PTA02600 C PTA02610 DO 100 I=1,9 PTA02620 IF(IPARM(I).EQ.0) GO TO 100 PTA02630 NU0=NU0+1 PTA02640 NULIST(NU0)=I PTA02650 IF(I.LE.3) NULIST(I+19)=NU0 PTA02660 NU11(NU0)=NU11LC(I) PTA02670 IF(I.GE.1.AND.I.LE.3) ISET(1)=ISET(1)+1 PTA02680 IF(I.GE.4.AND.I.LE.6) ISET(2)=ISET(2)+1 PTA02690 IF(I.GE.7.AND.I.LE.9) ISET(3)=ISET(3)+1 PTA02700 NAME11(NU0)=NAME(I) PTA02710 MAME11(NU0)=NAME(I) PTA02720 100 CONTINUE PTA02730 C PTA02740 IGO=0 PTA02750 MAM=NU0 PTA02760 K=9 PTA02770 C PTA02780 105 IGO=IGO+1 PTA02790 K=K+1 PTA02800 C PTA02810 GO TO (110,120,130,160),IGO PTA02820 C PTA02830 110 IS=10 PTA02840 IE=12 PTA02850 GO TO 140 PTA02860 C PTA02870 120 IS=13 PTA02880 IE=14 PTA02890 GO TO 140 PTA02900 C PTA02910 130 IS=15 PTA02920 IE=16 PTA02930 C PTA02940 140 IF(IPARM(K).EQ.0) GO TO 105 PTA02950 C PTA02960 DO 150 I=IS,IE PTA02970 NU0=NU0+1 PTA02980 NULIST(NU0)=I PTA02990 NU11(NU0)=NU11LC(I) PTA03000 ISET(K-6)=ISET(K-6)+1 PTA03010 150 NAME11(NU0)=NAME(I) PTA03020 C PTA03030 IDIST=1 PTA03040 MAM=MAM+1 PTA03050 MAME11(MAM)=MAME(K-9) PTA03060 ISET(K-3)=MAME(K-9) PTA03070 GO TO 105 PTA03080 C PTA03090 160 IF(ISET(4).NE.0 .OR. ISET(5).NE.0) NULIST(20)=1 PTA03100 C PTA03110 NUP=0 PTA03120 DO 165 I=13,15 PTA03130 IF(IPARM(I).EQ.0) GO TO 165 PTA03140 NUP=NUP+1 PTA03150 IF(IDIST.EQ.0) NULIST(NU0+NUP)=I-3 PTA03160 IF(IDIST.NE.0) NULIST(NU0+NUP)=I+4 PTA03170 NU22(NUP)=NU22LC(I-9) PTA03180 NAME22(NUP)=NU22LC(I-12) PTA03190 165 CONTINUE PTA03200 C PTA03210 IX=-1 PTA03220 IY=-1 PTA03230 IZ=-1 PTA03240 IXX=3 PTA03250 IYY=3 PTA03260 IZZ=3 PTA03270 IXY=3 PTA03280 C PTA03290 IF(NUP.EQ.0) RETURN PTA03300 C PTA03310 IS=3 PTA03320 C PTA03330 DO 175 I=1,NUP PTA03340 IS=IS+I PTA03350 IF(NU22(I).NE.1) GO TO 170 PTA03360 IX=I-1 PTA03370 IXX=IS PTA03380 170 IF(NU22(I).NE.2) GO TO 171 PTA03390 IY=I-1 PTA03400 IYY=IS PTA03410 171 IF(NU22(I).NE.3) GO TO 175 PTA03420 IZ=I-1 PTA03430 IZZ=IS PTA03440 175 CONTINUE PTA03450 C PTA03460 IF(IXX.NE.3 .AND. IYY.NE.3) IXY=5 PTA03470 C PTA03480 RETURN PTA03490 C PTA03500 1 FORMAT(80A1) PTA03510 2 FORMAT(1H ) PTA03520 3 FORMAT(1H , 9X,'***(ERROR)*** END STATEMENT APPEARS WITH PARAMETE'PTA03530 * ,'R CODE(S)',/,24X,80A1) PTA03540 C PTA03550 END PTA03560 SUBROUTINE ACCXYT(X,NXS,Y,NU0,NUP,Z,NZS,NXDIM) PTA03570 IMPLICIT REAL*8(A-H,O-Z) PTA03580 DIMENSION X(NXDIM),Z(NXDIM),Y(48) PTA03590 C PTA03600 DO 110 I=1,NU0 PTA03610 C PTA03620 KC=NZS+I-NU0 PTA03630 C PTA03640 DO 110 J=1,NU0 PTA03650 C PTA03660 KC=KC+NU0 PTA03670 KA=NXS+I-1-NU0 PTA03680 KB=J-NU0 PTA03690 R=0.0 PTA03700 C PTA03710 DO 100 K=1,NUP PTA03720 KA=KA+NU0 PTA03730 KB=KB+NU0 PTA03740 R=R+X(KA)*Y(KB) PTA03750 100 CONTINUE PTA03760 C PTA03770 Z(KC)=Z(KC)-R PTA03780 C PTA03790 110 CONTINUE PTA03800 C PTA03810 RETURN PTA03820 END PTA03830 SUBROUTINE INVERT(NUP,FILEL,IRL,NLDIM) PTA03840 IMPLICIT REAL*8(A-H,O-Z) PTA03850 DIMENSION FILEL(NLDIM) PTA03860 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA03870 C PTA03880 GO TO (100,200,300),NUP PTA03890 C PTA03900 100 IF(FILEL(IRL).EQ.0.0) GO TO 500 PTA03910 FILEL(IRL)=1.D0/FILEL(IRL) PTA03920 RETURN PTA03930 C PTA03940 200 A1=FILEL(IRL) PTA03950 A2=FILEL(IRL+1) PTA03960 A3=FILEL(IRL+2) PTA03970 D=A1*A3-A2*A2 PTA03980 IF(D.EQ.0.0) GO TO 500 PTA03990 FILEL(IRL)= A3/D PTA04000 FILEL(IRL+1)=-A2/D PTA04010 FILEL(IRL+2)= A1/D PTA04020 RETURN PTA04030 C PTA04040 300 A1=FILEL(IRL) PTA04050 A4=FILEL(IRL+1) PTA04060 A2=FILEL(IRL+2) PTA04070 A6=FILEL(IRL+3) PTA04080 A5=FILEL(IRL+4) PTA04090 A3=FILEL(IRL+5) PTA04100 C PTA04110 B=A2*A3-A5*A5 PTA04120 C=A1*A3-A6*A6 PTA04130 D=A3*A4-A5*A6 PTA04140 E=A2*A6-A4*A5 PTA04150 F=A1*A5-A4*A6 PTA04160 Q=D*D-B*C PTA04170 IF(Q.EQ.0.0) GO TO 500 PTA04180 C PTA04190 FILEL(IRL)=-(A3*B)/Q PTA04200 FILEL(IRL+1)= (A3*D)/Q PTA04210 FILEL(IRL+2)=-(A3*C)/Q PTA04220 FILEL(IRL+3)= (A3*E)/Q PTA04230 FILEL(IRL+4)= (A3*F)/Q PTA04240 FILEL(IRL+5)=-(A3*(A1*A2-A4*A4))/Q PTA04250 RETURN PTA04260 C PTA04270 500 WRITE(IPR,1) PTA04280 STOP PTA04300 C PTA04310 1 FORMAT(1H0, 9X,'***(ERROR)*** NORMAL EQUATION MATRIX IS SINGULAR')PTA04320 C PTA04330 END PTA04340 SUBROUTINE A12A22(A12,A22,NSA,NU0,NUP,Z,N22DIM) PTA04350 IMPLICIT REAL*8(A-H,O-Z) PTA04360 DIMENSION A12(48),A22(N22DIM),Z(48) PTA04370 C PTA04380 DO 110 I=1,NU0 PTA04390 C PTA04400 IB=NSA PTA04410 KC=I-NU0 PTA04420 C PTA04430 DO 110 J=1,NUP PTA04440 C PTA04450 KC=KC+NU0 PTA04460 KA=I-NU0 PTA04470 KB=IB PTA04480 R=0.0 PTA04490 C PTA04500 DO 100 K=1,NUP PTA04510 KA=KA+NU0 PTA04520 IF(J.EQ.3.AND.K.EQ.3) KB=KB-1 PTA04530 R=R+A12(KA)*A22(KB) PTA04540 100 KB=KB+K PTA04550 C PTA04560 Z(KC)=R PTA04570 IB=IB+J PTA04580 C PTA04590 110 CONTINUE PTA04600 C PTA04610 RETURN PTA04620 END PTA04630 SUBROUTINE ACCXXT(X,Y,NU0,NUP,Z,NZS,NZDIM) PTA04640 IMPLICIT REAL*8(A-H,O-Z) PTA04650 DIMENSION X(48),Y(48),Z(NZDIM) PTA04660 C PTA04670 M=NZS PTA04680 C PTA04690 DO 120 I=1,NU0 PTA04700 C PTA04710 M=M+I PTA04720 KC=M PTA04730 C PTA04740 DO 110 J=I,NU0 PTA04750 C PTA04760 KA=I-NU0 PTA04770 KB=J-NU0 PTA04780 R=0.0 PTA04790 C PTA04800 DO 100 K=1,NUP PTA04810 KA=KA+NU0 PTA04820 KB=KB+NU0 PTA04830 R=R+X(KA)*Y(KB) PTA04840 100 CONTINUE PTA04850 C PTA04860 Z(KC)=Z(KC)-R PTA04870 KC=KC+J PTA04880 C PTA04890 110 CONTINUE PTA04900 C PTA04910 120 CONTINUE PTA04920 C PTA04930 RETURN PTA04940 END PTA04950 SUBROUTINE ACCXTV(X,NXS,V,NVS,N,M,Z,NZS,NXDIM,NVDIM) PTA04960 IMPLICIT REAL*8(A-H,O-Z) PTA04970 DIMENSION X(NXDIM),V(NVDIM),Z(NVDIM) PTA04980 C PTA04990 IX=NXS-1 PTA05000 IK=NVS-1 PTA05010 IZ=NZS-1 PTA05020 C PTA05030 DO 110 J=1,M PTA05040 C PTA05050 IV=IK PTA05060 IZ=IZ+1 PTA05070 R=0.D0 PTA05080 C PTA05090 DO 100 I=1,N PTA05100 IX=IX+1 PTA05110 IV=IV+1 PTA05120 R=R+X(IX)*V(IV) PTA05130 100 CONTINUE PTA05140 C PTA05150 Z(IZ)=Z(IZ)-R PTA05160 C PTA05170 110 CONTINUE PTA05180 C PTA05190 RETURN PTA05200 END PTA05210 SUBROUTINE ACCXV(X,NXS,V,NVS,N,M,Z,NZS,NXDIM,NVDIM) PTA05220 IMPLICIT REAL*8(A-H,O-Z) PTA05230 DIMENSION X(NXDIM),V(NVDIM),Z(NVDIM) PTA05240 C PTA05250 IX=NXS-1 PTA05260 IK=NVS-1 PTA05270 IZ=NZS-1 PTA05280 C PTA05290 DO 110 J=1,N PTA05300 C PTA05310 JX=IX+J-N PTA05320 IV=IK PTA05330 IZ=IZ+1 PTA05340 R=0.D0 PTA05350 C PTA05360 DO 100 I=1,M PTA05370 JX=JX+N PTA05380 IV=IV+1 PTA05390 R=R+X(JX)*V(IV) PTA05400 100 CONTINUE PTA05410 C PTA05420 Z(IZ)=Z(IZ)-R PTA05430 C PTA05440 110 CONTINUE PTA05450 C PTA05460 RETURN PTA05470 END PTA05480 SUBROUTINE MULTXV(X,NXS, V,NVS, Z, NUP,NXDIM,NVDIM) PTA05490 IMPLICIT REAL*8(A-H,O-Z) PTA05500 DIMENSION X(NXDIM),V(NVDIM),Z(NUP) PTA05510 C PTA05520 IA=NXS PTA05530 C PTA05540 DO 150 I=1,NUP PTA05550 C PTA05560 KA=IA PTA05570 R=0.0 PTA05580 C PTA05590 DO 100 J=1,NUP PTA05600 IF(I.EQ.3.AND.J.EQ.3) KA=KA-1 PTA05610 R=R+X(KA)*V(NVS+J-1) PTA05620 KA=KA+J PTA05630 100 CONTINUE PTA05640 C PTA05650 Z(I)=R PTA05660 IA=IA+I PTA05670 C PTA05680 150 CONTINUE PTA05690 C PTA05700 RETURN PTA05710 END PTA05720 SUBROUTINE SETRMS(A,IA,RMS,IMS,N,IPT,IPH,NADIM,NRDIM,NIDIM) PTA05730 IMPLICIT REAL*8(A-H,O-Z) PTA05740 DIMENSION A(NADIM),RMS(NRDIM),IMS(NIDIM) PTA05750 REAL*4 A PTA05760 C PTA05770 DO 100 I=1,N PTA05780 RMS(I)=RMS(I)+A(IA+I)**2 PTA05790 IF(ABS(A(IA+I)).LT.DABS(RMS(N+I))) GO TO 100 PTA05800 RMS(N+I)=A(IA+I) PTA05810 IMS(I)=IPT PTA05820 IMS(N+I)=IPH PTA05830 100 CONTINUE PTA05840 C PTA05850 RETURN PTA05860 END PTA05870 SUBROUTINE RMSSET(IND,A,RMS,IMS,NMS,NS,NE,IPT) PTA05880 IMPLICIT REAL*8(A-H,O-Z) PTA05890 DIMENSION A(3),RMS(11,6),IMS(11,3),NMS(11,3) PTA05900 REAL*4 A PTA05910 C PTA05920 DO 100 J=NS,NE PTA05930 RMS(IND,J)=RMS(IND,J)+A(J)**2 PTA05940 NMS(IND,J)=NMS(IND,J)+1 PTA05950 IF(ABS(A(J)).LT.DABS(RMS(IND,J+3))) GO TO 100 PTA05960 RMS(IND,J+3)=A(J) PTA05970 IMS(IND,J)=IPT PTA05980 100 CONTINUE PTA05990 C PTA06000 RETURN PTA06010 END PTA06020 SUBROUTINE TESTOU(IERR,IPRNTA,IPRNTB,IPRNTC,ICARDA,ICARDB,IFILE, PTA06030 * KFILE) PTA06040 IMPLICIT REAL*8(A-H,O-Z) PTA06050 COMMON /IOUNIT/ICD,IPR,IPUNCH,IDISK,IAUX(80) PTA06060 C PTA06070 IF(IPRNTA.GE.0.AND.IPRNTA.LE.3) GO TO 101 PTA06080 WRITE(IPR,5001) IPRNTA PTA06090 IERR=1 PTA06100 101 IF(IPRNTB.GE.0.AND.IPRNTB.LE.3) GO TO 102 PTA06110 WRITE(IPR,5002) IPRNTB PTA06120 IERR=1 PTA06130 102 IF(IPRNTC.GE.0.AND.IPRNTC.LE.3) GO TO 1102 PTA06140 WRITE(IPR,5010) IPRNTC PTA06150 IERR=1 PTA06160 1102 IF(ICARDA.GE.0.AND.ICARDA.LE.3) GO TO 103 PTA06170 WRITE(IPR,5003) ICARDA PTA06180 IERR=1 PTA06190 103 IF(ICARDB.GE.0.AND.ICARDB.LE.3) GO TO 104 PTA06200 WRITE(IPR,5004) ICARDB PTA06210 IERR=1 PTA06220 104 IF(IFILE.GE.0.AND.IFILE.LE.99) GO TO 105 PTA06230 WRITE(IPR,5005) IFILE PTA06240 IERR=1 PTA06250 105 IF(IFILE.NE.ICD.AND.IFILE.NE.IPR) GO TO 106 PTA06260 WRITE(IPR,5006) IFILE PTA06270 IERR=1 PTA06280 106 IF(IFILE.NE.IPUNCH.AND.IFILE.NE.IDISK) GO TO 107 PTA06290 WRITE(IPR,5006) IFILE PTA06300 IERR=1 PTA06310 107 IF(KFILE.GE.0.AND.KFILE.LE.99) GO TO 108 PTA06320 WRITE(IPR,5007) KFILE PTA06330 IERR=1 PTA06340 108 IF(KFILE.NE.ICD.AND.KFILE.NE.IPR) GO TO 109 PTA06350 WRITE(IPR,5008) KFILE PTA06360 IERR=1 PTA06370 109 IF(KFILE.NE.IDISK) GO TO 110 PTA06380 WRITE(IPR,5008) KFILE PTA06390 IERR=1 PTA06400 110 IF(KFILE.NE.IFILE) GO TO 115 PTA06410 IF(KFILE.EQ.0) GO TO 115 PTA06420 WRITE(IPR,5009) IFILE,KFILE PTA06430 IERR=1 PTA06440 C PTA06450 115 RETURN PTA06460 C PTA06470 5001 FORMAT(1H ,9X,'***(ERROR)*** INVALID READ-IN IPRNTA (',I10,')') PTA06480 5002 FORMAT(1H ,9X,'***(ERROR)*** INVALID READ-IN IPRNTB (',I10,')') PTA06490 5003 FORMAT(1H ,9X,'***(ERROR)*** INVALID READ-IN ICARDA (',I10,')') PTA06500 5004 FORMAT(1H ,9X,'***(ERROR)*** INVALID READ-IN ICARDB (',I10,')') PTA06510 5005 FORMAT(1H ,9X,'***(ERROR)*** INVALID READ-IN IFILE (',I10,')') PTA06520 5006 FORMAT(1H ,9X,'***(ERROR)*** READ-IN IFILE (',I2,') IS A RESERVED'PTA06530 * ,' FILE NUMBER') PTA06540 5007 FORMAT(1H ,9X,'***(ERROR)*** INVALID READ-IN KFILE (',I10,')') PTA06550 5008 FORMAT(1H ,9X,'***(ERROR)*** READ-IN KFILE (',I2,') IS A RESERVED'PTA06560 * ,' FILE NUMBER') PTA06570 5009 FORMAT(1H ,9X,'***(ERROR)*** READ-IN IFILE (',I2,') AND KFILE (', PTA06580 * I2,') HAVE THE SAME FILE NUMBER') PTA06590 5010 FORMAT(1H ,9X,'***(ERROR)*** INVALID READ-IN IPRNTC (',I10,')') PTA06600 C PTA06610 END PTA06620 SUBROUTINE RADDMS(RD,IDMS,NS) PTA06630 IMPLICIT REAL*8(A-H,O-Z) PTA06640 DIMENSION IDMS(18),NR(10) PTA06650 DATA IPLUS,MINUS/4H(+) ,4H(-) / PTA06660 DATA NR/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ PTA06670 C PTA06680 PAI=3.1415926535898 PTA06690 PAI2=PAI+PAI PTA06700 C PTA06710 LOC=(NS-1)*6+1 PTA06720 ISGN=1 PTA06730 IF(RD.LT.0.D0) ISGN=-1 PTA06740 IDG=0 PTA06750 MNT=0 PTA06760 C PTA06770 ISD=DMOD(DABS(RD),PAI2)*648000.D0/PAI+0.5D0 PTA06780 ISD=MOD(ISD,1296000) PTA06790 IF(ISD.LE.648000) GO TO 100 PTA06800 ISD=1296000-ISD PTA06810 ISGN=-ISGN PTA06820 C PTA06830 100 ISD=ISD-3600 PTA06840 IF(ISD.LT.0) GO TO 110 PTA06850 IDG=IDG+1 PTA06860 GO TO 100 PTA06870 110 ISD=ISD+3600 PTA06880 C PTA06890 120 ISD=ISD-60 PTA06900 IF(ISD.LT.0) GO TO 130 PTA06910 MNT=MNT+1 PTA06920 GO TO 120 PTA06930 130 ISD=ISD+60 PTA06940 C PTA06950 M1=MNT/10 PTA06960 M2=MNT-M1*10 PTA06970 K1=ISD/10 PTA06980 K2=ISD-K1*10 PTA06990 C PTA07000 IF(ISGN.GE.0) IDMS(LOC)=IPLUS PTA07010 IF(ISGN.LT.0) IDMS(LOC)=MINUS PTA07020 IDMS(LOC+1)=IDG PTA07030 IDMS(LOC+2)=NR(M1+1) PTA07040 IDMS(LOC+3)=NR(M2+1) PTA07050 IDMS(LOC+4)=NR(K1+1) PTA07060 C PTA07080 RETURN PTA07090 END PTA07100