Trailing-Edge
-
PDP-10 Archives
-
BB-H064A-SM
-
sources/cogo.for
There are no other files named cogo.for in the archive.
DIMENSION IARGS(18)
INCLUDE 'COGO.COM'
C***********************************************************************
C
C MAIN PROGRAM (COGO.FOR)
C
C***********************************************************************
C DEFINE BLANK COMMON EQUAL IN SIZE TO THAT OF THE
C LARGEST BLANK COMMON DEFINED IN ANY SUBROUTINE.
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
C ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
C INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
C COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
C OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THIS SOFTWARE IS HEREBY
C TRANSFERED.
C
C THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
C AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
C CORPORATION.
C
C DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
C SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
C
C CGVRT IS THE CONTROLLING SUBROUTINE.
COMMON KOMON(379)
EQUIVALENCE(IARGS(1),IVCD),(IARGS(2),MTPR),(IARGS(3),MTCD),
*(IARGS(4),INPH),(IARGS(5),JPPR),(IARGS(6),IPDF),(IARGS(7),KPTR),
*(IARGS(8),MXER),(IARGS(9),KEOJ),(IARGS(10),ISGH),(IARGS(11),ISGV),
*(IARGS(12),ISEQ),(IARGS(13),IZZ),(IARGS(14),IZ90),
*(IARGS(15),MZ),(IARGS(16),M90),(IARGS(17),M180),(IARGS(18),M270)
C
C***********************************************************************
C TO EDIT THE FOLLOWING DEFAULT VALUES, FIRST CHECK WITH YOUR
C COGO-10/20 INSTALLATION GUIDE. THEN YOU MAY CHANGE THE DEFAULT
C VALUES IN THE DATA STATEMENTS YOU WISH TO. AFTER YOU HAVE EDITED
C THE DEFAULTS YOU THEN MUST COMPILE, LINK AND SAVE AS STATED IN
C COGO-10/20 INSTALLATION GUIDE.
C***********************************************************************
C
C IVCD = DEVICE NUMBER OF PRIMARY CARD READER.
DATA IVCD/02/
C MTPR = DEVICE NUMBER OF PRINTER. MTPR=1 IF NO PRINTER.
DATA MTPR/03/
C MTCD = DEVICE NUMBER OF CARD PUNCH.
DATA MTCD/20/
C IN THE FOLLOWING COMMENTS THE WORDS 'VERTICAL', 'UP',
C AND 'DOWN' DO NOT REFER TO ELEVATIONS BUT RATHER TO
C DIRECTIONS ON A PLAN VIEW MAP WHICH IS HELD VERTICALLY.
C (DRAW THE COORDINATE SYSTEM YOU DESIRE AND
C HANG IT ON THE WALL. THEN SET THE FOLLOWING VARIABLES.)
C
C ISGH = POSITIVE DIRECTION OF THE HORIZONTAL AXIS.
C ('R' FOR RIGHT, 'L' FOR LEFT)
DATA ISGH/'R'/
C ISGV = POSITIVE DIRECTION OF THE VERTICAL AXIS.
C ('U' FOR UP, 'D' FOR DOWN)
DATA ISGV/'U'/
C ISEQ = SEQUENCE OF VALUES IN A COORDINATE PAIR.
C ('HV' FOR HORIZONTAL FOLLOWED BY VERTICAL,
C 'VH' FOR VERTICAL FOLLOWED BY HORIZONTAL)
DATA ISEQ/'VH'/
C IZZ = DIRECTION OF ZERO AZIMUTH.
C ('R' FOR RIGHT, 'L' FOR LEFT, 'U' FOR UP, 'D' FOR DOWN)
DATA IZZ/'U'/
C IZ90 = DIRECTION OF 90 DEGREE AZIMUTH.
C ('R' FOR RIGHT, 'L' FOR LEFT, 'U' FOR UP, 'D' FOR DOWN)
DATA IZ90/'R'/
C MZ = SYMBOL ASSOCIATED WITH AZIMUTH OF ZERO
DATA MZ/'N'/
C M90 = SYMBOL ASSOCIATED WITH AZIMUTH OF 90 DEGREES
DATA M90/'E'/
C M180 = SYMBOL ASSOCIATED WITH AZIMUTH OF 180 DEGREES
DATA M180/'S'/
C M270 = SYMBOL ASSOCIATED WITH AZIMUTH OF 270 DEGREES
DATA M270/'W'/
C
C***********************************************************************
C THE FOLLOWING DEFAULTS ARE NOT USED BY COGO-10/20 AS IT DOES NOT
C HAVE PLOTTING CAPABILITIES. THEREFORE YOU DO NOT HAVE TO MAKE
C ANY CHANGES TO THEM.
C
C INPH = NUMBER OF INCREMENTS PER .01 INCH ON PLOTTER.
C SET INPH TO ZERO IF THE SYSTEM HAS NO PLOTTER.
C OTHERWISE 5 IS A NICE NUMBER
DATA INPH/0/
C JPPR = TOTAL (STOP TO STOP) WIDTH OF PLOTTER IN INCHES.
C IF THE ACTUAL WIDTH IS NOT A WHOLE NUMBER OF INCHES,
C INCREASE IT TO THE NEXT WHOLE INCH.
C FOR EXAMPLE, IF THE ACTUAL WIDTH IS 46.1 SET JPPR TO 47 .
DATA JPPR/12/
C IPDF = DEFAULT PAPER LENGTH.
C THIS IS THE MAXIMUM PAPER LENGTH WHICH WILL BE USED IF
C IT IS NOT SPECIFIED IN THE START PLOTTER COMMAND.
C FOR FLATBEDS THIS SHOULD BE AT LEAST ONE INCH LESS THAN
C THE USEABLE SURFACE.
DATA IPDF/100/
C KPTR = CODE SPECIFYING PLOTTER TYPE AND MODE OF OPERATION
C 1 = DRUM PLOTTER WITH PEN TO BE RUN TO STOP BY COGO
C TO ESTABLISH PEN POSITION BEFORE EACH MAP.
C 2 = DRUM PLOTTER WITH PEN TO BE POSITIONED BY OPERATOR.
C 3 = FLATBED PLOTTER.
DATA KPTR/1/
C MXER = NUMBER OF UNDEFINED POINT ERRORS PERMITTED.
C IF MORE THAN THIS OCCUR, COGO WILL TERMINATE THE JOB.
DATA MXER/100/
C KEOJ = PAUSE INDICATOR.
C 0 = DO NOT PAUSE AFTER END OF JOB.
C 1 = PAUSE AFTER EACH END OF JOB COMMAND.
DATA KEOJ/0/
C***********************************************************************
C
C GO INITIALIZE COMMON
2 CALL CGBEG(IARGS)
C START READING DATA
CALL CGCMD
CALL EXIT
END
SUBROUTINE CGAAE
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
C
C 109 ADJUST ANGULAR ERROR
C
C IF NO VALUE FOR GRID FACTOR GIVEN SET IT EQUAL TO 1.
IF (DATA(6)) 4,3,4
3 DATA(6)=1.
C
C INITIALIZE FIG CONTAINING TRAV PTS
4 KTF=DATA(1)
C
C INITIALIZE FIG CONTAINING NO ADJUSTMENT ANGLES
LTF=DATA(8)
C
C GET NO. OF PTS IN TRAV
J=0
K=0
901 CALL CGFIG (KTF,N,NS)
IF (N-DATA(2)) 62,63,62
63 K=K-1
62 K=K+1
IF (NS)901,902,901
902 CONTINUE
K=K-1
C
C IF ALL ANGS ARE TO BE ADJ (NO DESC2) GO TO 905
IF (DATA(8)) 905,905,906
906 WRITE (MOUT,911)
911 FORMAT (1H0,'ANGLE HELD AT')
C
C GET NO OF ANGLES IN TRAV NOT TO BE ADJ
904 CALL CGFIG(LTF,L,LEND)
IF (LEND)908,905,908
908 J=J+1
WRITE (MOUT,912)L
912 FORMAT (1H ,4X,I4)
GO TO 904
C
C COMPUTE NO. OF ANGS TO DISTRIBUTE ERROR AMOUNG
905 NOA=K-J
LTF=DATA(8)
KTF=DATA(1)
C
C FIND LAST COURSE OF TRAV CLOS PT TO DUMY PT OR TRAV PT TO CLO
K=K-1
DO 45 M=1,K
45 CALL CGFIG(KTF,N,NS)
I=N
CALL CGGET(I,X1,Y1)
CALL CGFIG(KTF,N,NS)
CALL CGGET(N,X2,Y2)
J=DATA(2)
CALL CGGET(J,X3,Y3)
C
C FOUND CLOS PT NOW GET ITS COORDS AND DUMYS COORDS INVERSE
C BETWEEN THEM AND COMPUTE AZ FROM CLOS TO DUMY (THIS IS FIELD
C CLOSING AZ)
IF(N-J) 159,160,159
159 CALL CGINV(X2,Y2,X3,Y3,AZ,DIST)
GO TO 170
160 CALL CGINV(X1,Y1,X3,Y3,AZ,DIST)
C
C COMPUTE TOTAL ERROR IN TRAV
170 ERROR=DATA(3)-AZ
IF(DABS(ERROR).GT.PI) ERROR=TWOPI-DABS(ERROR)
C
C COMPUTE CORR TO BE APPLIED TO EACH ADJ ANG IN TRAV
CORR=ERROR/(DFLOAT(NOA))
C CONVERT RADIANS TO DEG-MIN-SEC
DEG=ABS(ERROR*360.0/TWOPI)
IDEG=DEG
AMIN=(DEG-IDEG)*60.
MIN=(AMIN)
SEC=(AMIN-MIN)*60.+.005
DEG1=ABS(CORR*360.0/TWOPI)
IDEG1=DEG1
AMIN1= (DEG1-IDEG1)*60.
MIN1=AMIN1
SEC1=(AMIN1-MIN1)*60.+.005
C
C PRINT OUT NO. OF ANGS IN TRAV, NO. OF ADJ ANGS,TOTAL ERROR IN
C TRAV,AND CORR PER ANG
K=K+1
IF(ERROR)73,73,74
73 WRITE(MOUT,70)K,NOA,IDEG,MIN,SEC,IDEG1,MIN1,SEC1,DATA(6)
70 FORMAT(1H0,'NUMBER OF ANGLES IN TRAVERSE=',I4,5X,'NUMBER OF ANGLES
* ADJUSTED=',I4//1H ,'TOTAL AZIMUTH MISCLOSURE= -',I3,'-',I2,'-',
*F5.2,5X,'CORRECTION PER ANGLE =',I3,'-',I2,'-',F5.2//1H , 'GRID FA
*CTOR=',F11.9///)
GO TO 72
74 WRITE(MOUT,71)K,NOA,IDEG,MIN,SEC,IDEG1,MIN1,SEC1,DATA(6)
71 FORMAT(1H0,'NUMBER OF ANGLES IN TRAVERSE=',I4,5X,'NUMBER OF ANGLES
* ADJUSTED=',I4//1H ,'TOTAL AZIMUTH MISCLOSURE=',I3,'-',I2,'-',
*F5.2,5X,'CORRECTION PER ANGLE = -'I3,'-',I2,'-',F5.2//1H , 'GRID F
*ACTOR=',F11.9///)
C
C IF CORR PER ANG EXCEEDS ALLOWABLE ERROR DO NOT ADJUST (END
C PROG)
72 IF (DATA(4)-(TWOPI-ABS(CORR))) 80,80,900
C
C M IS A NO. WHICH WILL DECIDE WHETHER OR NOT A NEW PT NO. FROM
C TO BE READ IF M=1 YES IF M=0 NO
80 IF (DATA(8)) 82,81,82
82 M=1
GO TO 83
81 M=0
83 J=0
C
C INITIALIZE FIG CONTAINING TRAV PTS
KTF=DATA(1)
C
C INITIALIZE FIG CONTAINING NO ADJUSTMENT ANGLES
LTF=DATA(8)
CALL CGFIG(LTF,L,LEND)
C
TCOR=0.
C
C GET COORDS OF PT 1
CALL CGFIG(KTF,I,NS)
CALL CGGET(I,X1,Y1)
N=I
J=I
XNU=X1
YNU=Y1
C
C GET COORDS OF PT 2
CALL CGFIG(KTF,I,NS)
CALL CGGET(I,X2,Y2)
C
C INVERSE AZ AND DIST FROM 1 TO 2
10 CALL CGINV(X1,Y1,X2,Y2,AZ,DIST)
C CONVERT RADIANS AND AZIMUTHS FOR PRINTOUT
AZ2=CGNRM((AZ+AZEZ)*ISGG)
C
C SET COORDS OF PT2 EQUAL TO COORDS OF PT 1
X1=X2
Y1=Y2
C
C MULTIPLY DIST*GRID FACTOR
DIST=DIST * DATA(6)
C
C TEST TO SEE IF LAST L HAS FOUND COMPANION IN TRAV OR IF THIS I
C FIRST L NO. TO BE READ
IF(LEND)12,14,12
12 IF(M) 11,15,11
C
C GET FIRST OR NEXT L (L=ANG NOT TO BE ADJUSTED)
11 CALL CGFIG(LTF,K,LEND)
14 M=0
C
C IF 1ST PT IN TRAV = 1ST L PT COMPUTE AND STORE COORDS OF TRAV
15 IF(N-L) 20,21,20
21 M=1
L=K
GO TO 40
C
C IF ANG AT PT 1 IS TO BE ADJ GO TO 30
20 IF(L-J) 30,31,30
31 M=1
L=K
C
C ANG AT PT 1 NOT TO BE ADJUSTED
AZ=AZ + TCOR
GO TO 40
C
C ADJUST ANGLE AT PT 1
30 AZ=AZ + CORR + TCOR
C
C UPDATE TCOR (TOTAL COR SO FAR)
TCOR= TCOR + CORR
C
C COMPUTE AND STORE NEW COORDS OF PT 2
40 CALL CGXTL(XNU,YNU,AZ,DIST,XW,YW)
CALL CGPAT(I,XW,YW)
XNU=XW
YNU=YW
C
C SET J EQUAL TO PT NO. 1 OF NEXT LOOP
J=I
C
C ADVANCE TO NEXT TRAV PT AND MAKE ITS COORDS EQUAL TO COORDS OF
CALL CGFIG(KTF,I,NS)
IF (NS)13,903,13
13 CALL CGGET(I,X2,Y2)
GO TO 10
900 WRITE (MOUT,920)
920 FORMAT (1H0,'CORRECTION PER ANGLE EXCEEDS ALLOWABLE ERROR, NO ADJU
*STMENT PERFORMED'///)
C ABORT IF INPUT NOT FROM 'TTY'
CALL LOGDEV(INDEV,NDEV)
IF(NDEV.NE.'TTY') GO TO 999
903 CALL RTNONE
999 RETURN
END
SUBROUTINE CGAAI(XA,YA,RA,XB,YB,RB,XIA,YIA,XIB,YIB)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA HFPI/1.5707963267948966D0/
CALL CGINV(XA,YA,XB,YB,AZAB,DAB)
DTI=(DAB*DAB+RA*RA-RB*RB)/(DAB+DAB)
IF(DAB)20,20,30
20 CALL CGCLR(DTI,DTI)
30 CALL CGXTL(XA,YA,AZAB,DTI,XT,YT)
CALL CGALZ(XA,YA,RA,XT,YT,AZAB+HFPI,XIA,YIA,XIB,YIB)
RETURN
END
SUBROUTINE CGALI
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
IF(IDITO-106)3400,10600,10600
C
3400 CONTINUE
NPC = DATA(5)
NPT = DATA(7)
NC = DATA(6)
C
C COMPUTE CURVE ELEMENTS
C IF R=0.,COMPUTE FROM T. IF T=0.,COMPUTE FROM R.
C IF BOTH 0.,COMPOUND.
C
C GET BACK AZIMUTH BA
C
CALL CGGET(IFIX(SNGL(DATA(3))),XPI,YPI)
CALL CGGET(IFIX(SNGL(DATA(2))),XTEM2,YTEM2)
CALL CGINV(XPI,YPI,XTEM2,YTEM2,BA,TT)
C
C GET AZIMUTH AHEAD AA
C
CALL CGGET(IFIX(SNGL(DATA(4))),XTEM2,YTEM2)
CALL CGINV(XPI,YPI,XTEM2,YTEM2,AA,DIST1)
C
C COMPUTE VERTEX ANGLE AND SIGN.
C
DEFAN=CGNRM(AA-BA)-PI
SGN=1.
IF(DEFAN)36,38,38
36 SGN=-SGN
38 DELTA=ABS(DEFAN)
HALF = DELTA/2.0
C
C COMPUTE T OR R OR BOTH, AND STATION PC AND PT.
C
R = DATA(8)
T = DATA(9)
XL1 = DATA(11)
IF(R)42,42,43
43 T = R*SIN(HALF)/COS(HALF)
GO TO 45
42 IF(T)55,55,44
55 T = TT -XL1
44 R = T*COS(HALF)/SIN(HALF)
45 XL1 = TT - T
SB = DATA(10)
IF(SB+1.)54,3455,54
3455 IF(NCURV)3490,56,56
3490 WRITE(MOUT,3491)
3491 FORMAT(' #####NO PREVIOUS CURVE TO DEFINE STATIONING')
54 SPT = SB
56 SPC = SPT + XL1
XCUR = R * DELTA
SPT = SPC + XCUR
CALL CGDMS(DELTA,IDEG,MIN,SEC)
NCURV = DATA(1)
ISG=IFIX(SNGL(SGN))*ISGG
IF(LIST)82,81,81
81 WRITE(MOUT,1000) NCURV,ISG,R,T,IDEG,MIN,SEC,XL1,SPC,XCUR,SPT
1000 FORMAT('0CURVE',I5,' SIGN',I3,F11.4,'=R',F11.4,'=TAN',2X,
* 'DEFL=',I3,'-',I2,'-',F4.1,/,
* 1X,F11.4,'=NB TO PC',F11.4,'=SPC',F11.4,
*'=CURVE LENGTH',F11.4,'=SPT',/)
C
C COMPUTE AZ OF PC AND APC
C
82 APC = BA + HFPI*SGN
APT = AA - SGN*HFPI
C
C LOCATE PC,PT,AND CENTRE
C
CALL CGXTL(XPI,YPI,BA,T,XPC,YPC)
CALL CGPUT(NPC,XPC,YPC)
CALL CGPCD(NPC)
CALL CGXTL(XPI,YPI,AA,T,XPT,YPT)
CALL CGPUT(NPT,XPT,YPT)
CALL CGPCD(NPT)
CALL CGXTL(XPC,YPC,APC,-R,XC,YC)
CALL CGPUT(NC,XC,YC)
CALL CGPCD(NC)
GO TO 900
C FIT CURVE
10600 CONTINUE
NNB=DATA(1)
NNPI=DATA(2)
NNA=DATA(3)
NNPC=DATA(4)
NNCC=DATA(5)
NNPT=DATA(6)
CALL CGGET(NNB,XB,YB)
IF(XB-CLEAR)10612,10690,10690
10612 CALL CGGET(NNPI,XPI,YPI)
IF(XPI-CLEAR)10614,10690,10690
10614 CALL CGGET(NNA,XA,YA)
IF(XA-CLEAR)10620,10690,10690
10620 CALL CGINV(XPI,YPI,XB,YB,AZIB,DIB)
CALL CGINV(XPI,YPI,XA,YA,AZIA,DIA)
IF(DIB)10680,10680,10622
10622 IF(DIA)10680,10680,10623
10623 DEFAN=CGNRM(AZIA-AZIB)-PI
KURV=1
IF(DEFAN)10624,10625,10625
10624 KURV=-KURV
10625 HFDEL=ABS(DEFAN)/2.
IF(ND-7)10630,10630,10626
10626 RAD=DATA(8)
TANL=SIN(HFDEL)/COS(HFDEL)*RAD
GO TO 10640
10630 IF(NNB-NNPC)10634,10632,10634
10632 TANL=DIB
RAD=COS(HFDEL)/SIN(HFDEL)*TANL
XPC=XB
YPC=YB
GO TO 10642
10634 IF(NNA-NNPT)10682,10636,10682
10636 TANL=DIA
RAD=COS(HFDEL)/SIN(HFDEL)*TANL
10640 CALL CGXTL(XPI,YPI,AZIB,TANL,XPC,YPC)
CALL CGPUT(NNPC,XPC,YPC)
10642 CALL CGPCD(NNPC)
CALL CGXTL(XPC,YPC,AZIB-HFPI*KURV,RAD,XCC,YCC)
CALL CGPUT(NNCC,XCC,YCC)
CALL CGPCD(NNCC)
IF(ND-7)10644,10644,10646
10644 IF(NNA-NNPT)10646,10648,10646
10646 CALL CGXTL(XPI,YPI,AZIA,TANL,XPT,YPT)
CALL CGPUT(NNPT,XPT,YPT)
10648 CALL CGPCD(NNPT)
GO TO 900
10680 WRITE(MOUT,10681)
10681 FORMAT(' #####TANGENT LENGTH IS ZERO')
GO TO 10690
10682 WRITE(MOUT,10683)
10683 FORMAT(' #####UNDEFINED RADIUS')
10690 IF(ND-7)10691,10691,10692
10691 IF(NNB-NNPC)10692,10693,10692
10692 CALL CGPUT(NNPC,CLEAR,CLEAR)
10693 CALL CGPCD(NNPC)
CALL CGPUT(NNCC,CLEAR,CLEAR)
CALL CGPCD(NNCC)
IF(ND-7)10695,10695,10696
10695 IF(NNA-NNPT)10696,10697,10696
10696 CALL CGPUT(NNPT,CLEAR,CLEAR)
10697 CALL CGPCD(NNPT)
900 CALL RTNONE
END
SUBROUTINE CGALZ(XCC,YCC,RAD,XK,YK,AZ,XIA,YIA,XIB,YIB)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA HFPI/1.5707963267948966D0/
CALL CGCLR(XIA,YIA)
CALL CGCLR(XIB,YIB)
CALL CGINV(XK,YK,XCC,YCC,AZT,DT)
DT=DT*SIN(AZ-AZT)
AZT=AZ+HFPI
CALL CGXTL(XCC,YCC,AZT,DT,XT,YT)
DT=RAD*RAD-DT*DT
IF(DT)900,40,40
40 DT=SQRT(DT)
CALL CGXTL(XT,YT,AZ,-DT,XIA,YIA)
CALL CGXTL(XT,YT,AZ,DT,XIB,YIB)
900 RETURN
END
SUBROUTINE CGASY(ANGLE,LBUF,INDXX)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION LBUF(1)
C DATA K6040,K4B40/ Z6040,Z4B40 /
DATA K6040,K4B40/'-','.'/
C
C * * CONVERTS ANGLE TO 'XZZ-ZZ-ZZ.Z' IN A1 FMT IN LBUF(INDXX) THRU
C * * LBUF(INDXX+N-1) INDXX IS INCREMENTED. 'Z' INDICATES ZERO FILL.
C
CALL CGDMS(ANGLE,IDG,IMN,RSC)
ISC = RSC
ISFC = 10.0 *(RSC-DFLOAT(ISC))
CALL CGNSY(IDG,LBUF,INDXX,2)
LBUF(INDXX) = K6040
INDXX = INDXX+1
CALL CGNSY(IMN,LBUF,INDXX,2)
LBUF(INDXX) = K6040
INDXX = INDXX+1
CALL CGNSY(ISC,LBUF,INDXX,2)
LBUF(INDXX) = K4B40
INDXX=INDXX+1
CALL CGNSY(ISFC,LBUF,INDXX,1)
C
RETURN
END
SUBROUTINE CGBEG(JARGS)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IARGS(18),JARGS(18),NML(9),NMR(9),MALPH(26)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C * * COMMON STATEMENTS BELOW ADDED AUGUST 1973 - LGB
C * * (VARIABLES OCCUPY SPACE IN COMMON ARRAY 'KMMON' DEFINED IN THE
C * * 'COGO' MAINLINE.)
COMMON ANSIZ,JBRAZ
C * (ANNOT. HGT. IN INCHES,BEAR/AZM CODE)
EQUIVALENCE(IARGS(1),IVCD),(IARGS(2),MTPR),(IARGS(3),MTCD),
*(IARGS(4),INPH),(IARGS(5),JPPR),(IARGS(6),IPDF),(IARGS(7),KPTR),
*(IARGS(8),MXER),(IARGS(9),KEOJ),(IARGS(10),ISGH),(IARGS(11),ISGV),
*(IARGS(12),ISEQ),(IARGS(13),IZZ),(IARGS(14),IZ90),
*(IARGS(15),MZ),(IARGS(16),M90),(IARGS(17),M180),(IARGS(18),M270)
COMMON /COGCOM/ KBFLG,IBU(322)
COMMON /COGVRT/ NVFLG
DATA MALPH/'A','B','C','D','E','F','G','H','I','J','K','L','M',
* 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
DATA NML/'IS','IS','IS','IZ','IZ','MZ','M9','M1','M2'/
DATA NMR/'GH','GV','EQ','Z ','90',' ','0 ','80','70'/
DATA MA/'A'/
DATA MD/'D'/
DATA MG/'G'/
DATA ML/'L'/
DATA MR/'R'/
DATA MU/'U'/
DATA MHV/'HV'/
DATA MVH/'VH'/
C INITIALIZE VERTICAL CURVE INDICATOR
NVFLG=0
C INITIALIZE STARTING PLOT COORDINATES AND
C PLOTTING INDICATOR
XN=0.0
YN=0.0
INDPLT=0
C********** ZERO OUT RECORDS READ COUNTER **********
NUSE=0
C PATCH OUT CTL C
CALL SETCTP
C START OF RUN
C BLANK OUT HEADING AND ZERO PAGE NUMBER
CALL CGHDG(0,1,0)
NPG=0
C * * CHANGES BELOW MADE 8/73 - LGB
C SET LINE/ARC ANNOTATION PARAMETERS TO NO ANNOTATION
JBRAZ = 0
ANSIZ = 0.08
C * * END CHANGES
C MOVE ARGUMENTS INTO INTERNAL ARRAY TO TAKE
C ADVANTAGE OF EQUIVALENCE
DO 4 I=1,18
4 IARGS(I)=JARGS(I)
C GET DEVICE NUMBERS OF CARD READER, PRINTER,
C CARD PUNCH
IVC=IVCD
MTP=MTPR
MTC=MTCD
C GET INCREMENTS PER INCH ON PLOTTER
INCPI=INPH*100
C COMPUTE USABLE PAPER WIDTH (2 INCHES LESS THAN
C PLOTTER WIDTH)
JPAPR=JPPR-2
C GET DEFAULT PAPER LENGTH
IPDEF=IPDF
C GET PLOTTER TYPE CODE
KPLEJ=KPTR
IF(KPLEJ)6,6,7
6 KPLEJ=1
C GET MAXIMUM ERROR COUNT
7 MAXER=MXER
C GET END OF JOB PAUSE CODE
IF(KEOJ)8,8,9
8 KPLEJ=-KPLEJ
9 CONTINUE
C SET SWITCH INDICATING NO JOB IN PROGRESS AND TO
C START NEW PAGE
NXJOB=1
C SET SWITCH NO COMMAND TO DITTO IF BLANK COMMAND
C IS READ
IDTSV=0
C SET TYPEWRITER INPUT DEVICE NUMBER
IVT=5
C SET TYPEWRITER OUTPUT DEVICE NUMBER
MTT=5
C INITIAL INPUT DEVICE IS CARD READER
INDEV=IVC
C INITIAL OUTPUT DEVICE IS PRINTER
MOUT=MTP
C SET SWITCH - PRINT NO OUTPUT
LIST=-1
C SET SCALE TO ZERO INDICATING NO PLOTTING IS IN
C PROGRESS
SFPI=0.
C SET UP CONSTANTS FOR ANGLES
PI =3.1415926535897932D0
TWOPI=6.2831853071795864D0
HFPI =1.5707963267948966D0
C SET VALUE FOR UNDEFINED POINTS
CLEAR=1.E20
C SET SWITCH - NO CARD IN BUFFER
MLTCD=0
C GET ADDRESS OF WORKING STORAGE ON LOGICAL DRIVE
C ZERO (SEE CGMTB)
C* CALL CGDBF(1,1,0,285,KFWS)
C* KFWS=(KFWS+15)/16
KFWS=1
C ISGX = DIRECTION OF EXTERNAL HORIZONTAL AXIS
C +1 - RIGHT
C -1 - LEFT
IER=1
ISGX=1
IF(ISGH-MR)12,20,12
12 ISGX=-1
IF(ISGH-ML)90,20,90
C ISGY = DIRECTION OF EXTERNAL VERTICAL AXIS
C +1 - UP
C -1 - DOWN
20 IER=2
ISGY=1
IF(ISGV-MU)22,30,22
22 ISGY=-1
IF(ISGV-MD)90,30,90
C IXYF = SEQUENCE OF COORDINATES
C 1 - X FOLLOWED BY Y
C 2 - Y FOLLOWED BY X
30 IER=3
IXYF=1
IF(ISEQ-MHV)32,40,32
32 IXYF=2
IF(ISEQ-MVH)90,40,90
C ISGG = DIRECTION OF INCREASING AZIMUTH
C +1 - COUNTER CLOCKWISE
C -1 - CLOCKWISE
C AZEZ = AXIMUTH REFERENCE DIRECTION
40 IER=4
ISGG=1
AZEZ=0.
IF(IZZ-MR)42,50,42
42 AZEZ=-HFPI
IF(IZZ-MU)44,54,44
44 ISGG=-1
AZEZ=PI
IF(IZZ-ML)46,50,46
46 AZEZ=HFPI
IF(IZZ-MD)90,54,90
50 IER=5
IF(IZ90-MU)52,60,52
52 IF(IZ90-MD)90,58,90
54 IER=5
IF(IZ90-ML)56,60,56
56 IF(IZ90-MR)90,58,90
58 ISGG=-ISGG
C MAXES = AXIS MNEUMONICS
C OPPOSITE DIRECTIONS MUST HAVE DIFFERENT
C MNEUMONICS FOR 0 AND 180 DEG MAY NOT BE A OR G
60 DO 89 I=1,4
IER=IER+1
MAXIS=IARGS(I+14)
DO 69 J=1,26
IF(MAXIS-MALPH(J))69,70,69
69 CONTINUE
GO TO 90
70 IF(I/2*2-I)72,76,72
72 IF(MAXIS-MA)74,90,74
74 IF(MAXIS-MG)76,90,76
76 IF(I-3)89,78,78
78 IF(MAXIS-MAXES(I-2))89,90,89
89 MAXES(I)=MAXIS
C
C LET TTY USER SPECIFY DEVICES FOR THIS RUN
CALL ERRSET(0)
KBFLG=0
CALL SEQIN(INDEV,'SPECIFY INPUT DEVICE/FILENAME',29)
CALL FILNAM(INDEV,RNAME)
CALL RPTNAM(RNAME)
CALL SEQOUT(MOUT,'SPECIFY OUTPUT DEVICE/FILENAME',30)
C
C DETERMINE NAME FOR 'PLA' FILE IF PLOTTING REQUITED
PNAME='TEMP '
CALL LOGDEV(INDEV,IDVNM)
IF(IDVNM.EQ.'DSK') PNAME=RNAME
C SYSTEM INITIALIZATION COMPLETED
C GO READ A CARD
GO TO 99999
90 WRITE(MTT,91)NML(IER),NMR(IER),IARGS(IER+9)
91 FORMAT(' #####','ERROR IN COGO MAINLINE. ',2A2,' = ''',A2,'''')
99999 RETURN
END
SUBROUTINE CGCLM(XN,YN)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(IN(3),KTFA),(IN(6),KTB),(IN(9),FSTA),(IN(12),FSTB),
*(IN(15),M),(IN(18),XM),(IN(21),YM),(IN(24),SGINT),(IN(27),SGPRS),
*(IN(30),XI),(IN(33),YI),(IN(36),LKAB),(IN(39),LKBB),(IN(42),KVB),
*(IN(45),XAB),(IN(48),YAB),(IN(51),XBB),(IN(54),YBB),(IN(57),XCB),
*(IN(60),YCB)
IF(XN-CLEAR)20,900,900
20 IF(SGINT)30,50,30
30 CALL CGINV(XM,YM,XN,YN,A,DN)
CALL CGINV(XM,YM,XI,YI,A,DI)
IF((DN-DI)*M)50,900,900
50 XI=XN
YI=YN
SGINT=SGPRS
900 RETURN
END
SUBROUTINE CGCLR(X,Y)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA CLEAR/1.E20/
X=CLEAR
Y=CLEAR
RETURN
END
SUBROUTINE CGCMG(K,IK,JK,MAXCM)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION K(10000),IK(1000),JK(1000),NAMBF(30)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MA /'A'/
DATA MZ /'Z'/
DATA MBL /' '/
DATA MSLSH/'/'/
DATA MZERO/'0'/
DATA ME/'E'/
DATA MO/'O'/
DATA MJ/'J'/
C CHECK ERROR COUNT
IF(NUMER-MAXER)1060,1060,1040
1040 IF(NXJOB)1060,1042,1060
1042 WRITE(MTT,1044)MAXER
1044 FORMAT(10X,'OVER',I4,' ERRORS. JOB TERMINATED.')
DO 1046 I=1,80
1046 IN(I)=MBL
IN(1)=ME
IN(3)=MO
IN(5)=MJ
LK=5
GO TO 1210
1060 CONTINUE
C DID BAD DATA OCCUR ON A CONTINUATION CARD
C IF SO TRY TO USE IT AS FIRST CARD OF NEXT CMND
IF(MLTCD)1210,1101,1101
1101 CONTINUE
C MAIN READ
1109 CALL CGRED
C
C * * * THE FOLLOWING CODE DOWN TO 410 WAS ADDED TO ACCOMMODATE
C * * * NO SPACE BETWEEN THE J AND THE TABLE NAME ON THE SOJ CMND
C
C * * * CHECK RECORD FOR A SLASH
400 DO 401 II=4,6
IF(IN(II)-MSLSH) 401,402,401
401 CONTINUE
GO TO 410
402 IF(II-1) 410,410,403
403 IF(IN(II-1)-MBL) 404,410,404
404 JJ=LK+1
405 IN(JJ)=IN(JJ-1)
JJ=JJ-1
IF(JJ-II) 406,406,405
406 IN(II)=MBL
LK=LK+1
410 CONTINUE
MLTCD=0
1210 IDITO=0
C FIND FIRST COLUMN
NKL=1
CALL CGCOC(KN)
C IS THIS A COMMENT
IF(KN)1240,154,1240
C CHECK FOR VALID ALPH COMMAND FORM
1240 I=NKL
C SET INDICATOR THAT THIS IS NUMERIC COMMAND
JKL=0
1250 INOW=IN(I)
IF(INOW-MBL)1260,1300,1260
1260 IF(INOW-MSLSH)1270,1300,1270
1270 IF(INOW-MA)1320,1280,1280
1280 IF(INOW-MZ)1300,1300,1320
1300 IEND=I
C SET INDICATOR THAT THIS IS ALPHABETIC COMMAND
JKL=NKL
I=I+1
IF(I-LK)1250,1250,1320
1320 IF(JKL)1330,1330,2000
C IS THIS A BLANK COMMAND
1330 IF(NXJOB)1350,1340,1350
1340 IF(KALPH)1350,1350,1400
1350 IF(NKL-1)110,110,1400
1400 IDITO=IDTSV
GO TO 154
C DECODE NUMR COMMAND
110 KVAL=(IN(NKL)-MZERO)/2**29
IF(KVAL)115,113,113
113 IF(KVAL-9)114,114,115
114 IDITO=10*IDITO+KVAL
NKL=NKL+1
IF(NKL-LK)110,110,115
C IS THIS A VALID COMMAND
115 IF(IDITO-MAXCM)116,116,192
192 IF(MLTCD)1101,194,194
194 WRITE(MOUT,1004)(IN(I),I=1,LK)
WRITE(MOUT,2991)
2991 FORMAT(' ##### INVALID COMMAND #####')
C SET SAVED COMMAND NUMBER TO ZERO IN CASE
C BLANK COMMANDS FOLLOW
IDTSV=0
C MAKE NXJOB POS TO INDICATE THAT PAGE HAS BEEN USED
NXJOB=IABS(NXJOB)
GO TO 1101
C DECODE ALPH COMMAND
2000 NWDM=0
DO 2099 I=1,MAXCM
KKL=IABS(IK(I))
KEND=IABS(IK(I+1))
IKL=JKL
NMW=0
INOW=KN
NWDS=0
KLKL=JK(KKL)
2020 KNOW=K(KLKL)
KLKL=KLKL+1
IF(KNOW-MBL)2040,2022,2040
2022 KKL=KKL+1
KLKL=JK(KKL)
GO TO 2040
2030 NMW=0
2032 IF(IKL-IEND)2036,2034,2099
2034 IKL=IKL+1
INOW=MBL
GO TO 2039
2036 IKL=IKL+1
INOW=IN(IKL)
2039 IF(NMW)2040,2040,2020
2040 IF(KKL-KEND)2050,2042,2042
2042 IF(INOW-MBL)2099,2070,2099
2050 IF(KNOW-MBL)2060,2052,2060
2052 IF(INOW-MBL)2054,2030,2054
2054 IF(INOW-MSLSH)2056,2030,2056
2056 IF(NMW)2058,2058,2099
2058 NWDS=NWDS+1
GO TO 2020
2060 IF(INOW-KNOW)2064,2062,2064
2062 NMW=NMW+1
GO TO 2032
2064 IF(NMW)2099,2099,2020
2070 IF(NMW)2099,2099,2072
2072 NWDS=NWDS+1
IF(NWDS-NWDM)2099,2090,2074
2074 IDITO=I
NKL=IKL
NWDM=NWDS
GO TO 2099
2090 IDITO=0
2099 CONTINUE
C IS THIS A VALID COMMAND
116 IF(IDITO)192,192,117
117 KKL=IABS(IK(IDITO))
KEND=IABS(IK(IDITO+1))
IF(KEND-KKL)192,192,118
C IF LISTING INPUT, PRINT THE COMMAND NAME
118 IF(LIST)142,119,142
C GET THE NAME
119 KLNTH=0
I=JK(KKL)
120 KVAL=K(I)
I=I+1
IF(KVAL-MBL)123,121,123
121 KKL=KKL+1
IF(KKL-KEND)122,126,126
122 I=JK(KKL)
123 KLNTH=KLNTH+1
NAMBF(KLNTH)=KVAL
GO TO 120
C BLANK OUT INPUTTED COMMAND NAME
126 I=NKL
127 I=I-1
IF(I)129,129,128
128 IN(I)=MBL
GO TO 127
C IF INPUT IS FROM TYPEWRITER, PRINT NAME
129 IF(INDEV-IVT)130,145,130
C IF INPUT CONTAINS ONLY COMMAND NAME, PRINT IT
130 IF(NKL-LK)131,131,145
C ELSE TRY TO PUT THE NAME INTO THE CARD IMAGE
C MAKE SURE THERE IS ROOM FOR NAME
131 IF(NKL-KLNTH-1)132,132,136
132 IF(IN(NKL)-MBL)145,134,145
134 NKL=NKL+1
GO TO 131
C TRANSFER NAME INTO INPUT IMAGE
136 DO 137 I=1,KLNTH
137 IN(I)=NAMBF(I)
IF(LK-KLNTH)138,142,142
138 LK=KLNTH
GO TO 142
C PRINT COMMAND ON A SEPARATE LINE
145 WRITE(MOUT,1004)(NAMBF(I),I=1,KLNTH)
1004 FORMAT(1X80A1)
C ACCEPTABLE ALPH OR NUM COMMAND FORM
142 IF(NXJOB)143,146,143
143 KALPH=JKL
IF(IK(IDITO))150,1101,1101
146 IF(IK(IDITO))150,148,148
C SAVE COMMAND NUMBER - THIS COMMAND DITTOS
148 IDTSV=IDITO
C IF INPUT CONTAINS ONLY COMMAND NAME, DO NOT LIST
150 IF(NKL-LK)154,154,900
C ECHO PRINT INPUT
154 CALL CGLST
C RESET MULTICARD ERROR SWITCH
MLTCD=0
C IF BLANK CARD OR COMMENT OR
C IF BLANK COMMAND FOLLOWS START/OF/JOB,END/OF/JOB,
C OR INVALID COMMAND, TREAT IT AS A COMMENT.
IF(IDITO)1101,1101,900
900 CALL CGKEY
1 CALL RTNONE
END
SUBROUTINE CGCOC(KN)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * GETS NEXT CHARACTER FROM INPUT ARRAY
C * * * RETURNS 0 IF END OF LINE FOUND
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MBL /' '/
DATA MAST /'*'/
DATA MSLSH/'/'/
KN=0
2 IF(NKL-LK)4,4,900
4 K=IN(NKL)
IF(K-MBL)12,6,12
6 NKL=NKL+1
GO TO 2
12 IF(K-MAST)14,900,14
14 IF(K-MSLSH)20,900,20
20 KN=K
900 RETURN
END
SUBROUTINE CGCOL(KN)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * GETS NEXT CHARACTER OF INPUT. USED TO READ MULTIPLE RECORDS
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
10 CALL CGCOC(KN)
IF(KN)900,20,900
20 CONTINUE
CALL CGRED
CALL CGLST
NKL=1
MLTCD=1
GO TO 10
900 RETURN
END
SUBROUTINE CGCOM
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
NCRVS = DATA(1)
NB = DATA(2)
NBC = DATA(3)
NPISP = DATA(4)
NEC = DATA(5)
XLA = DATA(6)
D1=CGNRM(DATA(7)*ISGG)
D2=CGNRM(DATA(8)*ISGG)
SGNSP = DATA(9)*ISGG
C
IF(D1-D2)2,2,3
C
C SET DEGREE OF CURVATURE
C
2 KOMSW = 1
GO TO 4
C
3 D=D2
D2=D1
D1=D
KOMSW = 0
C
4 DELT1 = XLA* D1/200.
DELT2 = XLA* D2/200.
DELT = DELT1 + DELT2
FACT1 = (DELT2 - DELT1) /12.
FACT2 = (DELT2 - DELT1)**3 /336.
FACT3 = (DELT2 - DELT1)**5 /15840.
PA = XLA * (FACT1 - FACT2 + FACT3)
C
C CALCULATE RADII.
C
R1 = 100./D1
R2 = 100./D2
C
C CALCULATE TANGENTS.
C
T2 = (R1 - COS(DELT1) * (R1-R2-PA) -R2*COS(DELT))/SIN(DELT)
T1 = SIN(DELT1)*(R1-R2-PA) + R2*SIN(DELT) - T2*COS(DELT)
IF(KOMSW)10,10,13
C
10 TTEMP = T1
T1 = T2
T2 = TTEMP
C
C FIND AZIMUTH OF NB-NBC
C
13 CALL CGGET(NB,XTEM1,YTEM1)
CALL CGGET(NBC,XNBC,YNBC)
CALL CGINV(XTEM1,YTEM1,XNBC,YNBC,ANGLE,DIST1)
C
C FIND P.I.
C
CALL CGXTL(XNBC,YNBC,ANGLE,T1,XNPI,YNPI)
CALL CGPUT(NPISP,XNPI,YNPI)
FINAZ = ANGLE + DELT*SGNSP
C
C FIND NEC.
CALL CGXTL(XNPI,YNPI,FINAZ,T2,XNEC,YNEC)
CALL CGPUT(NEC,XNEC,YNEC)
C
C WRITE OUTPUT.
C
WRITE(MOUT,1000) NCRVS
1000 FORMAT(3X,15HCOMPOUND SPIRAL,I5/)
CALL CGPCD(NBC)
CALL CGPCD(NPISP)
CALL CGPCD(NEC)
DIST1=T1+.00005
DIST2=T2+.00005
WRITE(MOUT,1001)DIST1,DIST2
1001 FORMAT(3X,12HTANGENTS T1=,F14.4,4H T2=,F14.4/)
C
C CONVERT BACK-AZIMUTH TO DEGREES + WRITE
C
CALL CGDMS(CGNRM((ANGLE+AZEZ)*ISGG),IDEG,MIN,SEC)
WRITE(MOUT,1002) IDEG,MIN,SEC
1002 FORMAT(3X, 8HBACK AZ=,I4,1H-,I3,1H-,F5.1/)
C
C CONVERT FORWARD-AZIMUTH TO DEGREES + WRITE
C
CALL CGDMS(CGNRM((FINAZ+AZEZ)*ISGG),IDEG,MIN,SEC)
WRITE(MOUT,1003) IDEG,MIN,SEC
1003 FORMAT(3X,11HFORWARD AZ=,I4,1H-,I3,1H-,F5.1/)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGCSP
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
IF(NCRVS)5690,5610,5610
5610 CONTINUE
LS = DATA(1)
ARC = DATA(2)
IF(ARC - XLS) 15,15,10
10 WRITE(MOUT,1000)
1000 FORMAT(' #####ARC GREATER THAN SPIRAL LENGTH')
GO TO 900
C FIND CENTRAL ANGLE OF SPIRAL ARC (THETA)
C (THR IS THE SPIRAL ANGLE)
C
15 THETA = ((ARC/XLS)**2)*THR*SGNSP
Y1 = (THETA*THETA)/42.0
THET4 = THETA**4
Y2 = THET4/1320.
X1 = THETA*THETA/216.
X2 = THET4/9360.
C POINT JJ IS AN INTERMEDIATE POINT.
XTEM2 = ARC*(1.-THETA*THETA*(1./10. - X1 + X2))
YTEM2 = ARC*THETA*(1./3. - Y1 + Y2)
C POINT M IS THE ORIGIN.
C
C FIND DISTANCE FROM M TO JJ.
C
CALL CGINV(0.D0,0.D0,XTEM2,YTEM2,ANGLE,DIST1)
ROT = ANGLE +AZLT
C
CALL CGGET(NTS,XNTS,YNTS)
CALL CGXTL(XNTS,YNTS,ROT,DIST1,XPOSP,YPOSP)
CALL CGPUT(LS,XPOSP,YPOSP)
CALL CGPCD(LS)
C
C FIND AZIMUTH OF SHORT TANGENT AT POINT N.
C
ANGLE = AZLT + THETA
IF(LIST)900,20,20
20 CALL CGDMS(CGNRM((ANGLE+AZEZ)*ISGG),IDEG,MIN,SEC)
DIST1=ARC+.00005
WRITE(MOUT,1001) NCRVS,DIST1,IDEG,MIN,SEC
1001 FORMAT(3X,7HSPIRAL ,I5,5H ARC=,F14.4,9H AZIMUTH=,I3,'-',I2,
*'-',F4.1/)
GO TO 900
5690 WRITE(MOUT,5691)
5691 FORMAT(' #####NO SPIRAL DEFINED')
900 CALL RTNONE
RETURN
END
SUBROUTINE CGCUR
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
IF(NCRVS)6090,6010,6010
6010 CONTINUE
C
C INPUT DATA AND INITIALIZATION.
C
LS = DATA(1)
RR = DATA(2)
NCC = DATA(3)
IREL = DATA(4)
ERROR = 0.00005
INTSW = 0
I = 0
C
C DETERMINE NUMBER OF INTERSECTION POINTS.
C
CALL CGGET(NTS,XTS,YTS)
CALL CGGET(NCC,XCC,YCC)
CALL CGINV(XTS,YTS,XCC,YCC,ANGLE,DIST1)
IF (DIST1-RR) 5,5,6
5 INTSW = 1
6 CALL CGGET(NSC,XSC,YSC)
CALL CGINV(XSC,YSC,XCC,YCC,ANGLE,DIST1)
IF(DIST1-RR) 8,8,14
8 IF(INTSW - 1) 13,10,13
C
C NO INTERSECTION.
C
10 WRITE(MOUT,1000)
1000 FORMAT(' #####NO INTERSECTION')
CALL CGPUT(LS,CLEAR,CLEAR)
CALL CGPCD(LS)
GO TO 900
13 INTSW = 2
GO TO 20
14 IF(INTSW) 20,20,50
C
C INTSW = 0 OR 2, FIND DISTANCE ALONG ARC
C
20 XTEM2=XTS
YTEM2=YTS
SIGN1 = +1.0
21 CALL CGINV(XCC,YCC,XTEM2,YTEM2,ANGLE,DIST1)
DIST1 = DIST1 - RR
IF(DIST1-XLS)24,24,10
24 ARC = DIST1
IF(SIGN1)26,27,27
26 ARC = XLS - ARC
C
C CALCULATE VALUES OF X(LS), Y(LS)
C
27 THETA = ((ARC/XLS)**2)*THR*SGNSP
Y1 = (THETA*THETA)/42.0
THET4 = THETA**4
Y2 = THET4/1320.
X1 = THETA*THETA/216.
X2 = THET4/9360.
C POINT JJ IS AN INTERMEDIATE POINT.
XTEM2 = ARC*(1.- THETA*THETA*(1./10. - X1 + X2))
YTEM2 = ARC*THETA*(1./3. - Y1 + Y2)
C FIND DISTANCE FROM M TO JJ.
CALL CGINV(0.D0,0.D0,XTEM2,YTEM2,ANGLE,DIST1)
ROT = ANGLE + AZLT
C
CALL CGXTL(XTS,YTS,ROT,DIST1,XSL,YSL)
C
CALL CGINV(XSL,YSL,XCC,YCC,ANGLE,DIST1)
DIST1 = DIST1 - RR
C COMPARE DIST1 TO ERROR.....MAX NO. OF ITERATIONS = 1000
IF(DIST1 - ERROR) 36,32,32
32 ARC = ARC + DIST1*SIGN1
IF(ARC - XLS) 35,35,10
35 I = I + 1
IF(I - 1000) 27,10,10
36 IF(INTSW) 45,45,49
45 IF(SIGN1) 60,60,48
C
C SAVE FIRST INTERSECTION POINT
C
48 XA=XSL
YA=YSL
ATOP1 = ARC
GO TO 50
49 ATOP1 = ARC
GO TO 70
C
C CALCULATE SECOND INTERSECTION POINT.
C
50 XTEM2=XSC
YTEM2=YSC
SIGN1 = -1.
GO TO 21
C
C FIND THE CLOSEST INTERSECTION POINT TO IREL
C
60 CALL CGGET(IREL,XREL,YREL)
CALL CGINV(XREL,YREL,XSL,YSL,ANGLE,D)
CALL CGINV(XREL,YREL,XA,YA,ANGLE,DIST1)
IF(DIST1-D) 62,62,63
62 XSL=XA
YSL=YA
GO TO 70
63 ATOP1 = ARC
C WRITE OUTPUT.
70 CALL CGPUT(LS,XSL,YSL)
IF(LIST)900,72,72
72 CALL CGPCD(LS)
DIST1=ATOP1+.00005
WRITE(MOUT,1001) NTS,LS,DIST1
1001 FORMAT(10X,'ARC FROM',I5,' TO',I5,' H =',F14.4/)
GO TO 900
6090 WRITE(MOUT,6091)
6091 FORMAT(' #####NO SPIRAL DEFINED')
900 CALL RTNONE
RETURN
END
SUBROUTINE CGDAL
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION ZP(2),ZN(2),ZCC(2),ZPOA(2)
DIMENSION ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(ZP(1),XP),(ZP(2),YP)
EQUIVALENCE(ZN(1),XN),(ZN(2),YN)
EQUIVALENCE(ZCC(1),XCC),(ZCC(2),YCC)
EQUIVALENCE(ZPOA(1),XPOA),(ZPOA(2),YPOA)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
EQUIVALENCE(DATA(3),STA),(DATA(5),STINT)
EQUIVALENCE(DATA(7),STFR),(DATA(8),STTO)
DATA MBL/' '/
DATA MPI/'PI'/
DATA MPC/'PC'/
DATA MPT/'PT'/
DATA MPR/'PR'/
DATA MC/'C'/
DATA ML/'L'/
DATA MR/'R'/
C DESCRIBE ALIGNMENT AZIMUTHS
C DESCRIBE ALIGNMENT BEARINGS
C * * * GET DISK RECORD NUMBER OF START OF FIGURE
KA=DATA(1)
C * * * GET FIRST POINT NUMBER OF FIGURE
CALL CGFIG(KA,N,NS)
C * * * GET COORDS OF POINT
CALL CGGET(N,XN,YN)
A=CLEAR
LORPR=0
IDA=MBL
C * * * SAVE PREVIOUS POINT NUMBER
78200 NP=N
C * * * SAVE PREVIOUS POINTS COORDS
XP=XN
YP=YN
LORPR=LOR
APRV=A
C * * * SAVE STATION OF PREVIOUS POINT
STPRV=STA
C * * * GET NEXT POINT ON FIGURE
CALL CGFIG(KA,N,NS)
C * * * IS THIS THE END OF THE FIGURE? (CURVE, END, POINT)
IF(NS)78220,78700,78210
78210 LOR=0
C * * * GET COORDS OF CURRENT POINT
CALL CGGET(N,XN,YN)
C * * * CALC AZIMUTH AND DISTANCE BETWEEN POINTS
CALL CGINV(XP,YP,XN,YN,A,DIST)
C * * * CALC STATION OF CURRENT POINT
STA=STA+DIST
GO TO 78300
C * * * CURVE DATA * * * DETERMINE RIGHT OR LEFT
78220 LOR=-NS-2
C * * * CC WAS PREVIOUS POINT
NCC=N
C * * * GET COORDS OF CC
CALL CGGET(NCC,XCC,YCC)
C * * * CALC RADIUS OF CURVE
CALL CGINV(XCC,YCC,XP,YP,APC,RAD)
C * * * GET POINT NO. OF PT
CALL CGFIG(KA,N,NS)
C * * * GET COORDS OF PT
CALL CGGET(N,XN,YN)
C * * * CALC RADIUS OF CURVE. (SUPERCEDES PREVIOUS RADIUS)
CALL CGINV(XCC,YCC,XN,YN,APT,RAD)
C * * * CALC DEFLECTION ANGLE
DEFAN=CGNRM((APT-APC)*LOR)
C * * * CALC ARC LENGTH
ARCLN=RAD*DEFAN
C * * * CALC STATION
STA=STA+ARCLN
A=APC+HFPI*LOR
78300 IF(ND-6)78400,78400,78302
78302 IF(STA-STFR)78200,78200,78304
78304 IF(APRV-CLEAR)78400,78306,78306
78306 IF(STFR-STPRV)78310,78400,78400
78310 CALL CGXTL(XP,YP,A,STFR-STPRV,XPOA,YPOA)
CALL CGFCD(ZPOA,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
STPRN=STFR+.00005
IF(STFR)78314,78316,78316
78314 STPRN=STFR-.00005
78316 WRITE(MOUT,78317)(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),STPRN
78317 FORMAT(8X,2(1X,F10.0,4I1),F18.4)
CALL CGPZB(A)
CALL CGPPA(STFR,STPRV,XP,YP,A,0,0.D0)
WRITE(MOUT,78435)
78400 IF(ND-6)78410,78410,78402
78402 IF(STPRV-STTO)78410,78700,78700
78410 IDB=MBL
IF(LOR)78412,78420,78412
78412 IDA=MPC
IF(LORPR*LOR)78414,78420,78416
78414 IDA=MPR
78416 IDB=MC
78420 CALL CGFCD(ZP,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
STPRN=STPRV+.00005
IF(STPRV)78422,78424,78424
78422 STPRN=STPRV-.00005
78424 IF(APRV-CLEAR)78430,78426,78426
78426 WRITE(MOUT,78435)IDA,IDB,NP,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),STPRN
GO TO 78440
78430 ANGLE=CGNRM(A-APRV+PI)-PI
MLOR=ML
IF(ANGLE)78432,78433,78433
78432 MLOR=MR
78433 CALL CGDMS(ABS(ANGLE),IDEG,MIN,SEC)
WRITE(MOUT,78435)IDA,IDB,NP,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),STPRN
*,IDEG,MIN,SEC,MLOR
78435 FORMAT(1X,A2,A1,I4,2(1X,F10.0,4I1),F18.4,I7,'-',I2,'-',F4.1,1X,A1)
78440 CALL CGPZB(A)
IDA=MPI
IF(LOR)78450,78600,78450
78450 CALL CGFCD(ZCC,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
RDPRN=RAD+.00005
CALL CGDMS(DEFAN,IDEG,MIN,SEC)
MLOR=ML
IF(LOR)78451,78452,78452
78451 MLOR=MR
78452 WRITE(MOUT,78453)NCC,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),RDPRN,
* IDEG,MIN,SEC,MLOR
78453 FORMAT( ' CC',I5,2(1X,F10.0,4I1),4X,'RAD=',F10.4,I7,'-',I2,'-',F4.
11,1X,A1)
DEG=100./RAD
CALL CGDMS(DEG,IDEG,MIN,SEC)
ARCPR=ARCLN+.00005
WRITE(MOUT,78457)IDEG,MIN,SEC,ARCPR
78457 FORMAT(/18X,'DEGREE=',I3,'-',I2,'-',F4.1,8X,'L=',F10.4/)
ANGLE=DEFAN/2.
COSAN=COS(ANGLE)
IF(COSAN-.1)78470,78460,78460
78460 TAN=SIN(ANGLE)/COSAN*RAD
CALL CGXTL(XP,YP,A,TAN,XPOA,YPOA)
EXT=RAD/COSAN-RAD+.00005
TAN=TAN+.00005
CALL CGFCD(ZPOA,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
WRITE(MOUT,78465)(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),TAN,EXT
78465 FORMAT( ' PI',5X,2(1X,F10.0,4I1),4X,'TAN=',F10.4,3X,'EXT=',F10.4/)
78470 IDA=MPT
A=APT+HFPI*LOR
CALL CGPPA(STPRV,STA,XCC,YCC,APT,LOR,RAD)
CALL CGPZB(A)
GO TO 78200
78600 CALL CGPPA(STPRV,STA,XN,YN,A,0,0.D0)
WRITE(MOUT,78435)
GO TO 78200
78700 CALL CGFCD(ZP,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
IF(LORPR)78702,78701,78702
78701 IDA=MBL
78702 STPRN=STPRV+.00005
IF(STPRV)78703,78704,78704
78703 STPRN=STPRV-.00005
78704 WRITE(MOUT,78435)IDA,MBL,NP,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),STPRN
IF(ND-6)78780,78780,78708
78708 IF(STTO-STPRV)78780,78780,78740
78740 CALL CGXTL(XP,YP,APRV,STTO-STPRV,XPOA,YPOA)
CALL CGPZB(APRV)
CALL CGPPA(STPRV,STTO,XPOA,YPOA,APRV,0,0.D0)
WRITE(MOUT,78435)
CALL CGFCD(ZPOA,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
STPRN=STTO+.00005
IF(STTO)78772,78774,78774
78772 STPRN=STTO-.00005
78774 WRITE(MOUT,78317)(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),STPRN
78780 WRITE(MOUT,78435)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGDBF(KFORGX,LENRC,IRW,NREC,IAREA)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C SUBROUTINE TO PROVIDE BUFFERED NON-OVERLAPPED
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C DISK READ AND WRITE FUNCTIONS.
C ARGUMENTS...
C KFORG, SECTOR ADDRESS OF DESIRED FILE
C LENRC, LENGTH OF EACH RECORD IN THE FILE
C IRW, READ/WRITE CODE
C FUNCTIONS...
C IRW=0, READ
C IRW=1, WRITE
C IRW=-1,UPDATE DISK AND CHANGE ADDRESS OF
C BUFFER TO SECTOR CONTAINING
C THE SPECIFIED RECORD.
C NREC, NUMBER OF THE DESIRED RECORD
C IAREA, DATA TO BE READ OR WRITTEN
C IF DISKZ IS USED,IBU MUST BE AT AN EVEN ADDRESS.
COMMON /COGCOM/ KBFLG,IBU(322)
DIMENSION IAREA(1),IBK(320)
EQUIVALENCE(IBU(322),KTWD),(IBU(321),NSCT)
EQUIVALENCE(IBU(1),IBK(1))
DATA KTWD/320/, NSCT/1600/, JWRT/0/, KFORG/1/
C
C FOLLOWING CODE IS KLUDGY BUT STRAIGHT-FORWARD WAY
C TO DISTINGUISH PLOT FILE FROM TABLE FILE #RLF#
LUN=8
IF (KFORGX.EQ.-1) LUN=9
KFORG=IABS(KFORGX)
C
C COMPUTE NUMBER OF RECORDS PER SECTOR
K=KTWD/LENRC
C COMPUTE DESIRED SECTOR
NSDES=KFORG+(NREC-1)/K
C IS IT IN THE BUFFER
IF (LUN.NE.LUNOLD) GO TO 20
IF(NSDES-NSCT)20,50,20
C NO - SECTOR MUST BE READ INTO BUFFER
C HAS WRITING BEEN DONE TO THIS SECTOR
20 IF(JWRT)40,40,30
C YES - WRITE THE MODIFIED BUFFER TO DISK
30 WRITE (LUNOLD#NSCT) IBK
* 30 CALL CGDZZ(1,KTWD)
C SET SECTOR NUMBER TO DESIRED SECTOR
40 NSCT=NSDES
C SET SWITCH - NO WRITING DONE TO THIS SECTOR
JWRT=0
C ADDRESS HAS BEEN CHANGED - OP COMPLETE IF IRW=-1
IF(IRW)900,45,45
C READ THE NEW SECTOR
45 LUNOLD=LUN
READ (LUN#NSCT,END=100) IBK
* 45 CALL CGDZZ(0,KTWD)
C COMPUTE THE SUBSCRIPT BASE OF THE DATA
50 N=(NREC-K*(NSCT-KFORG)-1)*LENRC
C TRANSFER THE DATA
DO 89 K=1,LENRC
N=N+1
C CHECK THE FUNCTION
IF(IRW)20,60,70
C FUNCTION IS READ
60 IAREA(K)=IBU(N)
GO TO 89
C FUNCTION IS WRITE
70 IBU(N)=IAREA(K)
C SET SWITCH - WRITING DONE TO THIS SECTOR
JWRT=1
89 CONTINUE
GO TO 900
100 DO 101 N=1,320
101 IBU(N)=0
GO TO 50
900 RETURN
END
SUBROUTINE CGDCA
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
DIMENSION ISGZ(2),ZL(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
C SET SWITCH INDICATING NEXT COORDINATE (IF ANY)
C IS FIRST OF PAIR
99999 KOORD=IXYF
C GET NEXT COLUMN ON THIS CARD
200 CALL CGCOC(KN)
C COMPUTE NUMBER OF NEXT INPUT KEY
NKEY=ND+1
C HAVE ALL KEYS BEEN USED
IF(NKEY-12)220,220,900
C NO, GET NEXT KEY
220 KEY=DATA(NKEY)
C CAN THIS COMMAND HAVE MORE DATA
IF(KEY)900,900,260
C YES, GO DECODE THE NEXT DATA ITEM
260 GO TO(1000,2000,3000,4000,5000,6000,7000,8000,
* 9000,10000,11000,12000,13000,14000,15000),KEY
C DECODE A REAL NUMBER OR EXPRESSION
1000 CONTINUE
CALL CGDDS(VALUE,J)
C CHECK FOR ERRORS
IF(J)990,990,16000
C DECODE A COORDINATE
2000 CONTINUE
CALL CGDCD(ISGZ(KOORD),ZL(KOORD),VALUE,J)
C CHECK FOR ERRORS
IF(J)990,990,2020
C SET SWITCH INDICATING NEXT COORDINATE IS SECOND
C OF PAIR
C (OR FIRST OF NEXT PAIR IF THIS WAS SECOND)
2020 KOORD=3-KOORD
GO TO 16000
C DECODE ANGLE
3000 CONTINUE
C DECODE AZIMUTH
4000 CONTINUE
C DECOD BEARING
5000 CONTINUE
CALL CGGAB(KEY,VALUE,J)
C CHECK FOR ERRORS
IF(J)990,990,16000
C DECODE INTEGER
6000 CONTINUE
C SET DEFAULT VALUE OF SIGN TO +
ISGN=1
C GET SIGN IF ANY
CALL CGSGN(ISGN)
C GET UNSIGNED INTEGER
CALL CGNTG(I,J)
C CHECK FOR ERRORS
IF(J)990,990,6020
6020 VALUE=I*ISGN
GO TO 16000
C DECODE FIGURE
7000 CONTINUE
CALL CGDFG
C DECODE OPTIONAL END
9000 CONTINUE
C IS THERE MORE DATA ON THIS CARD
IF(KN)9020,900,9020
C YES, SET UP OPTIONAL END INDICATOR FOR CGEDA
9020 VALUE=1.E20
GO TO 16000
C THESE TYPES OF DATA ARE DECODED BY CGDCB
8000 CONTINUE
10000 CONTINUE
11000 CONTINUE
12000 CONTINUE
13000 CONTINUE
14000 CONTINUE
15000 CONTINUE
CALL CGDCB
C STORE THE VALUE FOUND
16000 DATA(NKEY)=VALUE
ND=NKEY
C ADVANCE TO NEXT DATA ITEM
GO TO 200
C END OF DATA FOR THIS COMMAND
900 CONTINUE
990 CONTINUE
CALL CGEDA
RETURN
END
SUBROUTINE CGDCB
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C GET NEXT COLUMN OF THIS CARD
200 CALL CGCOC(KN)
C GET NUMBER OF NEXT INPUT KEY
NKEY=ND+1
C HAVE ALL KEYS BEEN USED
IF(NKEY-12)220,220,900
C NO, GET NEXT KEY
220 KEY=DATA(NKEY)
C IF KEY IS ZERO NO MORE DATA SHOULD BE ON CARD
IF(KEY)900,900,260
C GO DECODE THIS DATA ITEM
260 GO TO(1000,2000,3000,4000,5000,6000,7000,8000,
* 9000,10000,11000,12000,13000,14000,15000),KEY
C THESE TYPES OF DATA ARE HANDLED BY CGDCA
1000 CONTINUE
2000 CONTINUE
3000 CONTINUE
4000 CONTINUE
5000 CONTINUE
6000 CONTINUE
CALL CGDCA
C FIGURES ARE DECODED BY CGDFG
7000 CONTINUE
CALL CGDFG
C DECODE HEXADECIMAL DATA
8000 CONTINUE
C CALL CGDHX(I,J)
C CHECK FOR ERRORS
C IF(J)990,990,8010
C8010 VALUE=I
GO TO 16000
C DECODE OPTIONAL END
9000 CONTINUE
C IS THERE MORE DATA ON THIS CARD
IF(KN)9020,900,9020
C YES, SET INDICATOR FOR CGEDA IN CASE OF ERROR
9020 VALUE=1.E20
GO TO 16000
C STORE THE DATA ITEM JUST DECODED
16000 DATA(NKEY)=VALUE
ND=NKEY
GO TO 200
C THESE TYPES HAVE NOT BEEN ASSIGNED
10000 CONTINUE
11000 CONTINUE
12000 CONTINUE
13000 CONTINUE
14000 CONTINUE
15000 CONTINUE
900 CONTINUE
990 CONTINUE
C END OF DECODING OF DATA FROM THIS COMMAND
CALL CGEDA
RETURN
END
SUBROUTINE CGDCD(ISGZ,ZL,VALUE,NUM)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * DECODES COORDINATES FROM INPUT
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MPNT /'.'/
200 ISGN=0
CALL CGSGN(ISGN)
CALL CGCOL(KN)
KLM=NKL
CALL CGNUM(HPT,NUM)
IF(NUM)900,80,202
80 IF(ISGN)90,900,90
90 NUM=-1
GO TO 900
202 KP=NKL
204 KP=KP-1
IF(KP-KLM)210,206,206
206 IF(IN(KP)-MPNT)204,220,204
210 FPT=0.
GO TO 230
220 NKL=KLM
KLM=LK
LK=KP
CALL CGNUM(HPT,I)
NKL=NKL-1
LK=KLM
CALL CGNUM(FPT,I)
230 IF(ISGZ)236,234,234
234 IF(ISGN)238,250,250
236 IF(ISGN)250,238,238
238 HPT=-HPT
FPT=-FPT
250 IF(LCDA)254,254,256
254 ZL=HPT
256 VALUE=HPT-ZL+FPT
900 RETURN
END
SUBROUTINE CGDDS(DIST,NUM)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * DECODES A REAL NUMBER OR EXPRESSION
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MLPAR/'('/
DATA MRPAR/')'/
DATA MS /'S'/
DATA MR /'R'/
DATA MD /'D'/
NUM=0
ISGN=1
CALL CGSGN(ISGN)
CALL CGCOL(KN)
ACC=0.
KPAR=0
JSGN=1
KSR=0
IF(KN-MLPAR)320,240,320
240 KPAR=1
NKL=NKL+1
GO TO 310
300 JSGN=0
310 CALL CGSGN(JSGN)
CALL CGCOL(KN)
IF(JSGN)320,312,320
312 IF(KN-MRPAR)990,314,990
314 NKL=NKL+1
GO TO 700
320 KSR=0
IF(KN-MS)500,400,500
400 NKL=NKL+1
CALL CGCOL(KN)
IF(KN-MR)990,410,990
410 NKL=NKL+1
KSGN=1
CALL CGSGN(KSGN)
IF(KSGN)990,990,420
420 KSR=1
GO TO 500
430 F=VALUE
CALL CGSGN(KSGN)
KSR=-1
GO TO 500
440 F=F*F+VALUE*VALUE*KSGN
IF(F)990,450,450
450 VALUE=SQRT(F)
GO TO 600
500 CALL CGCOL(KN)
IF(KN-MD)570,510,570
510 NKL=NKL+1
CALL CGNTG(I,J)
IF(J)990,990,520
520 CALL CGGET(I,XA,YA)
IF(XA-CLEAR)530,990,990
530 CALL CGNTG(I,J)
IF(J)990,990,550
550 CALL CGGET(I,XB,YB)
IF(XB-CLEAR)560,990,990
560 CALL CGINV(XA,YA,XB,YB,AZ,VALUE)
GO TO 580
570 CALL CGNUM(VALUE,J)
IF(J)990,990,580
580 IF(KSR)440,600,430
990 NUM=-1
GO TO 900
600 ACC=ACC+VALUE*JSGN
IF(KPAR)300,700,300
700 DIST=ACC*ISGN
NUM=1
900 RETURN
END
SUBROUTINE CGDEL
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION ITB(20),JTB(20)
DIMENSION JLS(6),IXLYL(6)
DIMENSION IIXLYL(4)
DIMENSION IBUF(6)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(LFTA,LFGA)
EQUIVALENCE(JLS(1),JHDR),(JLS(2),JRSA),(JLS(3),JFGA),
* (JLS(4),JCDA),(JLS(5),JUNU),(JLS(6),JFILE)
EQUIVALENCE(IIXLYL(1),XL),(IIXLYL(3),YL)
EQUIVALENCE(IBUF(2),XBUF),(IBUF(5),YBUF)
DATA KTB/20/
DATA MAST/'*'/
DATA MSLSH/'/'/
IF(IDITO-7)2,700,2
2 IF(IDITO-87)3,8700,3
3 IF(IDITO-88)4,8800,4
4 IF(IDITO-86)900,8600,900
C 7 CLEAR
C THIS COMMAND IS PRESENT ONLY FOR COMPATABILITY
C WITH EARLIER COGOS.
C ALTHOUGH THE CODING IS SYSTEM DEPENDENT IT MAY
C BE CONVERTED TO RUN ON ANY OTHER SYSTEM SIMPLY
C BY REMOVING IT AN REMOVING THE CLEAR COMMAND.
C* 700 NDX=DATA(1)
C* NRF=(NDX+5)/6
C* IF(NRF-LFPRM)730,730,702
C* 702 CALL CGDBF(KFTB,6,0,LHDRS+NRF,IBUF)
C* IF(IBUF(2))790,790,704
C* 704 IF(IBUF(2)-10000)706,790,790
C* 706 IF(IBUF(2)-IBUF(1))790,708,708
C* 708 IF(IBUF(3)-10000)790,710,790
C* 710 IBUF(2)=-IBUF(2)
C* CALL CGDBF(KFTB,6,1,LHDRS+NRF,IBUF)
C*C QUIT IF BAD DATA. THIS COMMAND IS TOO DANGEROUS
C* 730 IF(NKL-LK)732,732,8700
C* 732 IF(IN(NKL)-MAST)734,8700,734
C* 734 IF(IN(NKL)-MSLSH)790,8700,790
C* 790 WRITE(MOUT,791)
700 WRITE(MOUT,791)
791 FORMAT(' #####','CLEAR COMMAND NOT IMPLIMENTED (CGDEL)')
C* 791 FORMAT(' #####','INVALID CLEAR ADDRESS')
GO TO 900
C 87 DELETE COORDINATES
8700 CONTINUE
C GET ADDRESS OF DESCRIPTION
NDX=DATA(1)
C IF TABLE HAS NO COORDINATES, COMMAND IS FINISHED
8702 IF(LCDA)900,900,8704
C OTHERWISHE START LOOP TO SHORTEN COORDINATE AREA
C AS MUCH AS POSSIBLE
C GET THE LAST COORDINATE IN COORDINATE AREA
8704 CALL CGDBF(KFTB,6,0,LHDRS+LFGA+LCDA,IBUF)
C IS IT DEFINED
IF(XBUF-CLEAR)8713,8706,8706
C NO, SHORTEN COORDINATE AREA BY ONE POINT
8706 CONTINUE
LCDA=LCDA-1
C LENGTHEN UNUSED AREA BY ONE RECORD
LUNU=LUNU+1
C GO CHECK NEXT LOWER COORDINATE
GO TO 8702
C GET A RANGE OF POINTS TO BE DELETED
8713 CALL CGFRG(NDX,IA,IB,ISGN)
C MAKE IT AN INCREASING RANGE. CHECK FOR END
C OF DESCRIPTION
KA=IA
KB=IB
IF(ISGN)8724,900,8728
8724 KA=IB
KB=IA
C CHECK LOCATION OF RANGE
8728 IF(KB-LCDA)8734,8730,8730
C IF ENTIRE RANGE IS OUT OF COORDINATE AREA, GO
C CHECK NEXT RANGE
8730 IF(KA-LCDA)8732,8732,8713
C RANGE STRADDLES END OF COORDINATE AREA.
C SHORTEN COORDINATE AREA.
8732 LUNU=LUNU+LCDA-KA+1
LCDA=KA-1
C GO SHORTEN COORDINATE AREA FURTHER TO
C HIGHEST REMAINING DEFINED POINT
GO TO 8702
C ENTIRE RANGE IS IN COORDINATE AREA
8734 XBUF=CLEAR
YBUF=CLEAR
C SET ALL COORDINATES IN THE RANGE TO CLEAR
DO 8739 I=KA,KB
8739 CALL CGDBF(KFTB,6,1,LHDRS+LFGA+I,IBUF)
C GO GET NEXT RANGE
GO TO 8713
C 86 GET FIGURES (CONTINUED) (DELETE FIGURES
C WHICH WERE REPLACED)
8600 LTB=1
ITB(1)=0
JTB(1)=0
GO TO 8830
C 88 DELETE FIGURES
8800 CONTINUE
C GET ADDRESS OF DESCRIPTION
NDX=DATA(1)
8810 LTB=0
8820 CALL CGFRG(NDX,IA,IB,ISGN)
KA=IA
KB=IB
IF(ISGN)8822,8830,8824
8822 KA=IB
KB=IA
8824 LTB=LTB+1
ITB(LTB)=KA
JTB(LTB)=KB
IF(LTB-KTB)8820,8830,8830
8830 NR=1
8833 NRB=NR
8834 IF(NR-LFPRM)8836,8836,8858
8836 CALL CGDBF(KFTB,6,0,LHDRS+NR,IBUF)
NR=NR+1
IF(IBUF(6)-10000)8834,8838,8838
8838 NFG=IBUF(6)-10000
DO 8849 I=1,LTB
IF(JTB(I)-NFG)8849,8844,8844
8844 IF(NFG-ITB(I))8849,8850,8850
8849 CONTINUE
GO TO 8833
8850 CALL CGDBF(KFTB,6,0,LHDRS+NRB,IBUF)
IBUF(1)=0
CALL CGDBF(KFTB,6,1,LHDRS+NRB,IBUF)
GO TO 8833
8858 IF(IDITO-86)8859,8860,8859
8859 IF(ISGN)8810,8860,8810
8860 NRPUT=0
NRGET=0
8862 KSAV=1
8864 IF(NRGET-LFPRM)8866,8884,8884
8866 NRGET=NRGET+1
CALL CGDBF(KFTB,6,0,LHDRS+NRGET,IBUF)
IF(IBUF(1))8870,8868,8870
8868 KSAV=0
8870 IF(KSAV)8878,8878,8872
8872 NRPUT=NRPUT+1
IF(NRPUT-NRGET)8876,8864,8864
8876 CALL CGDBF(KFTB,6,1,LHDRS+NRPUT,IBUF)
8878 IF(IBUF(6)-10000)8864,8880,8880
8880 DO 8881 I=1,6
8881 IBUF(I)=10000
CALL CGDBF(KFTB,6,1,LHDRS+NRGET,IBUF)
GO TO 8862
8884 LFPRM=NRPUT
I=KGFGT(0)
JPACK=(LFGA-LFPRM)/53*53
IF(JPACK)900,900,88104
88104 NR=0
88106 NR=NR+1
IF(NR-LCDA)88108,88108,88300
88108 NRF=LHDRS+LFGA+NR
CALL CGDBF(KFTB,6,0,NRF,IBUF)
CALL CGDBF(KFTB,6,1,NRF-JPACK,IBUF)
IF(NRF/53*53-NRF)88106,88200,88106
C THESE INDENTED STATEMENTS MAY BE REMOVED IF THE
C ABOVE 'IF' STATEMENT IS REPLACED BY THE STATEMENT
C 'GO TO 88106'. THEN THE PACKING CONSTANT OF '53' MAY
C BE CHANGED IF DESIRED.
88200 IF(NR-LCDA)88202,88300,88300
88202 NR=NR+53
NRF=LHDRS+LFGA+NR
CALL CGDBF(KFTB,6,0,NRF,IBUF)
CALL CGDBF(KFTB,6,-1,NRF-JPACK,IBUF)
CALL CGDBF(KFTB,6,1,NRF-JPACK,IBUF)
GO TO 88200
88300 LFGA=LFGA-JPACK
LUNU=LUNU+JPACK
CALL CGDBF(KFTB,6,0,2,JLS)
JFGA=LFGA
JCDA=LCDA
JUNU=LUNU
CALL CGDBF(KFTB,6,1,2,JLS)
IXLYL(2)=IIXLYL(1)
IXLYL(3)=IIXLYL(2)
IXLYL(5)=IIXLYL(3)
IXLYL(6)=IIXLYL(4)
CALL CGDBF(KFTB,6,1,3,IXLYL)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGDFG
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION LFT(6)
DIMENSION JBFA(6,53)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MLPAR/'('/
DATA MINUS/'-'/
DATA MC /'C'/
DATA ML /'L'/
DATA MR /'R'/
DATA MT /'T'/
DATA MRPAR/')'/
10 CALL CGCOC(KN)
NKEY=ND+1
IF(NKEY-12)20,20,900
20 KEY=DATA(NKEY)
IF(KEY)900,900,60
60 IF(KEY-7)62,70,64
62 CALL CGDCA
64 CALL CGDCB
70 CALL CGCOL(KN)
IF(KN-MLPAR)100,3000,100
100 IF(ND)104,104,2000
104 IF(DATA(2))2000,110,2000
110 CALL CGNTG(NFG,I)
J=NKL
CALL CGCOC(KN)
NKL=J
IF(KN)112,2002,112
112 IF(KN-MT)4000,2002,4000
2000 CALL CGNTG(NFG,I)
2002 IF(I)990,990,2012
2012 IF(NFG)2090,2090,2014
2014 IF(NFG-10000)2020,2090,2090
2020 NWD=0
2022 KTF=NWD+1
2023 NWD=NWD+6
IF(NWD/6-LFPRM)2024,2024,2090
2024 I=KGFGT(NWD)-10000
IF(I)2023,2026,2026
2026 IF(I-NFG)2022,2030,2022
2030 CALL CGCOC(KN)
IF(KN-MT)2060,2050,2060
2050 I=(NWD-KTF+1)/6
CALL CGIFA(JBFA,I-(LFGA-LFTOT))
IF(I-(LFGA-LFTOT))2056,2056,990
2056 DATA(NKEY)=NWD
ND=NKEY
GO TO 4188
2060 IF(IDITO-70)2062,2070,2062
2062 DATA(NKEY)=KTF
ND=NKEY
GO TO 10
2070 I=(NWD-KTF+1)/6
CALL CGIFA(JBFA,I-(LFGA-LFTOT))
IF(I-(LFGA-LFTOT))2072,2072,990
2072 J=LFTOT
2074 J=J+1
KTF=KTF+6
CALL CGDBF(KFTB,6,0,LHDRS+KTF/6,LFT)
CALL CGDBF(KFTB,6,1,LHDRS+J,LFT)
IF(KTF-NWD)2074,2076,2076
2076 DO 2079 I=1,6
IF(LFT(I)-10000)2079,2078,2078
2078 LFT(I)=10000
2079 CONTINUE
CALL CGDBF(KFTB,6,1,LHDRS+J,LFT)
DATA(NKEY)=LFTOT*6+1
ND=NKEY
LFTOT=J
GO TO 10
2090 WRITE(MOUT,2091)NFG
2091 FORMAT(' #####','UNDEFINED FIGURE',I6)
GO TO 990
3000 KPAR=1
NKL=NKL+1
GO TO 4010
4000 KPAR=0
ITEM=NFG
4010 KTF=LFTOT*6
ISGN=1
ISCC=1
IF(KPAR)4123,4123,4020
4020 IF(KPAR)4030,4030,4050
4030 CALL CGCOC(KN)
IF(KN)4032,4170,4032
4032 IF(KN-MT)4100,4170,4100
4050 CALL CGCOL(KN)
IF(KN-MRPAR)4100,4170,4100
4100 IF(KN-MINUS)4106,4140,4106
4106 IF(KN-MC)4108,4150,4108
4108 IF(KN-ML)4110,4160,4110
4110 IF(KN-MR)4120,4162,4120
4120 IF(ISCC)4122,4092,4122
4122 CALL CGNTG(ITEM,I)
4123 IF(I)4092,4092,4124
4124 IF(ITEM)4092,4092,4126
4126 IF(ITEM-10000)4130,4092,4092
4130 IF(ISGN)4132,4136,4136
4132 IF(IABS(IABS(NMPRV)-ITEM)-MINDF)4092,4134,4134
4134 ITEM=-ITEM
4136 NMPRV=ITEM
MINDF=1
ISGN=0
ISCC=ISCC+1
7060 KTF=KTF+1
IF(KTF-6*LFGA)7070,7062,7062
7062 CALL CGIFA(JBFA,1)
IF(KTF-6*LFGA)7070,990,990
7070 NREC=LHDRS+(KTF+5)/6
CALL CGDBF(KFTB,6,0,NREC,LFT)
NSS=KTF-6*(NREC-LHDRS-1)
LFT(NSS)=ITEM
CALL CGDBF(KFTB,6,1,NREC,LFT)
GO TO 4020
4140 IF(ISGN)4092,4142,4092
4142 IF(ISCC)4092,4092,4144
4144 ISGN=-1
NKL=NKL+1
GO TO 4020
4150 IF(ISCC-1)4092,4152,4156
4152 IF(ISGN)4154,4092,4092
4154 MINDF=2
4156 ISCC=-1
NKL=NKL+1
GO TO 4020
4160 ITEM=-10003
GO TO 4164
4162 ITEM=-10001
4164 IF(ISCC)4092,4166,4092
4166 ISCC=1
NKL=NKL+1
GO TO 7060
4170 IF(ISGN)4092,4172,4092
4172 IF(ISCC-1)4092,4092,4180
4092 CONTINUE
IF(KPAR)41900,41900,990
41900 IF(ISGN)41902,41902,990
41902 NKL=NKL-1
ISGN=1
J=KGFGT(0)
IF(KGFGT(KTF)+10000)4182,4182,4180
4180 KTF=KTF+1
4182 NREC=LHDRS+(KTF+5)/6
CALL CGDBF(KFTB,6,0,NREC,LFT)
NSS=KTF-6*(NREC-LHDRS-1)
DO 4184 NS=NSS,6
4184 LFT(NS)=10000
CALL CGDBF(KFTB,6,1,NREC,LFT)
C UPDATE KGFGT BUFFER
I=KGFGT(0)
DATA(NKEY)=LFTOT*6+1
ND=NKEY
LFTOT=(KTF+5)/6
IF(ISGN)990,4186,990
4186 NKL=NKL+KPAR
CALL CGCOC(KN)
IF(KN-MT)10,4188,10
4188 NKL=NKL+1
CALL CGFTR
900 CONTINUE
990 CONTINUE
CALL CGEDA
RETURN
END
SUBROUTINE CGDMS(ANGLE,IDEG,MIN,SEC)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C CONVERT RADIANS TO DEG-MIN-SEC ROUNDING TO TENTH OF SECOND
FDEG=ANGLE*57.2957795130823216D0+.138888889D-04
IDEG=FDEG
FMIN=(FDEG-IDEG)*60.
MIN=FMIN
SEC=(FMIN-MIN)*60.-.05
IF(SEC.LT.0.0) SEC=0.0
RETURN
END
SUBROUTINE CGDVF
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION ZPOA(2),ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(ZPOA(1),XPOA),(ZPOA(2),YPOA)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
C DIVIDE FIGURE
10300 CONTINUE
C * * * GET DISK RECORD NUMBER OF START OF FIGURE
KTF=DATA(1)
FIGLN=0.
CALL CGFIG(KTF,N,NS)
10302 CALL CGGET(N,XP,YP)
IF(XP-CLEAR)10304,900,900
10304 CALL CGFIG(KTF,N,NS)
IF(NS)10308,10320,10306
10306 CALL CGGET(N,XN,YN)
CALL CGINV(XP,YP,XN,YN,A,DIST)
GO TO 10312
10308 LOR=-NS-2
CALL CGGET(N,XCC,YCC)
IF(XCC-CLEAR)10310,900,900
10310 CALL CGFIG(KTF,N,NS)
CALL CGGET(N,XN,YN)
CALL CGINV(XCC,YCC,XP,YP,APC,RAD)
CALL CGINV(XCC,YCC,XN,YN,APT,RAD)
DIST=RAD*CGNRM((APT-APC)*LOR)
10312 FIGLN=FIGLN+DIST
GO TO 10302
10320 NSEGS=DATA(2)
IF(NSEGS-1)10392,900,10322
10322 NXPNT=DATA(3)
IF(NXPNT)10394,10394,10324
C * * * GET MAXIMUM POINT DEFINED
10324 N=NXPNT+NSEGS-2
C * * * IS IT A VALID NUMBER (YES, YES, NO)
IF(N-9999)10326,10326,10394
C * * * WILL IT FIT INTO THE TABLE? (YES, YES, NO)
10326 IF(N-(LCDA+LUNU))10328,10328,10394
10328 NXSEG=1
KTF=DATA(1)
STA=0.
STDES=FIGLN/NSEGS
CALL CGFIG(KTF,N,NS)
10330 CALL CGGET(N,XP,YP)
NP=N
CALL CGFIG(KTF,N,NS)
IF(NS)10340,10331,10332
C FIGURE CONTAINS ONLY ONE POINT
10331 N=NP
10332 LOR=0
CALL CGGET(N,XN,YN)
CALL CGINV(XP,YP,XN,YN,A,DIST)
STA=STA+DIST
10334 IF(STDES-STA)10336,10336,10330
10336 CALL CGXTL(XN,YN,A,STDES-STA,XPOA,YPOA)
GO TO 10350
10340 LOR=-NS-2
CALL CGGET(N,XCC,YCC)
CALL CGFIG(KTF,N,NS)
CALL CGGET(N,XN,YN)
CALL CGINV(XCC,YCC,XP,YP,APC,RAD)
CALL CGINV(XCC,YCC,XN,YN,APT,RAD)
STA=STA+RAD*CGNRM((APT-APC)*LOR)
10342 IF(STDES-STA)10344,10344,10330
10344 CALL CGXTL(
*XCC,YCC,APT+(STDES-STA)/RAD*LOR,RAD,XPOA,YPOA)
10350 CALL CGPUT(NXPNT,XPOA,YPOA)
IF(LIST)10356,10352,10352
10352 CALL CGFCD(ZPOA,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
WRITE(MOUT,10353)NXPNT,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),NP,N
10353 FORMAT(I8,2(1X,F10.0,4I1),4X,'SEG',2I5/)
10356 NXPNT=NXPNT+1
NXSEG=NXSEG+1
IF(NXSEG-NSEGS)10360,900,900
10360 STDES=FIGLN*NXSEG/NSEGS
IF(LOR)10342,10334,10342
10392 WRITE(MOUT,10393)NSEGS
10393 FORMAT(' #####','INVALID NUMBER OF PARTS',I6)
GO TO 900
10394 WRITE(MOUT,10395)NXPNT,N
10395 FORMAT(' #####','INVALID POINT RANGE',I6,' TO',I6)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGEDA
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * PROCESSES END OF DATA RECORD AND ANY ERRORS FOUND
C * * * BY OTHER ROUTINES
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MSLSH/'/'/
DATA MAST /'*'/
DATA MINUS/'-'/
DATA MBL /' '/
C * * * GET POINTER TO NEXT ITEM IN 'DATA'
NKEY=ND+1
C * * * HAS THE END OF LINE BEEN PROCESSED? (NO,NO,YES)
IF(NKL-LK)202,202,220
C * * * GET THE NEXT CHARACTER
202 KN=IN(NKL)
C * * * CHECK FOR A COMMENT (NO,YES,NO)
IF(KN-MAST)204,220,204
C * * * CHECK FOR A COMMENT (NO,YES,NO)
204 IF(KN-MSLSH)990,220,990
C * * * HAD ALL ITEMS IN DATA BEEN PROCESSED?(NO,NO,YES)
220 IF(NKEY-12)222,222,999
C * * * WAS THE NEXT ONE ZERO?(NO,YES,NO)
222 IF(DATA(NKEY))224,972,224
C * * * WAS IT A 9? (TEST FOR OPTIONAL DATA) (NO,YES,NO)
224 IF(DATA(NKEY)-9)990,972,990
C * * * SHOULD WE PRINT (YES,NO,YES)
990 IF(LIST)992,994,992
C * * * ECHO THE COMMAND AS TYPED
992 WRITE(MOUT,1002)(IN(I),I=1,LK)
1002 FORMAT(1X80A1)
994 WRITE(MOUT,1004)(MBL,I=2,NKL),MINUS,MINUS
1004 FORMAT(81A1)
WRITE(MOUT,1006)
1006 FORMAT(' #####BAD DATA')
C * * * INDICATE NO PAGE EJECT
NXJOB=IABS(NXJOB)
C * * * INDICATE BAD DATA
MLTCD=-MLTCD
C * * * HAD ALL COLUMNS OF 'DATA' BEEN PROCESSED? (NO,NO,YES)
IF(NKEY-12)996,996,999
C * * * WAS THE NEXT ONE ZERO? (NO,YES,NO)
996 IF(DATA(NKEY))997,999,997
C * * * WAS IT CLEARED? (NO,YES,YES)
997 IF(DATA(ND)-1.E20)962,970,970
C * * * WAS THIS THE SAME COMMAND? (NO,YES,NO)
962 IF(IDTSV-IDITO)970,963,970
C * * * GO GET NEXT COMMAND
963 CALL RTNONE
970 DATA(NKEY)=0.
C * * * INCREMENT TO POINT TO NEXT ITEM IN 'DATA'
NKEY=NKEY+1
C * * * HAS ALL OF 'DATA' BEEN ZERO'ED? (NO,NO,YES)
972 IF(NKEY-12)974,974,999
974 IF(DATA(NKEY))970,999,970
C * * * GO PROCESS THE NEXT COMMAND
999 CALL CGXCM
RETURN
END
SUBROUTINE CGFBG(KTF,N,NS,X,Y,NBF,NSBF,XBF,YBF,LNB,KNB)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * FILLS TWO BUFFERS WITH FIGURE DATA. POINTS GO FROM NBF
C * * * TO NSBF. CURVE DIRECTIONS ARE ALWAYS IN NSBF.
C * * * CC'S ARE OPPOSITE DIRECTIONS IN NBF
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION NBF(1),NSBF(1),XBF(1),YBF(1)
IF(KNB-LNB)70,50,50
50 DO 59 I=1,LNB
CALL CGFIG(KTF,N,NS)
NBF(I)=N
NSBF(I)=NS
IF(NS)56,59,56
56 CALL CGGET(N,XBF(I),YBF(I))
59 CONTINUE
KNB=0
70 KNB=KNB+1
N=NBF(KNB)
NS=NSBF(KNB)
X=XBF(KNB)
Y=YBF(KNB)
RETURN
END
SUBROUTINE CGFCD(ZINT,ZL,ISGZ,IXYF,ZWHOL,IZ,IERR)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION ZINT(2),ZL(2),ISGZ(2),ZWHOL(2),IZ(4,2)
DATA CONST/0.00005/
C SET POINTER FOR STORING X COORD
IFL=IXYF
C DO FOR X THEN Y
DO 559 M=1,2
ZWHOLX=ZL(M)+ZINT(M)
ZWHOLX=ZWHOLX+DSIGN(CONST,ZWHOLX)
IZI=ZWHOLX
FR=ABS(ZWHOLX-IZI)
ZWHOL(IFL)=IZI-0.00001
C DIVIDE FRACTIONAL PART INTO 4 DIGITS
DO 539 I=1,4
IZI=FR*10
FR=FR*10-IZI
539 IZ(I,IFL)=IZI
C SET POINTER FOR STORING Y COORD
IFL=3-IFL
559 CONTINUE
900 RETURN
END
SUBROUTINE CGFIG(KTF,NPF,NS)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * THIS ROUTINE GETS THE NEXT POINT ON A FIGURE. IF
C * * * THE 'THROUGH' CONVENTION WAS USED IT ALSO RETURNS THE
C * * * INTERMEDIATE POINTS. RETURNS CURVE DATA IN NS.
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C * * * GET CONTENTS OF WORD KTF
I=KGFGT(KTF)
C * * * IS IT VALID? (NO,YES,YES)
IF(I)740,900,710
C * * * SAVE
C IF(I)AUTO,ERROR,PT NO OR END
710 NPF=I
C * * * IS IT A FIGURE NUMBER? (NO,YES,YES)
IF(I-10000)715,619,619
C IF(I-10000)PT NO,,END
C * * * GET NEXT
715 KTF=KTF+1
NS=KGFGT(KTF)+10000
C * * * IS IT A CURVE? (YES,YES,NO)
IF(NS)720,720,900
C IF(NS)CURVE,,NO CURVE
C * * * POINT TO NEXT WORD.
720 KTF=KTF+1
GO TO 900 !RETURN
C * * * FOUND A 'THROUGH'
740 NS=-I
C * * * CHECK DIRECTION OF THROUGH
IF(NPF-NS)742,744,744
742 NPF=NPF+1
GO TO 746
744 NPF=NPF-1
746 IF(NPF-NS)900,715,900
619 NS=0
900 RETURN
END
SUBROUTINE CGFIN
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(IN(3),KTFA),(IN(6),KTB),(IN(9),FSTA),(IN(12),FSTB),
*(IN(15),M),(IN(18),XM),(IN(21),YM),(IN(24),SGINT),(IN(27),SGPRS),
*(IN(30),XI),(IN(33),YI),(IN(36),LKAB),(IN(39),LKBB),(IN(42),KVB),
*(IN(45),XAB),(IN(48),YAB),(IN(51),XBB),(IN(54),YBB),(IN(57),XCB),
*(IN(60),YCB)
IF(KTB)10054,10054,10030
10030 CALL CGFSG(KTB,LKBB,FSTB,XAB,YAB,XBB,YBB,KVB,XCB,YCB
* ,KVNB,XNB,YNB)
IF(XAB-CLEAR)10032,9890,9890
10032 SGPRS=SGPRS+10000.
10054 KTA=KTFA
LKAA=0
LKBA=0
SGPRS=IFIX(SNGL(SGPRS/10000.))*10000.
30 CALL CGFSG(
* KTA,LKBA,FSTA,XAA,YAA,XBA,YBA,KVA,XCA,YCA,
* KVNA,XNA,YNA)
IF(XAA-CLEAR)32,9890,9890
32 SGPRS=SGPRS+1.
IF(KVA)46,45,46
45 IF(KVB)60,50,60
46 IF(KVB)80,56,80
50 CALL CGGPN(LKAA,XAA,YAA,LKBA,XBA,YBA,
* LKAB,XAB,YAB,LKBB,XBB,YBB)
GO TO 89
56 CALL CGGCL(LKAA,XAA,YAA,LKBA,XBA,YBA,KVA,XCA,YCA,
* LKAB,XAB,YAB,LKBB,XBB,YBB)
GO TO 89
60 CALL CGGCL(LKAB,XAB,YAB,LKBB,XBB,YBB,KVB,XCB,YCB,
* LKAA,XAA,YAA,LKBA,XBA,YBA)
GO TO 89
80 CALL CGINV(XCA,YCA,XAA,YAA,AZCA,DCA)
CALL CGINV(XCB,YCB,XAB,YAB,AZCB,DCB)
CALL CGAAI(XCA,YCA,DCA,XCB,YCB,DCB,XIA,YIA,XIB,YIB)
CALL CGPOC(KVA,XAA,YAA,XBA,YBA,XIA,YIA)
CALL CGPOC(KVB,XAB,YAB,XBB,YBB,XIA,YIA)
CALL CGCLM(XIA,YIA)
CALL CGPOC(KVA,XAA,YAA,XBA,YBA,XIB,YIB)
CALL CGPOC(KVB,XAB,YAB,XBB,YBB,XIB,YIB)
CALL CGCLM(XIB,YIB)
IF(LKAA)81,81,82
81 CALL CGINV(XCA,YCA,XAA,YAA,AZ,D)
CALL CGXTL(XAA,YAA,AZ-HFPI*KVA,1000.D0,XT,YT)
CALL CGGCL(LKAB,XAB,YAB,LKBB,XBB,YBB,KVB,XCB,YCB,
* 0,XT,YT,1,XAA,YAA)
82 IF(LKBA)83,83,84
83 CALL CGINV(XCA,YCA,XBA,YBA,AZ,D)
CALL CGXTL(XBA,YBA,AZ+HFPI*KVA,1000.D0,XT,YT)
CALL CGGCL(LKAB,XAB,YAB,LKBB,XBB,YBB,KVB,XCB,YCB,
* 1,XBA,YBA,0,XT,YT)
84 IF(LKAB)85,85,86
85 CALL CGINV(XCB,YCB,XAB,YAB,AZ,D)
CALL CGXTL(XAB,YAB,AZ-HFPI*KVB,1000.D0,XT,YT)
CALL CGGCL(1,XAA,YAA,1,XBA,YBA,KVA,XCA,YCA,
* 0,XT,YT,1,XAB,YAB)
86 IF(LKBB)87,87,89
87 CALL CGINV(XCB,YCB,XBB,YBB,AZ,D)
CALL CGXTL(XBB,YBB,AZ+HFPI*KVB,1000.D0,XT,YT)
CALL CGGCL(1,XAA,YAA,1,XBA,YBA,KVA,XCA,YCA,
* 1,XBB,YBB,0,XT,YT)
89 LKAA=1
IF(LKBA)10058,10058,30
10058 IF(KTB)9880,9880,10060
10060 LKAB=1
IF(LKBB)9880,9880,10030
9890 SGINT=0.
9880 CONTINUE
900 CALL CGSTI
RETURN
END
SUBROUTINE CGFIT
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
C EQUIVALENCE FOR FIT ROUTINE
EQUIVALENCE (DATA(11),XLS2),(DATA(10),CENTA),(DATA(9),DEFAN)
C
IF(DATA(12))400,100,400
100 NCRVS = DATA(1)
NBA = DATA(2)
NPIMN = DATA(3)
DC=CGNRM(DATA(4)*ISGG)
XLS1 = DATA(5)
XLS2 = DATA(6)
DEFAN = CGNRM(DATA(7)*ISGG)
SGNSP = DATA(8)*ISGG
C
C CALCULATE SPIRAL ANGLE FOR SPIRAL1 AND SPIRAL 2.
C
DCX = (DC/200.)
THR1 = XLS1*DCX
THR2 = XLS2*DCX
C
C CALCULATE FACTORS FOR FINDING TANGENTS OF SPIRAL 1.
C
FACT1 = 1.- THR1*THR1/10. + THR1**4/216. - THR1**6/9360.
FACT2 = THR1/3. - THR1**3/42. + THR1**5/1320. - THR1**7/75600.
C
C CALCULATE TANGENT LENGTHS OF SPIRAL 1 (ST1 AND XLT1).
C
XS = XLS1*FACT1
YS = XLS1*FACT2
ST1 = YS/SIN(THR1)
XLT1= XS - YS*(COS(THR1)/SIN(THR1))
C
C CALCULATE SHORT TANGENT LENGTH FOR SPIRAL 2 (ST2).
C
FACT2 = THR2/3. - THR2**3/42. + THR2**5/1320. - THR2**7/75600.
YS = XLS2*FACT2
ST2 = YS/SIN(THR2)
C
C CALCULATE TANGENT LENGTH FOR CIRCULAR CURVE (TC).
C
CENTA = DEFAN - THR1 - THR2
RC = 100./DC
TC = RC*SIN(CENTA/2.) / COS(CENTA/2.)
C
C SOLVE TRIANGLE FORMED BY SIDES (ST1+TC),(ST2+TC), AND THE LINE
C JOINING THE PI OF EACH SPIRAL.
C
C ANGLE OF TRIANGLE.
ALPHA= PI - CENTA
C TWO SIDES OF TRIANGLE.
C = ST1 + TC
B = ST2 + TC
C DISTANCE BETWEEN PI OF EACH SPIRAL.
A = SQRT( B*B + C*C - 2.*B*C*COS(ALPHA))
C FIND ANGLE BETA, OPPOSITE SIDE B.
BETA = ATAN(B*SIN(ALPHA)/(C-B*COS(ALPHA)))
C
C SOLVE TRIANGLE FORMED BY SPIRAL PIS AND MAIN PI.
C
ALPHA = PI - DEFAN
BETA = BETA + THR1
C = (A/SIN(ALPHA))*SIN(ALPHA + BETA)
C NOTE...C IS DISTANCE FROM MAIN PI TO PI OF FIRST SPIRAL.
C THUS START POINT OF ALIGNMENT IS A DISTANCE C+ LONG TANGENT OF
C FIRST SPIRAL, FROM TANGENT PI TOWARDS POINT NBA.
C
C LOCATE TS OF FIRST SPIRAL.
C
J = NPIMN
N = NBA
C CALCULATE AZIMUTH OF NPIMN-NA.
CALL CGGET(J,XTEM1,YTEM1)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
C LOCATE TS AND STORE IN NCRVS+1.
DIST1 = C + XLT1
N = NCRVS + 1
CALL CGXTL(XTEM1,YTEM1,ANGLE,DIST1,XTS,YTS)
CALL CGPUT(N,XTS,YTS)
C
C ENTER VALUES TO SIMPLE/SPIRAL ROUTINE.
C CALL SIMSP
C
DATA(1) = NCRVS
DATA(2) = NBA
DATA(3) = N
DATA(4) = NCRVS + 2
DATA(5) = NCRVS + 3
DATA(6) = XLS1
DATA(7) = DC *ISGG
DATA (8) = SGNSP*ISGG
DATA(12)=NPIMN
C CALL CGSIM
RETURN
C
C
C ADDITIONAL OUTPUTPUT FOR FIT/ALIGN ROUTINE.
C
C WRITE OUT MAIN BACK-TANGENT
C
400 CONTINUE
NPIMN=DATA(12)
RC = 100./DC
IF(LIST)420,410,410
410 J = NCRVS + 1
N = NPIMN
CALL CGGET(J,XTEM1,YTEM1)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
WRITE(MOUT,4000) J,N,DIST1
4000 FORMAT(3X,8HFROM PT.,I4,7H TO PT.,I4,6H DIST=,F14.4/)
C
C WRITE OUT MAIN FORWARD-TANGENT.
C
J = NCRVS + 7
CALL CGGET(J,XTEM1,YTEM1)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
WRITE (MOUT,4000) N,J,DIST1
C
C WRITE OUT DEFLECTION ANGLE.
C
CALL CGDMS(DEFAN,IDEG,MIN,SEC)
WRITE (MOUT,4001) IDEG,MIN,SEC
4001 FORMAT(3X,18HDEFLECTION ANGLE =,I4,1H-,I3,1H-,F5.1)
C
C WRITE OUT CURVE CENTRAL ANGLE.
C
CALL CGDMS(CENTA,IDEG,MIN,SEC)
WRITE(MOUT,4002) IDEG,MIN,SEC
4002 FORMAT(3X,21HCURVE CENTRAL ANGLE =,I4,1H-,I3,1H-,F5.1/)
C
C LOCATE CIRCLE CENTRE (POINT 1000).
C
420 J = NCRVS + 2
N = NCRVS + 4
CALL CGGET(J,XTEM1,YTEM1)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
SGNSP=-SGNSP
ANGRC = ANGLE + HFPI*SGNSP
C
J = NCRVS + 3
CALL CGGET(J,XTEM1,YTEM1)
CALL CGXTL(XTEM1,YTEM1,ANGRC,RC,XCC,YCC)
C
C FIND DISTANCE NPIMN-CIRCLE CENTER. THEN CALCULATE OFFSET
C
J = NPIMN
CALL CGGET(J,XTEM1,YTEM1)
CALL CGINV(XTEM1,YTEM1,XCC,YCC,ANGLE,DIST1)
C
OFF = DIST1 - RC
C
C FIND INTERSECTION POINT ON CURVE
C
N = NCRVS + 8
J = NPIMN
CALL CGGET(J,XTEM1,YTEM1)
CALL CGXTL(XTEM1,YTEM1,ANGLE,OFF,XPOC,YPOC)
CALL CGPUT(N,XPOC,YPOC)
C
C WRITE OUT INTERSECTION POINT AND OFFSET.
C
IF(LIST)900,430,430
430 WRITE (MOUT,4003) NPIMN,N,OFF
4003 FORMAT(3X,11HRADIAL FROM,I4,24H INTERSECTS ALIGNMENT AT,
1 I4/3X,7HOFFSET=,F14.4)
CALL CGPCD(N)
C
900 CALL RTNONE
RETURN
END
SUBROUTINE CGFRG(KTF,IA,IB,ISGN)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * GETS NEXT SPEC FROM FIGURE IF IT IS SPECIFIED
C * * * AS A 'THROUGH'. (INCLUDES INTERMEDIATE POINTS)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C * * * GET NEXT WORD FROM FIGURE
2 I=KGFGT(KTF)
C * * * IS IT A FIGURE NUMBER? (NO,YES,YES)
IF(I-10000)4,90,90
C * * * POINT TO NEXT WORD IN FIGURE
4 KTF=KTF+1
C * * * IS THIS A CURVE SPEC?(YES,YES,NO)
IF(I+10000)2,2,6
C * * * POSSIBLE 'THROUGH'
6 ISGN=1
C * * * IS IT A 'THROUGH'? (YES,NO,NO)
IF(I)14,12,12
12 IA=I
IB=I
GO TO 900
C * * * WAS LAST ONE GREATER? (NO,NO,YES)
14 IF(IB+I)18,18,16
16 ISGN=-1
18 IA=IB+ISGN
IB=-I
GO TO 900
90 ISGN=0
900 RETURN
END
SUBROUTINE CGFSG(KTF,NPF,FST,XA,YA,XB,YB,KV,XC,YC,KVN,XN,YN)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA HFPI/1.5707963267948966D0/
DATA CLEAR/1.E20/
IF(NPF)10,10,20
10 CALL CGFIG(KTF,NPF,NS)
CALL CGGET(NPF,XNX,YNX)
IF(XNX-CLEAR)11,990,990
11 CALL CGFIG(KTF,NPF,NS)
CALL CGGET(NPF,XN,YN)
CALL CGINV(XN,YN,XNX,YNX,AZ,D)
D=FST
IF(NS)12,990,14
12 KVN=-NS-2
D=D*KVN
GO TO 16
14 KVN=0
AZ=AZ+HFPI
CALL CGXTL(XN,YN,AZ,D,XN,YN)
16 CALL CGXTL(XNX,YNX,AZ,D,XB,YB)
20 XA=XB
YA=YB
XB=XN
YB=YN
CALL CGGET(NPF,XNR,YNR)
IF(XNR-CLEAR)21,990,990
21 KV=KVN
IF(KV)22,24,22
22 CALL CGGET(NPF,XC,YC)
CALL CGFIG(KTF,NPF,NS)
CALL CGGET(NPF,XNR,YNR)
IF(XNR-CLEAR)23,990,990
23 CALL CGINV(XC,YC,XNR,YNR,AZR,RAD)
RAD=RAD+FST*KV
CALL CGXTL(XC,YC,AZR,RAD,XB,YB)
24 CALL CGFIG(KTF,NPF,NS)
KVN=0
IF(NS)26,90,28
26 KVN=-NS-2
CALL CGGET(NPF,XN,YN)
28 CALL CGGET(NPF,XNX,YNX)
IF(XNX-CLEAR)30,990,990
30 CALL CGINV(XNR,YNR,XNX,YNX,AZ,D)
AZF=AZ-HFPI
IF(KVN)50,32,50
32 CALL CGXTL(XNX,YNX,AZF,FST,XN,YN)
CALL CGXTL(XNR,YNR,AZF,FST,XNX,YNX)
IF(KV)40,34,40
34 CALL CGPIN(XA,YA,XB,YB,XNX,YNX,XN,YN,XIB,YIB)
35 IF(XIB-CLEAR)36,900,900
36 XB=XIB
YB=YIB
GO TO 900
40 CALL CGALZ(XC,YC,RAD,XNX,YNX,AZ,XNR,YNR,XIB,YIB)
GO TO 54
50 D=D+FST*KVN
IF(KV)60,52,60
52 CALL CGINV(XA,YA,XB,YB,AZR,RAD)
CALL CGALZ(XNX,YNX,D,XB,YB,AZR,XNR,YNR,XIB,YIB)
54 IF(ABS(SIN(AZR-AZF))-.484813681E-4)900,56,56
56 CALL CGINV(XNR,YNR,XB,YB,AZ,D)
CALL CGINV(XIB,YIB,XB,YB,AZ,RAD)
IF(D-RAD)58,36,36
58 XIB=XNR
YIB=YNR
GO TO 35
60 CALL CGAAI(XC,YC,RAD,XNX,YNX,D,XNR,YNR,XIB,YIB)
AZF=AZ
GO TO 54
990 XA=CLEAR
90 NPF=0
900 RETURN
END
SUBROUTINE CGFST(XA,YA,XB,YB,XF,YF,XI,YI)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA CLEAR/1.E20/
XBA=XB-XA
YBA=YB-YA
XBAQ=XBA*XBA
YBAQ=YBA*YBA
XYBA=XBA*YBA
DENOM=XBAQ+YBAQ
IF(DENOM)20,90,20
20 XI=(XF*XBAQ-(YA-YF)*XYBA+XA*YBAQ)/DENOM
YI=(YF*YBAQ-(XA-XF)*XYBA+YA*XBAQ)/DENOM
900 RETURN
90 XI=CLEAR
YI=CLEAR
GO TO 900
END
SUBROUTINE CGFSY(XREAL,IA,NDX)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C * * CONVERTS XREAL TO 'XX---XZZ.ZZZZ' IN IA(NDX) THRU IA(NDX+N-1). NDX
C * * IS INCREMENTED. 'Z' INDICATES ZERO FILL.
C
DIMENSION IA(1)
C DATA K4B40/ Z4B40 /
DATA K4B40/'.'/
C
RNUM = ABS(XREAL) + 0.00005
IDL = 0
IF(RNUM-10000.0)20,10,10
10 IDL = RNUM/10000.0
RNUM = RNUM-DFLOAT(IDL)*10000.0
20 IDR = RNUM
IDF = 10000.0 * ( RNUM-DFLOAT(IDR) )
NC = 2
IF(IDL)40,40,30
30 CALL CGNSY(IDL,IA,NDX,0)
NC = 4
40 CALL CGNSY(IDR,IA,NDX,NC)
IA(NDX)= K4B40
NDX = NDX + 1
CALL CGNSY(IDF,IA,NDX,4)
RETURN
END
SUBROUTINE CGFTR
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IBUF(6),JBUF(6)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(LFTA,LFGA)
C IS THIS A PERMANENT OR TEMPORARY FIGURE
KTF=DATA(ND)
IF(KTF-LFPRM*6)3000,3000,5000
C PERMANENT FIGURE, KTF POINTS TO END RATHER THAN
C BEGINNING
C INITIALIZE POINTER TO PUT FIRST RECORD IN
C TEMPORARY FIGURE AREA
3000 JPUT=LHDRS+LFTOT+1
C INITIALIZE, NO PREVIOUS POINT
NPR=0
C INITIALIZE, NEXT WORD IS FIRST OF THIS RECORD
J=1
C ADVANCE TO NEXT ENTRY (SCANNING FIGURE BACKWARDS
3100 KTF=KTF-1
C CHECK FOR END OF SCAN
IF(KTF)3200,3200,3104
C GET NEXT ENTRY
3104 N=KGFGT(KTF)
C CHECK FOR END OF FIGURE
IF(N-10000)3120,3110,3110
C END OF FIGURE, CHECK FOR END OF SCAN
3110 IF(NPR)3200,3100,3200
C INITIALIZE INDICATOR, NO CURVE
3120 K=0
C CHECK FOR CURVE INDICATOR
IF(N+10000)3122,3122,3130
C REVERSE CURVE DIRECTION
3122 K=-20004-N
C ADVANCE TO CC
KTF=KTF-1
N=KGFGT(KTF)
C REMOVE 'THROUGH' SIGN
3130 NS=IABS(N)
C APPLY 'THROUGH' SIGN FORM PREVIOUS POINT
IF(NPR)3134,3140,3140
3134 NS=-NS
C MAKE ENTRY IN BUFFER
3140 IBUF(J)=NS
J=J+1
C IF BUFFER IS FULL, WRITE THIS RECORD
IF(J-6)3150,3150,3142
3142 CALL CGDBF(KFTB,6,1,JPUT,IBUF)
JPUT=JPUT+1
J=1
C IF THIS WAS CC, PUT IN CURVE INDICATOR NEXT
3150 IF(K)3152,3160,3152
3152 NS=K
K=0
GO TO 3140
C SAVE POINT AS PREVIOUS AND GO GET NEXT ENTRY
3160 NPR=N
GO TO 3100
C SCAN COMPLETED - TAG FIGURE AS FIGURE ZERO
3200 DO 3209 I=J,6
3209 IBUF(I)=10000
CALL CGDBF(KFTB,6,1,JPUT,IBUF)
C SET DATA ITEM TO POINT TO FIRST RECORD OF THE
C TEMPORARY FIGURE JUST GENERATED
DATA(ND)=LFTOT*6+1
C SET TOTAL SPACE USED IN FIGURE AREA TO INCLUDE
C THIS 'TRANSPOSED' FIGURE
LFTOT=JPUT-LHDRS
GO TO 900
5000 JPUT=LHDRS+LFTOT
NPR=1
I=LFTOT*6
J=1
5100 IF(I-KTF)5200,5200,5110
5110 I=I-1
N=KGFGT(I)
IF(N-10000)5120,5100,5100
5120 K=0
IF(N+10000)5122,5122,5130
5122 K=-20004-N
I=I-1
N=KGFGT(I)
5130 NS=IABS(N)
IF(NPR)5134,5140,5140
5134 NS=-NS
5140 IBUF(J)=NS
J=J+1
IF(J-6)5150,5150,5142
5142 CALL CGDBF(KFTB,6,1,JPUT,IBUF)
JPUT=JPUT-1
J=1
5150 IF(K)5152,5160,5152
5152 NS=K
K=0
GO TO 5140
5160 NPR=N
GO TO 5100
5200 DO 5209 I=J,6
5209 IBUF(I)=10000
CALL CGDBF(KFTB,6,1,JPUT,IBUF)
I=LHDRS+(KTF+5)/6
J=LHDRS+LFTOT
5240 CALL CGDBF(KFTB,6,0,I,IBUF)
CALL CGDBF(KFTB,6,0,J,JBUF)
CALL CGDBF(KFTB,6,1,J,IBUF)
CALL CGDBF(KFTB,6,1,I,JBUF)
I=I+1
J=J-1
IF(J-I)5260,5260,5240
5260 N=KGFGT(0)
900 CALL CGDCA
RETURN
END
SUBROUTINE CGGAB(KTYPE,GAB,NUM)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C * * * DECODES ANGLES, AZIMUTHS AND BEARINGS FROM INPUT
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MLPAR/'('/
DATA MRPAR/')'/
DATA MG /'G'/
DATA MA /'A'/
DATA MPNT /'.'/
IGA=0
IFREE=0
NUM=0
ISGN=1
CALL CGSGN(ISGN)
CALL CGCOL(KN)
ACC=0.
KPAR=0
JSGN=1
IF(KN-MLPAR)320,240,320
240 KPAR=1
NKL=NKL+1
GO TO 310
300 JSGN=0
310 CALL CGSGN(JSGN)
CALL CGCOL(KN)
IF(JSGN)320,312,320
312 IF(KN-MRPAR)990,314,990
314 NKL=NKL+1
GO TO 700
320 NQUAD=0
IF(KN-MAXES(1))330,400,330
330 IF(KN-MAXES(3))410,404,410
400 NQUAD=-1
GO TO 406
404 NQUAD=-2
406 NKL=NKL+1
GO TO 510
410 IF(KN-MA)412,414,412
412 IF(KN-MG)500,414,500
414 MAG=KN
NKL=NKL+1
CALL CGNTG(I,J)
IF(J)990,990,420
420 CALL CGGET(I,XA,YA)
IF(XA-CLEAR)430,990,990
430 CALL CGNTG(I,J)
IF(J)990,990,450
450 CALL CGGET(I,XB,YB)
IF(XB-CLEAR)454,990,990
454 CALL CGINV(XA,YA,XB,YB,VALUE,DS)
IF(DS)990,990,460
460 JGA=1
JFREE=0
IF(MAG-MA)462,600,462
462 JGA=0
CALL CGNTG(I,J)
IF(J)990,990,470
470 CALL CGGET(I,XA,YA)
IF(XA-CLEAR)476,990,990
476 CALL CGINV(XA,YA,XB,YB,AZ,DS)
IF(DS)990,990,480
480 VALUE=AZ-VALUE
GO TO 600
500 IF(KPAR)504,504,510
504 IF(KTYPE-5)510,506,506
506 CALL CGNTG(NQUAD,J)
IF(J)990,990,507
507 IF(NQUAD)990,990,508
508 IF(NQUAD-4)510,510,990
510 FMIN=0.
SEC=0.
CALL CGCOL(KN)
KLM=NKL
CALL CGNUM(VALUE,J)
IF(J)990,990,511
511 IF(IN(KLM)-MPNT)512,530,512
512 KLM=KLM+1
IF(KLM-NKL)511,514,514
514 KSGN=0
CALL CGSGN(KSGN)
IF(KSGN)515,515,528
515 CALL CGCOL(KN)
KLM=NKL
CALL CGNUM(FMIN,J)
IF(J)990,526,521
521 IF(IN(KLM)-MPNT)522,530,522
522 KLM=KLM+1
IF(KLM-NKL)521,524,524
524 KSGN=0
CALL CGSGN(KSGN)
IF(KSGN)525,525,528
525 CALL CGNUM(SEC,J)
IF(J)990,526,530
526 IF(KSGN)528,530,528
528 NKL=NKL-1
530 JGA=0
JFREE=1
IF(NQUAD)532,541,540
532 NQUAD=-NQUAD
CALL CGCOL(KN)
IF(KN-MAXES(2))534,538,534
534 IF(KN-MAXES(4))990,536,990
536 NQUAD=5-NQUAD
538 NKL=NKL+1
540 JGA=1
JFREE=0
GO TO(541,542,543,544),NQUAD
543 VALUE=180.+VALUE
GO TO 541
542 VALUE=180.+VALUE
544 JSGN=-JSGN
JGA=-1
541 VALUE=((VALUE*60.+FMIN)*60.+SEC)*.484813681E-05*ISGG-JGA*AZEZ
GO TO 600
990 NUM=-1
GO TO 900
600 ACC=ACC+VALUE*JSGN
IGA=IGA+JGA*JSGN
IFREE=IFREE+JFREE
IF(KPAR)300,700,300
700 NAZER=IGA*ISGN-KTYPE/4
IF(IABS(NAZER)-IFREE)710,710,990
710 ACC=ACC*ISGN+NAZER*AZEZ
IF(ABS(ACC)-180.)720,720,990
720 GAB=CGNRM(ACC)
NUM=1
900 RETURN
END
SUBROUTINE CGGCL(LKAA,XAA,YAA,LKBA,XBA,YBA,KVA,XCA,YCA,
* LKAB,XAB,YAB,LKBB,XBB,YBB)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA HFPI/1.5707963267948966D0/
CALL CGINV(XAB,YAB,XBB,YBB,AZ,D)
CALL CGINV(XCA,YCA,XAA,YAA,AZCA,D)
CALL CGALZ(XCA,YCA,D,XAB,YAB,AZ,XIA,YIA,XIB,YIB)
CALL CGPOC(KVA,XAA,YAA,XBA,YBA,XIA,YIA)
CALL CGPOL(LKAB,XAB,YAB,LKBB,XBB,YBB,XIA,YIA)
CALL CGCLM(XIA,YIA)
CALL CGPOC(KVA,XAA,YAA,XBA,YBA,XIB,YIB)
CALL CGPOL(LKAB,XAB,YAB,LKBB,XBB,YBB,XIB,YIB)
CALL CGCLM(XIB,YIB)
IF(LKAA)22,22,30
22 CALL CGXTL(XAA,YAA,AZCA-HFPI*KVA,1000.D0,XIB,YIB)
CALL CGGPN(
*0,XIB,YIB,1,XAA,YAA,LKAB,XAB,YAB,LKBB,XBB,YBB)
30 IF(LKBA)32,32,900
32 CALL CGINV(XCA,YCA,XBA,YBA,AZ,D)
CALL CGXTL(XBA,YBA,AZ+HFPI*KVA,1000.D0,XIB,YIB)
CALL CGGPN(
*1,XBA,YBA,0,XIB,YIB,LKAB,XAB,YAB,LKBB,XBB,YBB)
900 RETURN
END
SUBROUTINE CGGET(NGET,XGET,YGET)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION LBUF(6)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(LBUF(2),XBUF),(LBUF(5),YBUF)
C ROUTINE TO GET COORDS (XGET AND YGET) OF A POINT
C (NGET) AND PRINT MESSAGE IF POINT IS UNDEFINED.
C CHECK THAT POINT IS IN DEFINED AREA OF TABLE
CALL CGCLR(XBUF,YBUF)
IF(NGET)90,90,20
20 IF(NGET-LCDA)40,40,90
C GET COORDINATES IN MEMORY
40 CALL CGDBF(KFTB,6,0,LHDRS+LFGA+NGET,LBUF)
C PRINT MESSAGE IF POINT IS UNDEFINED
IF(XBUF-CLEAR)800,90,90
C SEE IF WORKING ON 'STAKING NOTES' COMMAND
90 IF(IDITO.EQ.113) GO TO 800
WRITE(MOUT,91)NGET
91 FORMAT(' #####UNDEFINED POINT'I6)
NUMER=NUMER+1
800 XGET=XBUF
YGET=YBUF
RETURN
END
SUBROUTINE CGGFF
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION NPS(50),XS(50),YS(50)
DIMENSION JBFA(6,53)
DIMENSION IFBF(6,50)
DIMENSION IBUF(6)
DIMENSION IIFBF(200)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C* EQUIVALENCE(XS(50),IFBF(6,25)),(YS(50),IFBF(6,50))
EQUIVALENCE(LFTA,LFGA)
EQUIVALENCE(JBFA(1,1),IFBF(1,1))
EQUIVALENCE(XS(1),IIFBF(1)),(YS(1),IIFBF(101))
EQUIVALENCE(IBUF(2),XBUF),(IBUF(5),YBUF)
IF(IDITO-86)85050,86050,86050
85050 NSECT=DATA(12)
JHRF=DATA(11)
JCDA=DATA(10)
KFROM=DATA(9)
KTO =DATA(7)
XSHFT=DATA(5)
YSHFT=DATA(4)
85051 N=0
85052 CALL CGFIG(KFROM,NPFR,NSFR)
IF(NSFR)85054,85060,85054
85054 N=N+1
NPS(N)=NPFR
IF(N-50)85052,85060,85060
85060 I=0
85062 IF(I-N)85064,85070,85070
85064 I=I+1
NPN=NPS(I)
IF(NPN-JCDA)85066,85066,85069
85066 CALL CGDBF(NSECT,6,0,JHRF+NPN,IBUF)
IF(XBUF-CLEAR)85067,85069,85069
85067 XS(I)=XBUF+XSHFT
YS(I)=YBUF+YSHFT
GO TO 85062
85069 XS(I)=CLEAR
YS(I)=CLEAR
GO TO 85062
85070 I=0
85072 IF(I-N)85074,85080,85080
85074 I=I+1
CALL CGFIG(KTO,NPTO,NSTO)
CALL CGPUT(NPTO,XS(I),YS(I))
GO TO 85072
85080 IF(NSFR)85051,900,85051
86050 NSECT=DATA(12)
JHDRS=DATA(11)
JFGA =DATA(10)
KFROM=DATA(9)
NPFR =DATA(8)
KTO =DATA(7)
NPTO =DATA(6)
LFTOT=LFPRM
86052 CALL CGFIG(KFROM,NPFR,NSFR)
IF(NSFR)86054,86900,86054
86054 NR=0
86055 NRB=NR
86056 NR=NR+1
IF(NR-JFGA)86057,86057,86082
86057 CALL CGDBF(NSECT,6,0,JHDRS+NR,IBUF)
NS=IBUF(6)-10000
IF(NS)86056,86058,86058
86058 IF(NS-NPFR)86055,86060,86055
86060 N=NR-NRB
DO 10 NAG=1,199,4
IFBF(2,(NAG+3)/4)=IIFBF(NAG)
IFBF(3,(NAG+3)/4)=IIFBF(NAG+1)
IFBF(5,(NAG+3)/4)=IIFBF(NAG+2)
IFBF(6,(NAG+3)/4)=IIFBF(NAG+3)
10 CONTINUE
CALL CGIFA(JBFA,N-(LFGA-LFPRM))
DO 15 NAG=1,199,4
IIFBF(NAG)=IFBF(2,(NAG+3)/4)
IIFBF(NAG+1)=IFBF(3,(NAG+3)/4)
IIFBF(NAG+2)=IFBF(5,(NAG+3)/4)
IIFBF(NAG+3)=IFBF(6,(NAG+3)/4)
15 CONTINUE
IF(N-(LFGA-LFPRM))86062,86062,86900
86062 N=0
86064 IF(N-50)86065,86070,86070
86065 IF(NRB-NR)86066,86070,86070
86066 N=N+1
NRB=NRB+1
CALL CGDBF(NSECT,6,0,JHDRS+NRB,IBUF)
DO 86067 J=1,6
86067 IFBF(J,N)=IBUF(J)
IIFBF(2*N)=IBUF(6)
IIFBF(2*N-1)=IBUF(3)
GO TO 86064
86070 I=0
86072 IF(I-N)86074,86080,86080
86074 I=I+1
DO 86077 J=1,6
IBUF(J)=IFBF(J,I)
IF(IBUF(J)-10000)86077,86076,86076
86076 IBUF(J)=10000
86077 CONTINUE
LFTOT=LFTOT+1
CALL CGDBF(KFTB,6,1,LHDRS+LFTOT,IBUF)
GO TO 86072
86080 IF(NRB-NR)86062,86082,86082
86082 CALL CGFIG(KTO,NPTO,NSTO)
DATA(1)=NPTO
DATA(2)=LFPRM*6+1
DATA(12)=NSECT
DATA(11)=JHDRS
DATA(10)=JFGA
DATA(9)=KFROM
DATA(8)=NPFR
DATA(7)=KTO
DATA(6)=NPTO
CALL CGSLF
86900 CALL CGDEL
900 CALL RTNONE
RETURN
END
SUBROUTINE CGGPN(LKAA,XAA,YAA,LKBA,XBA,YBA,
* LKAB,XAB,YAB,LKBB,XBB,YBB)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CALL CGPIN(XAA,YAA,XBA,YBA,XAB,YAB,XBB,YBB,XIA,YIA)
CALL CGPOL(LKAA,XAA,YAA,LKBA,XBA,YBA,XIA,YIA)
CALL CGPOL(LKAB,XAB,YAB,LKBB,XBB,YBB,XIA,YIA)
CALL CGCLM(XIA,YIA)
900 RETURN
END
SUBROUTINE CGGSF(IDES,STST,XF,YF,NSEG,STA,OFF)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA CLEAR/1.D20/
DATA HFPI/1.5707963267948966D0/
DATA TWOPI/6.2831853071795864D0/
NSEGI=0
K=IDES
STAC=STST
CALL CGFIG(K,N,NIN)
CALL CGGET(N,XN,YN)
IF(XN-CLEAR)160,90,90
160 DMIN=CLEAR
KURV=0
CALL CGINV(XN,YN,XF,YF,AZF,DEF)
200 CALL CGFIG(K,N,NIN)
DBF=DEF
XJ=XN
YJ=YN
IF(NIN)220,800,220
220 NSEGI=NSEGI+1
230 CALL CGGET(N,XN,YN)
IF(XN-CLEAR)260,90,90
260 CALL CGINV(XJ,YJ,XN,YN,AZA,DS)
IF(NIN)400,300,300
300 KURV=0
G=AZA-AZF
STAL=DBF*COS(G)
OFFL=DBF*SIN(G)
CALL CGINV(XN,YN,XF,YF,AZF,DEF)
IF(STAL-DS)360,500,500
360 IF(STAL*(CLEAR-DMIN))510,520,520
400 KURV=-NIN-2
IF(DMIN-CLEAR)410,402,402
402 AZA=AZA-KURV*HFPI
DS=0.
XN=XJ
YN=YJ
GO TO 300
410 CALL CGFIG(K,N,NIN)
XJ=XN
YJ=YN
CALL CGGET(N,XN,YN)
CALL CGINV(XN,YN,XJ,YJ,AZT,R)
DELTA=CGNRM((AZT-AZA)*KURV)
DS=R*DELTA
CALL CGINV(XF,YF,XJ,YJ,AZFC,DFC)
IF(DFC)420,420,422
420 AZFC=AZA
422 G=CGNRM((AZFC-AZA)*KURV)
CALL CGINV(XN,YN,XF,YF,AZF,DEF)
STAL=R*G
OFFL=(DFC-R)*KURV
IF(STAL-DS)520,520,460
460 IF(DEF-DBF)500,500,470
470 STAL=R*(G-TWOPI)
GO TO 510
500 EXTL=STAL-DS
DMINL=DEF
GO TO 600
510 EXTL=-STAL
DMINL=DBF
GO TO 600
520 EXTL=0.
DMINL=ABS(OFFL)
600 IF(ABS(DMINL-DMIN).LT.9.0D-10)GO TO 610
IF(DMINL-DMIN)620,610,670
610 IF(EXTL-EXT)620,670,670
620 NSEG=NSEGI
STA=STAC+STAL
OFF=OFFL
DMIN=DMINL
EXT=EXTL
670 STAC=STAC+DS
IF(NIN)680,900,200
680 IF(KURV)200,230,200
800 IF(KURV)802,804,802
802 AZA=AZT-KURV*HFPI
804 DS=CLEAR
GO TO 300
90 NSEG=0
900 RETURN
END
SUBROUTINE CGGSN(KTF,NSG,NA,NB,KV,NC)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
K=KTF
I=0
6 I=I+1
NA=NB
KV=0
7 CALL CGFIG(K,NB,NS)
IF(NS)8,9,9
8 NC=NB
KV=-2-NS
GO TO 7
9 IF(I-NSG)6,6,900
900 RETURN
END
SUBROUTINE CGHDG(LINE,KFR,KTO)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION LINE(1)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MPLUS/'+'/
DATA MBL/' '/
M=MPLUS
K=75
20 M=M/2**29
IF(M)30,40,40
C* 30 M=M+255
30 M=M+"177
40 KHDNG(K)=M
M=MBL
L=KFR+75-K
IF(L-KTO)50,50,70
50 IF(K-4)70,70,60
60 M=LINE(L)
70 K=K-1
IF(K)900,900,20
900 RETURN
END
SUBROUTINE CGIFA(JBFA,INCR)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION JLS(6),IXLYL(6)
DIMENSION IIXLYL(4)
DIMENSION JBFA(6,53)
DIMENSION IBUF(6)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(JLS(1),JHDR),(JLS(2),JRSA),(JLS(3),JFGA),
* (JLS(4),JCDA),(JLS(5),JUNU),(JLS(6),JFILE)
EQUIVALENCE(IIXLYL(1),XL),(IIXLYL(3),YL)
INCDN=0
IF(LUNU-INCR)7092,7062,7062
7062 IF(INCDN-INCR)7063,900,900
7063 INSZ=53
IF(LUNU-INSZ)7064,70650,70650
C THESE INDENTED STATEMENTS MAY BE REMOVED IF THE STATEMENT
C NUMBER IN THE ABOVE 'IF' IS CHANGED FROM '70650' TO '7065'.
C THEN THE CONSTANT IN STATEMENT 7063 MAY BE CHANGED IF DESIRED.
70650 JPACK=53
NSH=(LHDRS+LFGA+LCDA-1)/53
NSL=(LHDRS+LFGA)/53
70653 IF(NSH-NSL)7066,70654,70654
70654 CALL CGDBF(KFTB+NSH,6,0,1,IBUF)
CALL CGDBF(KFTB+NSH+1,6,-1,1,IBUF)
CALL CGDBF(KFTB+NSH+1,6,1,1,IBUF)
NSH=NSH-1
GO TO 70653
7064 INSZ=LUNU
7065 JPACK=LCDA+INSZ
7066 DO 7067 J=1,INSZ
DO 7067 K=1,6
7067 JBFA(K,J)=0
DO 7069 LREC=1,JPACK
NREC=LHDRS+LFGA+LREC
NSS=LREC-LREC/INSZ*INSZ+1
CALL CGDBF(KFTB,6,0,NREC,IBUF)
CALL CGDBF(KFTB,6,1,NREC,JBFA(1,NSS))
DO 7068 K=1,6
7068 JBFA(K,NSS)=IBUF(K)
7069 CONTINUE
LFGA=LFGA+INSZ
LUNU=LUNU-INSZ
CALL CGDBF(KFTB,6,0,2,JLS)
JFGA=LFGA
JCDA=LCDA
JUNU=LUNU
CALL CGDBF(KFTB,6,1,2,JLS)
IXLYL(2)=IIXLYL(1)
IXLYL(3)=IIXLYL(2)
IXLYL(5)=IIXLYL(3)
IXLYL(6)=IIXLYL(4)
CALL CGDBF(KFTB,6,1,3,IXLYL)
INCDN=INCDN+INSZ
GO TO 7062
7092 WRITE (MOUT,7082)
7082 FORMAT(' #####TABLE FULL')
900 RETURN
END
SUBROUTINE CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * INVERSES BETWEEN TWO POINTS
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA HFPI/1.5707963267948966D0/
DATA PI/3.1415926535897932D0/
DATA TWOPI/6.2831853071795864D0/
DX=XTEM2-XTEM1
DY=YTEM2-YTEM1
ANGLE=ATAN(DY/DX)
AD=PI
IF(DX)430,410,415
410 ANGLE=HFPI
GO TO 420
415 AD=TWOPI
420 IF(DY)430,435,435
430 ANGLE=ANGLE+AD
435 DIST=SQRT(DX*DX+DY*DY)
RETURN
END
SUBROUTINE CGJAR
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IBUF(6)
DIMENSION XA(2),YA(2),NXYC(2),NXYD(2),AZAB(2),AZCD(2),RAB(2)
* ,GINT(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(LFTA,LFGA)
EQUIVALENCE(IBUF(2),XBUF),(IBUF(5),YBUF)
EQUIVALENCE(XA(1),XA1),(XA(2),XA2),(YA(1),YA1),(YA(2),YA2)
*,(NXYC(1),NXYC1),(NXYC(2),NXYC2),(NXYD(1),NXYD1),(NXYD(2),NXYD2)
*,(AZAB(1),AZAB1),(AZAB(2),AZAB2),(AZCD(1),AZCD1),(AZCD(2),AZCD2)
*,(RAB(1),RAB1),(RAB(2),RAB2),(GINT(1),GINT1),(GINT(2),GINT2)
C
DATA MXTRY/20/
C
NPB=DATA(3)
NPE=DATA(4)
IF(DATA(6))42300,42006,42300
42006 IF(DATA(5))42100,42200,42100
42100 CALL CGGET(IFIX(SNGL(DATA(5))),XCC,YCC)
IF(XCC-CLEAR)42110,900,900
42110 UR=.001
UX=0.
UY=0.
GO TO 42020
42200 CALL CGGET(NPB,XTEM1,YTEM1)
CALL CGGET(NPE,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
ANGLE=ANGLE-HFPI
GO TO 42308
94 WRITE(MOUT,95)
95 FORMAT(' #####','UNDEFINED DIRECTION')
GO TO 900
42300 CALL CGGET(IFIX(SNGL(DATA(5))),XTEM1,YTEM1)
IF(XTEM1-CLEAR)42304,900,900
42304 CALL CGGET(IFIX(SNGL(DATA(6))),XTEM2,YTEM2)
IF(XTEM2-CLEAR)42306,900,900
42306 CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
42308 IF(DIST1)94,94,42310
42310 UX=COS(ANGLE)
UY=SIN(ANGLE)
UR=0.
42020 KTF=DATA(1)
KTFS=KTF
IBEG=0
NS=0
42026 NPREV=NPF
NSPRV=NS
CALL CGFIG(KTF,NPF,NS)
IF(NS)42030,96,42030
96 WRITE(MOUT,97)NPB,NPE
97 FORMAT(' #####','POINT',I6,' OR',I6,' OUT OF SEQUENCE')
GO TO 900
42030 IF(IBEG)42032,42032,42040
42032 IF(NPF-NPB)42026,42034,42026
42034 IBEG=KTF
CALL CGGET(NPREV,XA1,YA1)
NXYD1=NPF
CALL CGGET(NPF,XTEM2,YTEM2)
CALL CGINV(XA1,YA1,XTEM2,YTEM2,AZAB1,RAB1)
IF(NSPRV)42038,96,42036
42036 RAB1=0.
42038 NPREV=NPF
NSPRV=NS
CALL CGFIG(KTF,NPF,NS)
NXYC1=NPF
CALL CGGET(NPF,XTEM1,YTEM1)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,AZCD1,DIST1)
GINT1=ABS(ABS(AZAB1-AZCD1)-PI)-HFPI
42040 IF(NPF-NPE)42026,42042,42026
42042 NXYC2=NPREV
CALL CGGET(NPREV,XTEM1,YTEM1)
NXYD2=NPF
CALL CGGET(NPF,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,AZCD2,DIST1)
CALL CGFIG(KTF,NPF,NS)
CALL CGGET(NPF,XA2,YA2)
CALL CGINV(XA2,YA2,XTEM2,YTEM2,AZAB2,RAB2)
IF(NS)42048,96,42046
42046 RAB2=0.
42048 GINT2=ABS(ABS(AZAB2-AZCD2)-PI)-HFPI
ISGAR=0
GO TO 42800
42602 IF(LIST)42606,42604,42604
42604 AP=A+.0005
WRITE(MOUT,42605)AP
42605 FORMAT(5X,'ORIGINAL AREA=',F13.3,' SQ.FT.')
42606 DESAR=DATA(2)
TOL=DESAR/1.E8
ADJF=1.
APR=A+A-DESAR
NTRY=0
42610 CHNG=A-APR
DSCH=DESAR-A
IF(ABS(DSCH)-TOL)42900,42900,42616
42616 IF(NTRY-MXTRY)42618,42990,42990
42618 ADJF=ADJF*DSCH/CHNG
APR=A
NTRY=NTRY+1
IER=0
NIN=0
42051 MNIN=10000
IF(ND-8)42059,42052,42052
42052 KTF=DATA(8)
42053 CALL CGFIG(KTF,NPF,NS)
IF(NS)42054,42059,42054
42054 IF(NPF-NIN)42053,42053,42055
42055 IF(NPF-MNIN)42056,42053,42053
42056 MNIN=NPF
GO TO 42053
42059 KTF=IBEG
NPF=NPB
42060 IF(NPF-NIN)42063,42063,42061
42061 IF(NPF-MNIN)42062,42063,42063
42062 MNIN=NPF
42063 IF(NPF-NPE)42064,42069,42064
42064 CALL CGFIG(KTF,NPF,NS)
GO TO 42060
42069 NIN=MNIN
IF(NIN-10000)42620,42700,42700
42620 CALL CGGET(NIN,XTEM1,YTEM1)
IF(UR)42120,42220,42120
42120 SINR=SIN(UR*ADJF)
COSR=COS(UR*ADJF)
XLL=XTEM1-XCC
YLL=YTEM1-YCC
XBUF=XLL*COSR-YLL*SINR+XCC
YBUF=YLL*COSR+XLL*SINR+YCC
42129 CALL CGDBF(KFTB,6,1,LHDRS+LFGA+NIN,IBUF)
GO TO 42051
42220 XBUF=XTEM1+UX*ADJF
YBUF=YTEM1+UY*ADJF
GO TO 42129
42700 DO 42749 I=1,2
AZCD(I)=AZCD(I)+UR*ADJF
CALL CGGET(NXYC(I),XC,YC)
IF(RAB(I))42710,42710,42730
42710 AZ=AZAB(I)
42712 CALL CGZIN(XA(I),YA(I),AZ,XC,YC,AZCD(I),XBUF,YBUF)
GO TO 42740
42730 CALL CGALZ(
*XA(I),YA(I),RAB(I),XC,YC,AZCD(I),XBUF,YBUF,XTEM2,YTEM2)
IF(XBUF-CLEAR)42734,42733,42733
42733 IER=NXYD(I)
AZ=AZCD(I)-HFPI
GO TO 42712
42734 IF(GINT(I))42740,42738,42738
42738 XBUF=XTEM2
YBUF=YTEM2
42740 CALL CGDBF(KFTB,6,1,LHDRS+LFGA+NXYD(I),IBUF)
CALL CGINV(XC,YC,XBUF,YBUF,ANGLE,DIST1)
IF(ABS(ABS(ANGLE-AZCD(I))-PI)-HFPI)42790,42744,42744
42744 CALL CGINV(XA(I),YA(I),XBUF,YBUF,ANGLE,DIST1)
IF(ABS(ABS(ANGLE-AZAB(I))-PI)-HFPI)42790,42749,42749
42790 IER=NXYD(I)
42749 CONTINUE
42800 KTF=KTFS
CALL CGFIG(KTF,NPF,NS)
IPTA=NPF
CALL CGGET(IPTA,XTEM2,YTEM2)
YLOC=XTEM2
A=0.
42820 KURV=NS
N=NPF
CALL CGFIG(KTF,NPF,NS)
IF(NS)42830,42880,42830
42830 XTEM1=XTEM2
YTEM1=YTEM2
CALL CGGET(NPF,XTEM2,YTEM2)
IF(XTEM2-CLEAR)42838,900,900
42838 AZA=AZB
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,AZB,DIST1)
IF(KURV)42840,42840,42850
42840 KURV=-KURV-2
ANGLE=(AZB-AZA)*KURV-PI
A=A-CGNRM(ANGLE)*DIST1*DIST1/2.*KURV
42850 A=A+(XTEM2-XTEM1)*((YTEM2+YTEM1)/2.-YLOC)
GO TO 42820
42880 IF(N-IPTA)42892,42882,42892
42892 WRITE(MOUT,42893)
42893 FORMAT(' #####','FIRST POINT DIFFERENT FROM LAST')
GO TO 900
42882 IF(ISGAR)42888,42883,42888
42883 ISGAR=1
IF(A)42884,42885,42885
42884 ISGAR=-1
42885 A=A*ISGAR
GO TO 42602
42888 A=A*ISGAR
GO TO 42610
42990 WRITE(MOUT,42991)MXTRY
42991 FORMAT(' #####','AREA NOT FOUND AFTER',I3,' TRIES')
42900 IF(IER)42904,42910,42904
42904 WRITE(MOUT,42905)IER
42905 FORMAT(' #####','SIDE AT',I5,' HAS CHANGED DIRECTION')
42910 IF(LIST)900,42912,42912
42912 AP=A+.0005
WRITE(MOUT,42913)AP
42913 FORMAT(8X,'FINAL AREA=',F13.3,' SQ.FT.',/)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGLAN
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C * * GET INPUT DATA FROM 'PLOT ANNOTATION' CARD
C
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C * * COMMON STATEMENTS BELOW ADDED AUGUST 1973 - LGB
C * * (VARIABLES OCCUPY SPACE IN COMMON ARRAY 'KMMON' DEFINED IN THE
C * * 'COGO' MAINLINE.)
COMMON ANSIZ,JBRAZ
C * (ANNOT. HGT. IN INCHES,BEAR/AZM CODE)
JBRAZ = DATA(1)
IF(ND-2)5,5,4
4 ANSIZ = DATA(3)
5 IF(JBRAZ)900,35,10
10 IF(JBRAZ-3)20,20,900
20 IF(ANSIZ-0.028)900,30,30
30 IF(ANSIZ-2.10)40,40,900
C
C
900 WRITE(MOUT,901)JBRAZ,ANSIZ
901 FORMAT(' #####','BAD ANNOT. DATA',I7,F10.3)
35 JBRAZ = 0
ANSIZ = 0.07
40 CALL RTNONE
RETURN
END
SUBROUTINE CGLIN
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
IF(NCRVS)5790,5710,5710
5710 CONTINUE
C
C INPUT DATA AND INITIALIZATION.
C
LS = DATA(1)
IJ = DATA(2)
IK = DATA(3)
IREL = DATA(4)
ERROR = .00005
IPTSW = 0
ISW = 0
C
C PRELIMINARY CHECK FOR INTERSECTION.
C
CALL CGGET(IJ,XIJ,YIJ)
CALL CGGET(IK,XIK,YIK)
CALL CGGET(NSC,XSC,YSC)
CALL CGGET(NTS,XTS,YTS)
XTEM1=XSC
YTEM1=YSC
DO 5 K=1,2
CALL CGFST(XIJ,YIJ,XIK,YIK,XTEM1,YTEM1,XI,YI)
CALL CGINV(XI,YI,XTEM1,YTEM1,ANGLE,DIST1)
IF(DIST1-XLS)4,4,3
C
C NO INTERSECTION OF LINE AND SPIRAL.
C
3 WRITE(MOUT,1000)
1000 FORMAT(' #####','NO INTERSECTION')
CALL CGPUT(LS,CLEAR,CLEAR)
CALL CGPCD(LS)
GO TO 900
C
C
C REPEAT CHECK FOR NTS.
C
4 XTEM1=XTS
YTEM1=YTS
5 CONTINUE
C
C FIND COORDS OF POINT ON SPIRAL (LS).
C
ARC = DIST1
7 THETA = ((ARC/XLS)**2) * THR*SGNSP
C
Y1 = (THETA*THETA)/42.0
THET4 = THETA**4
Y2 = THET4/1320.
X1 = THETA*THETA/216.
X2 = THET4/9360.
C
XTEM2 = ARC* (1. - THETA*THETA*(1./10. - X1 + X2))
YTEM2 = ARC * THETA * (1./3. -Y1 + Y2)
C
CALL CGINV(0.D0,0.D0,XTEM2,YTEM2,ANGLE,DIST1)
C
ROT = ANGLE + AZLT
C
CALL CGXTL(XTS,YTS,ROT,DIST1,XINT,YINT)
CALL CGFST(XIJ,YIJ,XIK,YIK,XINT,YINT,XI,YI)
CALL CGINV(XI,YI,XINT,YINT,ANGLE,DIST1)
IF(DIST1 - ERROR) 12,12,14
12 IF(ISW) 13,13,20
C
13 IPTSW = 1
ATOP1 = ARC
XA=XINT
YA=YINT
ARC = ARC + ERROR
GO TO 18
14 IF(IPTSW) 16,16,15
15 ISW = 1
16 ARC = ARC + DIST1
C
18 IF(ARC-XLS) 7,7,19
19 IF(IPTSW) 3,3,22
C
C TWO INTERSECTION POINTS
C FIND DISTANCE TO POINT NEAREST NSC (SECOND POINT CALCULATED).
C
20 CALL CGGET(IREL,XREL,YREL)
CALL CGINV(XREL,YREL,XINT,YINT,ANGLE,D)
C
C FIND DISTANCE TO POINT NEAREST NTS.
C
CALL CGINV(XREL,YREL,XA,YA,ANGLE,DIST1)
C
C FIND SHORTEST DISTANCE
C
IF(DIST1-D) 22,22,21
21 ATOP1 = ARC
XA=XINT
YA=YINT
22 CALL CGPUT(LS,XA,YA)
C
C OUTPUT PHASE
C
IF(LIST)900,34,34
34 CALL CGPCD(LS)
DIST1=ATOP1+.00005
WRITE(MOUT,1001) NTS,LS,DIST1
1001 FORMAT(3X,12HARC FROM PT.,I4,7H TO PT.,I4,1H=,F14.4/)
GO TO 900
5790 WRITE(MOUT,5791)
5791 FORMAT(' #####','NO SPIRAL DEFINED')
900 CALL RTNONE
RETURN
END
SUBROUTINE CGLOC
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C SUBROUTINE TO LOCATE A POINT N.
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C CALLED BY...LOCATE/AZIMUTH LOCATE/DEFLECTION
C LOCATE/ANGLE
C LOCATE/BEARING LOCATE/LINE
C LOCATE/ANGLE REDEFINE
C
C PARALLEL/LINE DIVIDE/LINE
C EXTEND/ARC DIVIDE/ARC
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
IF(IDITO-41)2,4100,6700
2 IF(IDITO-18)11,1800,4000
C INITIALIZE FOR REDEFINE OR LOCATE/...
11 J = DATA(1)
N = DATA(2)
C 1 2 3 4 5 6 7 8
GO TO(50,900,900,900,500,600,900,900,
* 90,900,1100,1200,1300,1400,1500),IDITO
C 9 10 11 12 13 14 15
C OLD/FORMAT
C SET FORMAT SWITCH
50 LDFMT=1
GO TO 900
C STORE
500 CONTINUE
C
C KNOWN
600 CONTINUE
NS = DATA(1)
C STORE THE COORDINATES OF THE DESIRED POINT
IXYL=3-IXYF
CALL CGPUT(NS,DATA(IXYF+1),DATA(IXYL+1))
IF(LIST)900,120,120
C IF PRECISION IS POOR, PRINT COORDS
120 IF(DATA(2)+10./200000.-DATA(2))121,160,121
121 IF(DATA(3)+10./200000.-DATA(3))122,160,122
C IF PRECISION IS GOOD, PRINT ONLY POINT NUMBER
122 WRITE(MOUT,123)NS
123 FORMAT(I8)
GO TO 900
C PRINT COORDS
160 CALL CGPCD(NS)
GO TO 900
C
C REDEFINE COMMAND SET COORDS. OF N EQUAL TO COORDS OF J
C DECOD INSURES THAT ONLY DATA(1) AND DATA (2) ARE
C NON ZERO SO LOCATE/AZIMUTH CODING CAN BE USED
C
90 CONTINUE
C
C LOCATE/AZIMUTH
C
1100 CONTINUE
C
C LOCATE/BEARING
C
1200 IF(LDFMT)1210,1220,1210
C CODING FOR 9, 11, 12 IN OLD FORMAT
1210 TEMP = DATA(3)
DATA(3)=DATA(4)
DATA(4)=TEMP
C CODING FOR 9, 11, 12 IN NEW FORMAT
1220 ANGLE=DATA(3)
C GET VERICAL ANGLE
1101 A=ABS(DATA(6))
C MAKE VERTICAL ANGLE BETWEEN -45 AND +45 DEGREES
1102 IF(A-HFPI/2.)1104,1103,1103
1103 A=A-HFPI
GO TO 1102
C APPLY VERTICAL ANGLE TO SLOPE DISTANCE
1104 DIST1=DATA(4)*COS(A)
C FIND COORDINATES OF UNKNOWN
1105 CALL CGGET(J,XTEM1,YTEM1)
IF(XTEM1-CLEAR)1106,1590,1590
1106 CALL CGXTL(XTEM1,YTEM1,ANGLE,DIST1,XP,YP)
CALL CGPUT(N,XP,YP)
IF(DIST1)1150,1140,1150
1140 IF(IDITO-9)1142,1150,1142
1142 WRITE(MOUT,1143)
1143 FORMAT(' #####','DISTANCE IS ZERO')
C PRINT OUTPUT
1150 CALL CGPCD(N)
GO TO 900
C
C LOCATE/ANGLE
C
1300 E = -1.
GO TO 1405
C LOCATE/DEFLECTION
1400 E =1.
C FIND AZMUTH FROM BACKSIGHT TO SETUP
1405 CALL CGGET(J,XTEM1,YTEM1)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
C J=POINT NUMBER OF SETUP
J=N
C N=POINT NUMBER OF FORESIGHT
N = DATA(3)
IF(LDFMT)1310,1320,1310
C CODING FOR 13 14 IN OLD FORMAT
1310 TEMP=DATA(4)
DATA(4)=DATA(5)
DATA(5)=TEMP
C CODING FOR 13 14 IN NEW FORMAT
C COMPUTE AZMUTH TO FORSIGHT
1320 ANGLE=ANGLE+DATA(4)
C REVERSE DISTANCE IF COMMAND IS 13
C MOVE DISTANCE AND VERTICAL ANGLE INTO POSITION
C FOR USE BY LOCATE/AZMUTH CODING
DATA(4)=DATA(5)*E
DATA(6)=DATA(7)
C GO CHECK FOR NO BACKSIGHT CONDITION
GO TO 1501
C
C LOCATE/LINE
C FIND AZMUTH FROM KNOWN POL TO SETUP
C J=POINT NUMBER KNOWN POL
1500 J=N
C N=POINT NUMBER OF SETUP
N=DATA(1)
CALL CGGET(J,XTEM1,YTEM1)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
C REVERSE DISTANCE
DATA(4)=-DATA(4)
C J=POINT NUMBER OF SETUP
J=N
C N=POINT NUMBER OF UNKNOWN
N = DATA(3)
C CHECK FOR UNDEFINED DIRECTION
1501 IF(XTEM1-CLEAR)1502,1590,1590
1502 IF(DIST1)1580,1580,1101
1580 WRITE(MOUT,1581)
1581 FORMAT(' #####','UNDEFINED DIRECTION')
C ERROR ROUTINE(MESSAGE PRINTED ABOVE OR BY CGGET)
1590 CALL CGPUT(N,CLEAR,CLEAR)
GO TO 1150
C
C PARALLEL/LINE
C
1800 J = DATA(1)
N = DATA(2)
JOF=DATA(4)
NOF=DATA(5)
C FIND AZIMUTH OF J-N.
CALL CGGET(J,XTEM1,YTEM1)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
IF(DIST1)1890,1890,1820
1820 ANGLE=ANGLE-HFPI
DIST1 = DATA(3)
CALL CGXTL(XTEM1,YTEM1,ANGLE,DIST1,XP,YP)
CALL CGPUT(JOF,XP,YP)
CALL CGPCD(JOF)
CALL CGXTL(XTEM2,YTEM2,ANGLE,DIST1,XP,YP)
CALL CGPUT(NOF,XP,YP)
CALL CGPCD(NOF)
GO TO 900
1890 WRITE(MOUT,1891)
1891 FORMAT(' #####','NO LINE')
CALL CGPUT(JOF,CLEAR,CLEAR)
CALL CGPCD(JOF)
CALL CGPUT(NOF,CLEAR,CLEAR)
CALL CGPCD(NOF)
GO TO 900
C
C DIVIDE/LINE
C
4000 CONTINUE
C GET COORDS OF SECOND POINT
CALL CGGET(IFIX(SNGL(DATA(2))),XB,YB)
IF(XB-CLEAR)4010,900,900
C GET X AND Y DISTANCE FORM FIRST TO SECOND POINT
4010 CALL CGGET(IFIX(SNGL(DATA(1))),XTEM2,YTEM2)
IF(XTEM2-CLEAR)4020,900,900
4020 DX=XB-XTEM2
DY=YB-YTEM2
C GET NUMBER OF PARTS (M IS COUNTER)
M=DATA(3)
C A REMAINS AS NUMBER OF PARTS (A=IFIX(SNGL(DATA(3))))
A=M
IF(M)4092,4092,4025
C GET STARTING POINT NUMBER
4025 NS=DATA(5)
C WAS IT GIVEN
IF(ND-4)4027,4027,4028
C NO - USE 1 GREATER THAN FIRST POINT
4027 NS=IFIX(SNGL(DATA(1)))+1
C COMPUTE NUMBER OF HIGHEST POINT TO BE DEFINED
4028 L=NS+M-2
C CHECK POINT RANGE
IF(L-(LCDA+LUNU))4029,4029,4094
C NOTE - LOOP ENTRANCE IS STATEMENT 4050
4029 IF(NS)4094,4094,4050
C DEFINE NEXT POINT ON LINE
4040 CALL CGPUT(NS,XB-M/A*DX,YB-M/A*DY)
C PRINT THE COORDINATES
N=NS
CALL CGPCD(N)
C ADVANCE POINT NUMBER
NS=NS+1
C ADVANCE TO NEXT POSITION ON LINE
4050 M=M-1
C RETURN IF ALL POINTS HAVE BEEN DEFINED
IF(M)900,900,4040
4092 WRITE(MOUT,4093)M
4093 FORMAT(' #####','INVALID NUMBER OF PARTS',I6)
GO TO 900
4094 WRITE(MOUT,4095)NS,L
4095 FORMAT(' #####','INVALID POINT RANGE',I6,' TO',I6)
GO TO 900
C
C DIVIDE/ARC
C
4100 CONTINUE
C SAVE COORDINATES OF CC
CALL CGGET(IFIX(SNGL(DATA(3))),XTEM1,YTEM1)
C GET AZIMUTH AND LENGTH OF SECOND SIDE
CALL CGGET(IFIX(SNGL(DATA(2))),XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
C CHECK FOR UNDEFINED POINTS(CGGET PRINTS MESSAGE)
IF(XTEM1-CLEAR)4104,900,900
4104 IF(XTEM2-CLEAR)4106,900,900
C MAKE SURE SECOND SIDE HAS LENGTH
4106 IF(DIST1)4190,4190,4108
C SAVE AZIMUTH OF SECOND SIDE
4108 AZ=ANGLE
C GET AZIMUTH AND LENGTH OF FIRST SIDE
CALL CGGET(IFIX(SNGL(DATA(1))),XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
C CHECK FOR UNDEFINED POINT (CGGET PRINTS MESSAGE)
IF(XTEM2-CLEAR)4114,900,900
C CHECK FOR LENGTH OF FIRST SIDE
4114 IF(DIST1)4190,4190,4116
C GET ANGLE, MAKE IT POSITIVE
4116 DA=CGNRM((AZ-ANGLE)*ISGG)*ISGG
C GET NUMBER OF PARTS (M IS COUNTER)
4122 M=DATA(4)
C A REMAINS AS WHOLE NUMBER OF PARTS
A=M
IF(M)4092,4092,4125
C GET STARTING POINT NUMBER
4125 NS=DATA(6)
C WAS IT GIVEN
IF(ND-5)4127,4127,4128
C NO - USE 1 GREATER THAN FIRST POINT
4127 NS=IFIX(SNGL(DATA(1)))+1
C VARIABLE 'NS' WAS USED FOR DIVIDE/LINE ERR MESS
4128 N=NS
C COMPUTE NUMBER OF HIGHEST POINT TO BE DEFINED
L=NS+M-2
C CHECK POINT RANGE
IF(L-(LCDA+LUNU))4129,4129,4094
C NOTE LOOP ENTRANCE IS STATEMENT 4150
4129 IF(NS)4094,4094,4150
C COMPUTE AZIMUTH FROM CC TO NEXT POC
4140 ANGLE=AZ-M/A*DA
C LOCATE NEXT POC
CALL CGXTL(XTEM1,YTEM1,ANGLE,DIST1,XP,YP)
CALL CGPUT(N,XP,YP)
C PRINT THE COORDINATES
CALL CGPCD(N)
C ADVANCE POINT NUMBER
N=N+1
C ADVANCE TO NEXT POINT ON CURVE
4150 M=M-1
C RETURN IF FINISHED
IF(M)900,900,4140
4190 WRITE(MOUT,4091)
4091 FORMAT(' #####','NO ANGLE')
GO TO 900
C EXTEND/ARC
C TEM2 = COORDS OF PC
6700 CALL CGGET(IFIX(SNGL(DATA(1))),XTEM2,YTEM2)
C J = POINT NUMBER OF CC
J=DATA(2)
C N = NUMBER OF DESIRED POINT
N=DATA(3)
IF(XTEM2-CLEAR)6702,1590,1590
6702 CALL CGGET(J,XTEM1,YTEM1)
C COMPUTE AZIMUTH AND DISTANCE FROM CC TO PC
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
C COMPUTE AZIMUTH FROM CC TO DESIRED POINT
ANGLE=ANGLE+DATA(4)/DIST1*ISGG
C COMPLETE USING LOCATE/AZIMUTH CODING
GO TO 1105
C
900 CALL RTNONE
RETURN
END
SUBROUTINE CGLST
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DIMENSION KDATE(3)
DATA MAST /'*'/
DATA MBL /' '/
DATA M1 /'1'/
C* NEXT STORAGE ADDED FOR DATE/TIME JUL-74 RLF
IF(LIST)900,1106,900
C CHOOSE DEVICE FOR ECHO PRINT
1106 MECHO=MOUT
IF(INDEV-IVT)1109,1107,1109
1107 MECHO=MTP
IF(MECHO-MTT)1109,900,1109
1109 KARIJ=MBL
C CHECK FOR COMMENT
IF(IN(1)-MAST)107,102,107
C CHECK FOR PAGE SKIP CODE
102 IF(IN(2)-MAST)107,105,107
105 KARIJ=M1
107 WRITE(MECHO,1004)KARIJ,(IN(I),I=1,LK)
1004 FORMAT(81A1)
IF (KARIJ.NE.M1) GO TO 900
CALL DATE (KDATE)
CALL TIME (KDATE(3))
NPG=NPG+1
WRITE (MECHO,1005) KDATE,NPG
1005 FORMAT (20X,'EXECUTION ON ',2A5,' AT ',A5,' PAGE',I4)
900 RETURN
END
SUBROUTINE CGMER
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IBUF(6)
DIMENSION KTFS(2),LINK(2),LNGTH(2),XCL(2),YCL(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(KTFS(1),KTFSA),(KTFS(2),KTFSB),
* (XCL(1),XLA),(XCL(2),XLB),(YCL(1),YLA),(YCL(2),YLB)
EQUIVALENCE(IBUF(2),XBUF),(IBUF(5),YBUF)
EQUIVALENCE(LFTA,LFGA)
C CONVERT/MERIDIAN
7100 DO 7119 I=1,2
C * * * GET POINTER TO START OF FIGURE
KTFS(I)=DATA(I)
C * * * GET POINT NUMBER OF COMMON POINT
N = DATA(I+2)
C * * * GET COORDS
CALL CGGET(N,XCL(I),YCL(I))
C * * * DO THE COORDS EXIST? (YES,NO,NO) (NO- ERROR)
IF(XCL(I)-CLEAR) 7108,900,900
7108 J=0
C * * * GET RECORD NO OF START OF FIGURE
KTF=KTFS(I)
C * * * SAVE RELATIVE LOCATION OF COMMON POINT
7110 LINK(I)=J
C * * * GET 1 WORD OF FIGURE
7112 CALL CGFIG(KTF,NPF,NS)
C * * * IS IT THE END OF THE FIGURE? (NO,YES,NO)
IF(NS) 7114,7119,7114
7114 J=J+1
C * * * IS THIS THE POINT OF COMMONNESS? (NO,YES,NO)
IF(NPF- N ) 7112,7116,7112
C * * * HAD WE FOUND THE COMMON POINT BEFORE? (YES,NO,YES)
7116 IF(LINK(I)) 7112,7110,7112
C * * * RECORD NUMBER OF POINTS IN FIGURE SO FAR
7119 LNGTH(I)=J
C
C * * * IS THE SECOND FIGURE SMALLER THAN THE FIRST? (NO,NO,ERROR)
IF(LNGTH(1)-LNGTH(2)) 7121,7121,7193
7121 NPSSB=0
C * * * WAS THE COMMON POINT SPECIFIED FOR 1ST FIGURE? (NO,NO,YES)
IF(LINK(1))7130,7130,7124
C * * * WAS THE COMMON POINT SPECIFIED FOR 2ND FIGURE? (NO,NO,YES)
7124 IF(LINK(2))7130,7130,7125
C
C * * * THE FOLLOWING CODE LINES UP THE COMMON POINTS TO START
C * * * THE CONVERSION
C * * * FIND DIFFERNCE BETWEEN LOCATIONS OF COMMON POINTS
7125 NPSSB= LINK(2)-LINK(1)
C * * * IS THIS THE FIRST PASS OR THE SECOND
IF (NPSSB) 7126,7130,7130
7126 NPSSB = NPSSB+LNGTH(2)
7130 KTFB=KTFSB
I=0
7131 IF (I-NPSSB) 7132,7133,7133
7132 CALL CGFIG(KTFB,NPFB,NS)
I=I+1
GO TO 7131
C * * * END OF LINING UP PROCESS
7133 SCL=1.
C * * * WAS THE SCALE SPECIFIED? (NO,NO,YES)
IF(ND-5)7135,7135,7134
C * * * GET SCALE
7134 SCL=DATA(7)
C * * * GET ANGLE OF ROTATION
7135 ANGLE=DATA(5)
SINR=SIN(ANGLE)
COSR=COS(ANGLE)
C * * * GET POINTER TO START OF FIGURE
KTFA=KTFSA
IF(LIST)7140,7136,7136
C
C * * * CALC CONVERSION FACTOR, SHIFT
7136 CALL CGINV(XLA,YLA,XLB,YLB,AZ,DIST)
CALL CGDMS(CGNRM((AZ+AZEZ)*ISGG),IDEG,MIN,SEC)
DIST=DIST+.00005
CALL CGDMS(CGNRM(ANGLE*ISGG),IDEGG,MING,SECG)
WRITE(MOUT,7137)IDEG,MIN,SEC,DIST,IDEGG,MING,SECG,SCL
7137 FORMAT(37X,'SHIFT =',I4,'-',I2,'-',F4.1,F16.4/
* 26X,'CONVERSION ANGLE =',I4,'-',I2,'-',F4.1/
* 30X'SCALE FACTOR ='E16.9/)
C * * * GET ONE WORD OF SECOND FIGURE
7140 CALL CGFIG(KTFB,NPFB,NS)
C * * * HAVE WE REACHED THE END OF THE FIGURE? (NO,YES,NO)
IF(NS) 7144,7142,7144
C * * * START THE FIGURE OVER
7142 KTFB=KTFSB
GO TO 7140
C * * * GET ONE WORD OF FIRST FIGURE
7144 CALL CGFIG(KTFA,NPFA,NS)
C * * * IS THIS THE END OF THE FIGURE? (NO,YES,NO)
IF(NS) 7146,900,7146
C * * * START THE FIGURE OVER
7146 KTF=KTFSA
C * * * GET NEXT WORD OF FIGURE 1
7148 CALL CGFIG(KTF,NPF,NS)
C * * * IS THIS THE SAME AS THE LAST W\ONE WE HAD? (NO,YES,NO)
IF(NPF-NPFA) 7148,7149,7148
C * * * IS THIS THE START OF THE FIGURE? (NO,YES,NO)
7149 IF(KTF-KTFA) 7140,7150,7140
C * * * IS THIS A VALID POINT NUMBER? (YES,YES,NO)
7150 IF(NPFA-LCDA)7152,7152,7151
C * * * INVALID POINT - CLEAR COORDS
7151 XBUF=CLEAR
YBUF=CLEAR
GO TO 7155
C * * * GET COORDS OF POINT FROM FIGURE 1
7152 CALL CGDBF(KFTB,6,0,LHDRS+LFGA+NPFA,IBUF)
C * * * IS THIS A VALID POINT? (YES,NO,NO)
IF(XBUF-CLEAR)7153,7155,7155
C
C * * * PERFORM CONVERSION
7153 XLL=(XBUF-XLA)*SCL
YLL=(YBUF-YLA)*SCL
XBUF=XLL*COSR-YLL*SINR+XLB
YBUF=YLL*COSR+XLL*SINR+YLB
C * * * WAS POINT ON FIGURE 2 VALID? (YES,YES,NO)
7155 IF(NPFB-LCDA)7156,7156,7157
C * * * WRITE CONVERTED COORDS TO DISK
7156 CALL CGDBF(KFTB,6,1,LHDRS+LFGA+NPFB,IBUF)
GO TO 7140
C * * * NEW POINT WRITE TO DISK
7157 CALL CGPUT(NPFB,XBUF,YBUF)
GO TO 7140
7193 WRITE(MOUT,7183)
7183 FORMAT(' #####','SECOND FIGURE SMALLER THAN FIRST')
900 CALL RTNONE
RETURN
END
SUBROUTINE CGMIX
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
DIMENSION IDHX(4)
DIMENSION IIXLYL(4)
DIMENSION JOBS(6),JLS(6),IXLYL(6)
DIMENSION NSFL(100),LNFL(100)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(JOBS(1),JOBA),(JOBS(2),JOBB),(JOBS(3),JOBC),
* (JOBS(4),JPG)
EQUIVALENCE(JLS(1),JHDR),(JLS(2),JRSA),(JLS(3),JFGA),
* (JLS(4),JCDA),(JLS(5),JUNU),(JLS(6),JFILE)
EQUIVALENCE(IIXLYL(1),XL),(IIXLYL(3),YL)
IF(IDITO-4)30,30,4
4 IF(IDITO-64)6300,6400,6
6 IF(IDITO-66)6500,6600,8
8 IF(IDITO-80)7800,8000,92000
C END/OF/JOB END/OF/RUN
C IF NXJOB IS ZERO A JOB IS IN PROGRESS
C IF NXJOB=-, PRIMARY OUTPUT DEVICE HAS NOT
C BEEN USED SINCE LAST END/OF/JOB
C OTHERWISE TYPE MESSAGE AND RESTORE CARRIAGE
30 IF(NXJOB)36,31,34
C COMPLETE MAP IF ANY IS IN PROGRESS
31 IF(SFPI)33,33,32
C 32 CALL CGPLA
32 RETURN
C PUT HEADER DATA ON DISK
33 CALL CGDBF(KFTB,6,0,2,JLS)
JFGA=LFGA
JCDA=LCDA
JUNU=JFILE-(JHDR+JRSA+JCDA+JFGA)
CALL CGDBF(KFTB,6,1,2,JLS)
IXLYL(2)=IIXLYL(1)
IXLYL(3)=IIXLYL(2)
IXLYL(5)=IIXLYL(3)
IXLYL(6)=IIXLYL(4)
CALL CGDBF(KFTB,6,1,3,IXLYL)
CALL CGDBF(KFTB,6,0,1,JOBS)
C IF(KFTB-KFWS)285,287,285
C 285 WRITE(MOUT,286)JLS
C 286 FORMAT(/10X,'HEADER + RESERVED + FIGURE + COORD + UNUSED = TABLE',
C 1/
C * 7X6I9/)
C NOTIFY OPERATOR
C 287 WRITE(MTT,38)JOBA,JOBB
C 38 FORMAT(10X,'JOB',2I6,' COMPLETED')
JPG=NPG
CALL CGDBF(KFTB,6,1,1,JOBS)
CALL CGDBF(KFTB,6,-1,1,JOBS)
C CLOSE TABLE FILE WE ARE USING
CLOSE (UNIT=8)
C CLOSE PLOT FILE WE ARE USING
CLOSE (UNIT=9)
34 WRITE(MTP,35)
35 FORMAT('1')
CALL CGHDG(0,1,0)
NPG=0
36 IF(IDITO-4)37,999,999
C SET CLEAR TO ZERO - CLEAN SHEET IN PRINTER
C ACCEPT ONLY CONTROL COMMANDS
37 NXJOB=-1
C NO OUTPUT MODE
LIST=-1
C IGNORE BLANK COMMANDS
IDTSV=0
C GET PRIMARY I/O DEVICE NUMBERS
INDEV=IVC
MOUT=MTP
GO TO 900
C APPLY USE CHARGE AND EXIT
999 CHARGE=FLOAT(NUSE)*0.06
CALL USECHG('COGO 03/08',SNGL(CHARGE),'COGO')
STOP
C
C CARD/PRINT COMMAND
6300 CONTINUE
INDEV=IVC
MOUT=MTP
GO TO 6610
C CARD/TYPE COMMAND
6400 CONTINUE
INDEV=IVC
MOUT=MTT
GO TO 6610
C TYPE/PRINT COMMAND
6500 CONTINUE
INDEV=IVT
MOUT=MTP
GO TO 6610
C TYPE/TYPE COMMAND
6600 CONTINUE
INDEV=IVT
MOUT=MTT
C SET LIST OPTION IF A JOB IS IN PROGRESS
6610 IF(NXJOB)900,6690,900
6690 LIST=DATA(2)
GO TO 900
7800 CONTINUE
GO TO 900
C LIST TABLES
8000 CONTINUE
GO TO 900
C POINT LABELS
92000 KRSZN=DATA(1)*INCPI+.5
IF(KRSZN)92910,92016,92016
92016 IF(KRSZN-INCPI)92020,92020,92910
92910 WRITE(MOUT,92911)DATA(1)
92911 FORMAT(' #####','INVALID CROSS SIZE',F10.4)
KRSZN=INCPI/10
92020 NMSZN=DATA(2)*INCPI+.5
IF(NMSZN)92920,92026,92026
92026 IF(NMSZN-INCPI/5)92030,92030,92920
92920 WRITE(MOUT,92921)DATA(2)
92921 FORMAT(' #####','INVALID NUMBER SIZE',F10.4)
NMSZN=INCPI/10
92030 IF(ND-3)92080,92040,92040
92040 KRSZC=DATA(4)*INCPI+.5
IF(KRSZC)92940,92046,92046
92046 IF(KRSZC-INCPI)92050,92050,92940
92940 WRITE(MOUT,92941)DATA(4)
92941 FORMAT(' #####','INVALID CC CROSS SIZE',F10.4)
KRSZC=KRSZN
92050 NMSZC=DATA(5)*INCPI+.5
IF(NMSZC)92950,92056,92056
92056 IF(NMSZC-INCPI/5)900,900,92950
92950 WRITE(MOUT,92951)DATA(5)
92951 FORMAT(' #####','INVALID CC NUMBER SIZE',F10.4)
NMSZC=NMSZN
GO TO 900
92080 KRSZC=KRSZN
NMSZC=NMSZN
900 CALL RTNONE
RETURN
END
SUBROUTINE CGMTB
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION JOBS(6),JLS(6),IXLYL(6)
DIMENSION IIXLYL(4)
DIMENSION IDHXA(4),IDHXB(4)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(JOBS(1),JOBA),(JOBS(2),JOBB),(JOBS(3),JOBC),
* (JOBS(4),JPG)
EQUIVALENCE(JLS(1),JHDR),(JLS(2),JRSA),(JLS(3),JFGA),
* (JLS(4),JCDA),(JLS(5),JUNU),(JLS(6),JFILE)
EQUIVALENCE(IIXLYL(1),XL),(IIXLYL(3),YL)
EQUIVALENCE(LFTA,LFGA)
COMMON /COGCOM/ KBFLG,IBU(322)
DATA DEFFIL,MSLSH/'COGTAB.TMP','/'/
C START/OF/JOB
200 IF(NXJOB)220,203,210
C PREVIOUS JOB DID NOT HAVE END/OF/JOB.
C PUT HEADER DATA ON DISK
203 CALL CGDBF(KFTB,6,0,2,JLS)
JFGA=LFGA
JCDA=LCDA
JUNU=JFILE-(JHDR+JRSA+JCDA+JFGA)
CALL CGDBF(KFTB,6,1,2,JLS)
IXLYL(2)=IIXLYL(1)
IXLYL(3)=IIXLYL(2)
IXLYL(5)=IIXLYL(3)
IXLYL(6)=IIXLYL(4)
CALL CGDBF(KFTB,6,1,3,IXLYL)
CALL CGDBF(KFTB,6,0,1,JOBS)
WRITE(MTT,205)
205 FORMAT(' #####PREVIOUS JOB TERMINATED')
JPG=NPG
CALL CGDBF(KFTB,6,1,1,JOBS)
CALL CGDBF(KFTB,6,-1,1,JOBS)
MOUT=MTP
210 CONTINUE
WRITE(MTP,212)
212 FORMAT('1')
220 CALL CGHDG(IN,NKL,LK)
C
C*** PICK UP USER SPECIFIED FILENAME ON S.O.J. CARD
C IF THERE WAS ONE SPECIFIED.
COGFIL=DEFFIL
IF (IN(NKL).NE.MSLSH) GO TO 101
DO 104 JJJ=NKL+1,NKL+10
IF (IN(JJJ).EQ.'.') GO TO 105
104 CONTINUE
IN(NKL+7)='.'
IN(NKL+8)='C'
IN(NKL+9)='G'
IN(NKL+10)='T'
105 ENCODE (10,102,COGFIL) (IN(JJJ),JJJ=NKL+1,NKL+10)
102 FORMAT (10A1)
101 WRITE (MTT,103) COGFIL
103 FORMAT (' COGO OPENING FILE: ',A10,' FOR TABLE')
OPEN (UNIT=8,DEVICE='DSK',ACCESS='RANDOM',MODE='BINARY',
1 FILE=COGFIL,RECORD SIZE=320,ASSOCIATE VARIABLE=JDUMMY)
C
C ALSO OPEN TEMP. PLOTTING FILE
OPEN (UNIT=9,DEVICE='DSK',ACCESS='RANDOM',MODE='BINARY',
1 FILE='COGPLT.TMP',RECORD SIZE=320,
2 DISPOSE='DELETE',ASSOCIATE VARIABLE=JDUMMY)
NPG=0
IA=DATA(2)
IB=DATA(3)
I=DATA(5)
C INITIALIZE COMMON
NUMER=0
NXJOB=0
IDTSV=0
SFPI=0.
NPREC=0
KRSZN=IFIX(FLOAT(INCPI)/12.5)
NMSZN=IFIX(FLOAT(INCPI)/12.5)
KRSZC=IFIX(FLOAT(INCPI)/12.5)
NMSZC=IFIX(FLOAT(INCPI)/12.5)
XLP=CLEAR
LDFMT=0
LIST=0
AREA=0.
NCURV=-1
NCRVS=-1
C THE FOLLOWING STATEMENTS (THROUGH 228) MAY BE REMOVED
C THEIR PURPOSE IS TO SPEED START OF JOB WHEN ND=0
C DEC-10 VERSION USES NEG. VALUE FOR PLTFILORG
KFPLB=-1
C* KFPLB=KFWS
KFTB=KFWS
LNREC=(1600-KFTB)*53.
C* IF(LNREC)228,228,226
C* 226 IF(ND)260,260,228
C* 228 CONTINUE
C*C CHECK FOR FILE NUMBER ZERO
C* IF(I)232,230,232
C* 230 I=100
C*C GET PLOT FILE BASE ADDRESS
C* 232 CALL CGGTB(IFIX(SNGL(DATA(9))),IDHXB,100,KFPLB,LNREC)
C* IF(LNREC)298,298,234
C*C GET ADDRESS AND LENGTH OF FILE
C* 234 CALL CGGTB(IFIX(SNGL(DATA(7))),IDHXB,I,KFTB,LNREC)
C* IF(LNREC)298,298,236
C* 236 IF(DATA(5))260,260,240
C CHECK FOR EXISTANCE OF FILE
226 I=1
IF (COGFIL.EQ.DEFFIL) GO TO 260
READ (8#1,END=260) (IBU(JJJ),JJJ=1,320)
C CHECK FOR VALID JOB NUMBER
240 CALL CGDBF(KFTB,6,0,1,JOBS)
CALL CGDBF(KFTB,6,0,2,JLS)
CALL CGDBF(KFTB,6,0,3,IXLYL)
IIXLYL(1)=IXLYL(2)
IIXLYL(2)=IXLYL(3)
IIXLYL(3)=IXLYL(5)
IIXLYL(4)=IXLYL(6)
IF(JOBA+JOBB-JOBC)260,241,260
241 IF(IA-JOBA)294,242,294
242 IF(IB-JOBB)294,275,294
260 IF(DATA(5)-100.)267,296,296
267 JHDR=3
JRSA=0
JFGA=0
JCDA=0
JUNU=0
JFILE=JHDR
JOBA=IA
JOBB=IB
JOBC=JOBA+JOBB
JOBS(4)=0
JOBS(5)=0
JOBS(6)=0
275 IF(JHDR-3)290,276,290
276 SZ=JHDR
DO 277 J=2,5
IF(JLS(J))290,277,277
277 SZ=SZ+JLS(J)
IF(SZ-JFILE)290,280,290
280 KCH=LNREC-JFILE
J=5
282 JLS(J)=JLS(J)+KCH
IF(JLS(J))283,284,284
283 KCH=JLS(J)
JLS(J)=0
J=J-1
IF(J-1)290,290,282
284 JFILE=LNREC
CALL CGDBF(KFTB,6,1,1,JOBS)
CALL CGDBF(KFTB,6,1,2,JLS)
NPG=JPG
LHDRS=JHDR+JRSA
LFGA=JFGA
LCDA=JCDA
LUNU=JUNU
C INITIALIZE KGFGT BUFFER
J=KGFGT(0)
LFPRM=LFGA
2841 IF(LFPRM)2844,2844,2842
2842 IF(KGFGT(LFPRM*6)-10000)2843,2843,2844
2843 LFPRM=LFPRM-1
GO TO 2841
2844 CONTINUE
290 CONTINUE
294 CONTINUE
296 CONTINUE
GO TO 900
C COPY/TABLE
C UPDATE HEADER
900 CALL RTNONE
RETURN
END
SUBROUTINE CGNGN(XA,YA,RA,XB,YB,RB,XTA,YTA,XTB,YTB)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA CLEAR/1.E20/
DATA HFPI/1.5707963267948966D0/
DR=RA-RB
CALL CGINV(XA,YA,XB,YB,AZAB,DAB)
IF(DAB)90,90,10
10 IF(DAB-ABS(DR))90,20,20
20 TLVAB=SQRT(DAB*DAB-DR*DR)/DAB
AZOFF=AZAB-HFPI
CALL CGXTL(XA,YA,AZOFF,RA*TLVAB,XTA,YTA)
CALL CGXTL(XB,YB,AZOFF,RB*TLVAB,XTB,YTB)
DRVAB=DR/DAB
CALL CGXTL(XTA,YTA,AZAB,RA*DRVAB,XTA,YTA)
CALL CGXTL(XTB,YTB,AZAB,RB*DRVAB,XTB,YTB)
900 RETURN
90 XTA=CLEAR
YTA=CLEAR
XTB=CLEAR
YTB=CLEAR
GO TO 900
END
FUNCTION CGNRM(ANGLE)
C
C * * * NORMALIZES ANGLES.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA TWOPI/6.2831853071795864D0/
CGNRM=ANGLE
200 IF(CGNRM)202,210,210
202 CGNRM=CGNRM+TWOPI
GO TO 200
212 CGNRM=CGNRM-TWOPI
210 IF(CGNRM-TWOPI)900,212,212
900 RETURN
END
SUBROUTINE CGNSY(NUM,IA,NDX,NC)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C * * CONVERTS NUM TO A SYMBOL STRING IN A1 FORMAT AND PUTS STRING IN
C * * IA BEGINNING AT IA(NDX). LEADING ZEROES ARE GENERATED IF NECESSARY
C * * TO MAKE THE STRING NC CHARACTERS LONG. NDX WILL BE INCREMENTED BY
C ** ONE FOR EACH CHARACTER GENERATED.(NUM MUST BE .GE.0.AND.LE.9999)
C
DIMENSION IA(1),KON(10)
DATA KON/ '0','1','2','3','4','5','6','7','8','9' /
DATA MAX,MXP/4,5/
C
ISW = 1
DO 50 I=1,MAX
ISUB = (MOD(NUM,10**(MXP-I)) / 10**(MAX-I) ) + 1
IA(NDX) = KON(ISUB)
IF(ISUB-1)10,10,25
10 GO TO(15,25),ISW
15 IF(I-1+NC-MAX)50,25,25
25 NDX = NDX+1
ISW = 2
50 CONTINUE
C
RETURN
END
SUBROUTINE CGNTF
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
IF(IDITO-32)3200,3200,5200
3200 CONTINUE
NTA=DATA(1)
NTB=DATA(4)
CALL CGGET(IFIX(SNGL(DATA(2))),XA,YA)
IF(XA-CLEAR)3212,3290,3290
3212 CALL CGGET(IFIX(SNGL(DATA(5))),XB,YB)
IF(XB-CLEAR)3220,3290,3290
3220 IF(ND-6)3230,3230,3222
3222 IF(DATA(3)-DATA(6))3292,3224,3224
3292 WRITE(MOUT,3293)
3293 FORMAT(' #####','LARGER RADIUS MUST BE FIRST')
GO TO 3298
3224 DATA(3)=DATA(3)*DATA(8)*ISGG
DATA(6)=DATA(6)*DATA(8)*DATA(9)*ISGG
3230 CALL CGNGN(
*XA,YA,DATA(3),XB,YB,DATA(6),XTA,YTA,XTB,YTB)
IF(XTA-CLEAR)3232,3290,3290
3232 CALL CGPUT(NTA,XTA,YTA)
CALL CGPUT(NTB,XTB,YTB)
3234 CALL CGPCD(NTA)
CALL CGPCD(NTB)
IF(LIST)900,3240,3240
3240 CALL CGINV(XTA,YTA,XTB,YTB,AZ,DIST)
CALL CGDMS(CGNRM((AZ+AZEZ)*ISGG),IDEG,MIN,SEC)
WRITE(MOUT,3243)NTA,NTB,IDEG,MIN,SEC,DIST
3243 FORMAT(20X,'FROM',I5,' TO',I5,I10,'-',I2,'-',F4.1,F16.4/)
GO TO 900
3290 WRITE(MOUT,3291)
3291 FORMAT(' #####','NO TANGENT POSSIBLE')
3298 CALL CGPUT(NTA,CLEAR,CLEAR)
CALL CGPUT(NTB,CLEAR,CLEAR)
GO TO 3234
C TANGET/OFFSET
C
5200 CONTINUE
C GET OFFSET POINT
IL=DATA(2)
CALL CGGET(IL,XA,YA)
C GET FIRST POL
IJ=DATA(3)
CALL CGGET(IJ,XC,YC)
N=DATA(4)
C GET SECOND POL
CALL CGGET(N,XD,YD)
C GET AZIMUTH AND LENGTH
CALL CGINV(XC,YC,XD,YD,AZ,DIST)
C COMPUTE INTERSECTION
CALL CGFST(XC,YC,XD,YD,XA,YA,XFIND,YFIND)
C GET UNKNOWN POINT NUMBER
N=DATA(1)
C CHECK FOR ERROR
IF(XA-CLEAR)5232,5290,5290
5232 IF(XC-CLEAR)5234,5290,5290
5234 IF(XD-CLEAR)5236,5290,5290
5236 IF(XFIND-CLEAR)5238,5290,5290
5238 CALL CGPUT(N,XFIND,YFIND)
C PRINT OUTPUT
IF(LIST)900,5239,5239
5239 CALL CGPCD(N)
CALL CGINV(XC,YC,XFIND,YFIND,ANGLE,DIST1)
DIST2=DIST1+.00005
IF(ABS(ABS(ANGLE-AZ)-PI)-HFPI)5250,5253,5253
5250 WRITE(MOUT,5251)IJ,N,DIST2
5251 FORMAT(20X,'FROM',I5,' TO',I5,F14.4,' FT. ON BACK EXTENSION',/)
GO TO 5260
5253 IF(DIST1-DIST)5258,5258,5254
5254 WRITE(MOUT,5255)IJ,N,DIST2
5255 FORMAT(20X,'FROM',I5,' TO',I5,F14.4,' FT. ON FORWARD EXTENSION',/
1)
GO TO 5260
5258 WRITE(MOUT,5259)IJ,N,DIST2
5259 FORMAT(20X,'FROM',I5,' TO',I5,F14.4,' FT.',/)
5260 CALL CGINV(XA,YA,XFIND,YFIND,ANGLE,DIST1)
DIST1=DIST1+.00005
IF(ABS(ABS(ANGLE+HFPI-AZ)-PI)-HFPI)5268,5268,5262
5262 WRITE(MOUT,5263)N,IL,DIST1
5263 FORMAT(20X,'FROM',I5,' TO',I5,F14.4,' FT. LEFT',/)
GO TO 900
5268 WRITE(MOUT,5269)N,IL,DIST1
5269 FORMAT(20X,'FROM',I5,' TO',I5,F14.4,' FT. RIGHT',/)
GO TO 900
5290 WRITE(MOUT,5291)
5291 FORMAT(' #####','NO OFFSET POSSIBLE')
CALL CGPUT(N,CLEAR,CLEAR)
CALL CGPCD(N)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGNTG(IVAL,NUM)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * DECODES UNSIGNED INTEGERS FROM INPUT
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C * * * GET THE NUMBER
CALL CGNUM(VALUE,NUM)
IVAL=VALUE
C * * * WAS IT REAL OR INTEGER? (REAL,INT,REAL)
IF(IVAL-VALUE)90,900,90
C * * * SET ERROR FOR REAL
90 NUM=-1
900 RETURN
END
SUBROUTINE CGNTR
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
C 19 POINTS INTERSECT
C 20 AZIMUTH INTERSECT
C 21 BEARING INTERSECT
C 104 POINTS AZIMUTH INTERSECT
C 105 POINTS BEARING INTERSECT
C 114 ANGLES INTERSECT
C 115 FORESECTION
C
IF(LDFMT)20,20,10
10 DATA(7)=0.
DATA(9)=0.
20 CONTINUE
C
IF(IDITO-19)1900,1900,2000
C POINTS/INTERSECT
1900 NI=DATA(1)
CALL CGGET(IFIX(SNGL(DATA(2))),XA,YA)
IF(XA-CLEAR)1912,1990,1990
1912 CALL CGGET(IFIX(SNGL(DATA(3))),XB,YB)
IF(XB-CLEAR)1914,1990,1990
1914 CALL CGGET(IFIX(SNGL(DATA(4))),XC,YC)
IF(XC-CLEAR)1916,1990,1990
1916 CALL CGGET(IFIX(SNGL(DATA(5))),XD,YD)
IF(XD-CLEAR)1920,1990,1990
1920 CALL CGINV(XA,YA,XB,YB,AZAB,DIST)
AZ=AZAB-HFPI
CALL CGXTL(XA,YA,AZ,DATA(7),XA,YA)
CALL CGXTL(XB,YB,AZ,DATA(7),XB,YB)
CALL CGINV(XC,YC,XD,YD,AZCD,DIST)
AZ=AZCD-HFPI
CALL CGXTL(XC,YC,AZ,DATA(9),XC,YC)
CALL CGXTL(XD,YD,AZ,DATA(9),XD,YD)
CALL CGPIN(XA,YA,XB,YB,XC,YC,XD,YD,XI,YI)
IF(XI-CLEAR)1930,1990,1990
1930 ANGLE=HFPI-ABS(ABS(ABS(AZCD-AZAB)-PI)-HFPI)
1934 CALL CGDMS(ANGLE,IDEG,MIN,SEC)
IF(IDEG-6)1936,1940,1940
1936 WRITE(MOUT,1937)NI,IDEG,MIN,SEC
1937 FORMAT(I8,' INTERSECTION ANGLE =',I3,'-',I2,'-',F4.1)
1940 CALL CGPUT(NI,XI,YI)
1960 CALL CGPCD(NI)
GO TO 900
1990 WRITE(MOUT,1991)
1991 FORMAT(' #####','NO INTERSECTION')
CALL CGPUT(NI,CLEAR,CLEAR)
GO TO 1960
C AZ/INTERSECT
2000 CONTINUE
C BR/INTERSECT
2100 CONTINUE
C ANGLES INTERSECT
11400 CONTINUE
C FORESECTION
11500 CONTINUE
C POINTS AZIMUTH INTERSECT
10400 CONTINUE
C POINTS BEARING INTERSECT
10500 CONTINUE
C GET NEW POINT NUMBER
NI=DATA(1)
C GET COORDINATES OF POINT J
CALL CGGET(IFIX(SNGL(DATA(2))),XA,YA)
IF(XA-CLEAR)2012,1990,1990
C GET COORDINATES OF POINT K
2012 CALL CGGET(IFIX(SNGL(DATA(4))),XB,YB)
IF(XB-CLEAR)2014,1990,1990
2014 IF(IDITO.NE.104.AND.IDITO.NE.105) GO TO 2020
10410 CALL CGGET(IFIX(SNGL(DATA(3))),XC,YC)
IF(XC-CLEAR)10412,1990,1990
10412 CALL CGINV(XA,YA,XC,YC,DATA(3),DIST)
IF(DIST)1990,1990,2020
2020 IF(IDITO.EQ.114.OR.IDITO.EQ.115) GO TO 11420
C AZIMUTH OR BEARING INTERSECT
CALL CGXTL(XA,YA,DATA(3)-HFPI,DATA(7),XA,YA)
CALL CGXTL(XB,YB,DATA(5)-HFPI,DATA(9),XB,YB)
CALL CGZIN(XA,YA,DATA(3),XB,YB,DATA(5),XI,YI)
IF(XI-CLEAR)2030,1990,1990
2030 ANGLE=HFPI-ABS(ABS(ABS(ABS(DATA(3)-DATA(5))-TWOPI)-PI)-HFPI)
GO TO 1934
C ANGLES INTERSECT OR FORESECTION
C GET AZIMUTH BETWEEN J TO K
11420 CALL CGINV(XA,YA,XB,YB,DATA(12),DIST)
C REDEFINE XA,YA,XB AND YB WITH OFFSETS
CALL CGXTL(XA,YA,DATA(12)-HFPI+DATA(3),DATA(7),XA,YA)
CALL CGXTL(XB,YB,DATA(12)+HFPI+DATA(5),DATA(9),XB,YB)
CALL CGZIN(XA,YA,DATA(12)+DATA(3),XB,YB,DATA(12)+DATA(5)+PI,
1XI,YI)
GO TO 1940
900 CALL RTNONE
RETURN
END
SUBROUTINE CGNTS
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(IN(3),KTFA),(IN(6),KTB),(IN(9),FSTA),(IN(12),FSTB),
*(IN(15),M),(IN(18),XM),(IN(21),YM),(IN(24),SGINT),(IN(27),SGPRS),
*(IN(30),XI),(IN(33),YI),(IN(36),LKAB),(IN(39),LKBB),(IN(42),KVB),
*(IN(45),XAB),(IN(48),YAB),(IN(51),XBB),(IN(54),YBB),(IN(57),XCB),
*(IN(60),YCB)
NI=DATA(1)
IF(IDITO-23)2200,2300,10
10 IF(IDITO-25)2400,2500,20
20 CONTINUE
C RESET MULTICARD ERROR SWITCH
C IF BAD DATA OCCURED ON CONTINUATION CARD, THE
C CARD CANNOT BE USED AS NEXT COMMAND BECAUSE
C THE CARD IMAGE IS DESTROYED BY THIS COMMAND
MLTCD=0
IF(IDITO-99)9800,9900,10000
C
C ARC/LINE/POINTS
C
2200 CONTINUE
CALL CGGET(IFIX(SNGL(DATA(5))),XTEM2,YTEM2)
IF(XTEM2-CLEAR)2210,2592,2592
2210 CALL CGGET(IFIX(SNGL(DATA(4))),XTEM1,YTEM1)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,DATA(5),DIST1)
IF(DIST1)2592,2592,2300
C ARC LINE AZIMUTH
2300 CONTINUE
C ARC LINE BEARING
2400 CONTINUE
CALL CGGET(IFIX(SNGL(DATA(4))),XK,YK)
IF(XK-CLEAR)2312,2592,2592
2312 CALL CGGET(IFIX(SNGL(DATA(2))),XCC,YCC)
IF(XCC-CLEAR)2314,2592,2592
2314 CALL CGXTL(XK,YK,DATA(5)-HFPI,DATA(8),XK,YK)
CALL CGALZ(
*XCC,YCC,DATA(3),XK,YK,DATA(5),XIA,YIA,XIB,YIB)
CALL CGINV(XCC,YCC,XIA,YIA,AZ,DIST1)
ANGLE=AZ-HFPI-DATA(5)
GO TO 2522
C
C ARC/ARC/INTERSECT.
C
2500 CONTINUE
CALL CGGET(IFIX(SNGL(DATA(2))),XA,YA)
IF(XA-CLEAR)2512,2592,2592
2512 CALL CGGET(IFIX(SNGL(DATA(4))),XB,YB)
IF(XB-CLEAR)2520,2592,2592
2520 CALL CGAAI(
*XA,YA,DATA(3),XB,YB,DATA(5),XIA,YIA,XIB,YIB)
CALL CGINV(XA,YA,XIA,YIA,ANGLE,DIST1)
CALL CGINV(XIA,YIA,XB,YB,AZ,DIST1)
ANGLE=ANGLE-AZ
2522 IF(XIA-CLEAR)2524,2592,2592
2524 CALL CGDMS(
*HFPI-ABS(ABS(ABS(ANGLE)-PI)-HFPI),IDEG,MIN,SEC)
IF(IDEG-6)2526,2530,2530
2526 WRITE(MOUT,2527)NI,IDEG,MIN,SEC
2527 FORMAT(I8,' INTERSECTION ANGLE =',I3,'-',I2,'-',F4.1)
2530 CALL CGGET(IABS(IFIX(SNGL(DATA(6)))),XK,YK)
IF(XK-CLEAR)2532,2592,2592
2532 CALL CGINV(XK,YK,XIA,YIA,AZ,DMA)
CALL CGINV(XK,YK,XIB,YIB,AZ,DMB)
IF((DMB-DMA)*DATA(6))2536,2534,2534
2534 CALL CGPUT(NI,XIA,YIA)
GO TO 2540
2536 CALL CGPUT(NI,XIB,YIB)
2540 CALL CGPCD(NI)
GO TO 900
2592 WRITE(MOUT,2593)
2593 FORMAT(' #####','NO INTERSECTION')
CALL CGPUT(NI,CLEAR,CLEAR)
GO TO 2540
9800 CONTINUE
9900 CONTINUE
KTB=0
M=DATA(5)
FSTA=DATA(7)
CALL CGGET(IFIX(SNGL(DATA(3))),XCB,YCB)
IF(XCB-CLEAR)9804,2592,2592
9804 IF(IDITO-99)9810,9910,9910
9810 CALL CGXTL(XCB,YCB,DATA(4)-HFPI,DATA(9),XAB,YAB)
CALL CGXTL(XAB,YAB,DATA(4),1000.D0,XBB,YBB)
KVB=0
GO TO 10020
9910 CALL CGXTL(XCB,YCB,0.D0,DATA(4),XAB,YAB)
XBB=XAB
YBB=YAB
KVB=1
LKAB=1
LKBB=1
GO TO 9816
10000 CONTINUE
KTB=DATA(3)
M=DATA(4)
FSTA=DATA(6)
FSTB=DATA(8)
10020 LKAB=0
LKBB=0
9816 CALL CGGET(IABS(M),XM,YM)
IF(XM-CLEAR)9820,2592,2592
9820 SGPRS=0.
SGINT=0.
KTFA=DATA(2)
CALL CGFIN
900 CALL RTNONE
RETURN
END
SUBROUTINE CGNUM(VALUE,NUM)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * DECODES A NUMBER FROM THE INPUT (REAL OR INTEGER)
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MZERO/'0'/
DATA M9 /'9'/
DATA MPNT /'.'/
C * * * SET NUMBER
VALUE=0.
C * * * SET NUMBER OF DECIMAL PLACES
POINT=0.
C * * * SET NO NUMBER FOUND YET
NUM=0
C * * * GET NEXT COLUMN - INCLUDES CONTINUATIONS
CALL CGCOL(KN)
C * * * IS THIS THE END OF THE LINE? (NO,NO,YES)
2 IF(NKL-LK)4,4,60
C * * * GET NEXT CHARACTER
4 KN=IN(NKL)
C * * * IS IT A NUMBER?
IF(KN.LT.MZERO.OR.KN.GT.M9) GO TO 30
C * * * CALC REAL NUMBER (NOT STANDARD FORTRAN)
KV=(KN-MZERO)/2**29
C * * * CALC NUMBER
10 VALUE=VALUE*10.+KV
C * * * CALC DECIMAL SHIFT
POINT=POINT*10.
C * * * POINT TO NEXT INPUT CHARACTER
19 NKL=NKL+1
C * * * SET GOOD NUMBER SO FAR
NUM=1
GO TO 2
C * * * CHECK FOR DECIMAL
30 IF(KN-MPNT)60,32,60
C * * * WERE THERE ANY DECIMALS? (YES,NO,YES)
32 IF(POINT)90,34,90
C * * * SET FOUND A DECIMAL
34 POINT=1.
GO TO 19
C * * * FOUND MORE THAN ONE DECIMAL POINT
90 NUM=-1
GO TO 900
C * * * WAS A DECIMAL POINT FOUND? (YES,NO,YES)
60 IF(POINT)62,900,62
C * * * SHIFT FOR DECIMAL
62 VALUE=VALUE/POINT
900 RETURN
END
SUBROUTINE CGNVR
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION ZTEM2(2),ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(LFTA,LFGA)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ZTEM2(1),XTEM2),(ZTEM2(2),YTEM2)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
DATA ML /'L'/
DATA MR /'R'/
DATA MBL /' '/
C START OF CODING FOR 10 DISTANCE
C 16 INVERSE/AZIMUTH
C 17 INVERSE/BEARING
C 26 AREA
C 27 AREA/AZIMUTHS
C 28 AREA/BEARINGS
C 72 TRAVERSE/AZIMUTHS
C 73 TRAVERSE/BEARINGS
C 89 TRAVERSE ANGLES
C 90 TRAVERSE DEFLECTIONS
C INITIALIZE FOR FIGURE
KTF=DATA(1)
C INITIALIZE (NO CURVE IN PROGRESS)
KURVA=0
C SET SWITCH (THIS IS NOT 89 OR 90)
KGD=0
C GET FIRST POINT IN FIGURE
CALL CGFIG(KTF,NPF,NS)
IPTA=NPF
C NEXT POINT IS FIRST POINT
N=IPTA
CALL CGGET(N,XTEM2,YTEM2)
C PREVIOUS POINT IS ALSO FIRST POINT
XTEM1=XTEM2
YTEM1=YTEM2
C USE FIRST POINT AS LOCAL ORIGIN FOR AREA
YLOC=YTEM2
C INITIALIZE AREA
A=0.
C IF 27 28 72 73 PRINT FIRST COORD BEFORE STARTING
IF(IDITO-26)180,180,600
C ADVANCE TO NEXT POINT.
180 J=N
XTEM1=XTEM2
YTEM1=YTEM2
C ADVANCE CURVE SWITCH
KURVB=KURVA
CALL CGFIG(KTF,NPF,NS)
C PRESET CURVE SWITCH (NO CURVE)
KURVA=0
C IF(NS)SET CURVE SWITCH,END OF FIGURE,NO CURVE
IF(NS)254,800,255
C KURVA=1 FOR LEFT, KURVA=-1 FOR RIGHT
254 KURVA=-NS-2
C N IS NEXT POINT
255 N=NPF
C ASAVE=AZIMUTH OF PREVIOUS COURSE
300 ASAVE=BSAVE
C GET AZIMUTH AND DISTANCE OF THIS COURSE (J TO N)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,BSAVE,DIST1)
C GET THE ROUNDED DISTANCE SAVING THE UNROUNDED
C VALUE FOR CURVE COMPUTATIONS
C* THE DECSYSTEM-10 ALREADY ROUNDS SO DONT DO IT IN SOFTWARE
* DIST=DIST1+.00005
DIST=DIST1
C SET UP R OR L IN A1 FORMAT FOR PRINTING
C OR SKIP CURVE ROUTINE IF THERE IS NO CURVE
NS=MR
IF(KURVB)402,540,401
401 NS=ML
C COMPUTE CENTRAL ANGLE
402 ANGLE=(BSAVE-ASAVE)*KURVB-PI
C MAKE IT IN RANGE 0-TWOPI
ANGLE=CGNRM(ANGLE)
C INCLUDE SECTOR IN ACCUMULATED AREA
A=A-ANGLE*DIST1**2/2.*KURVB
C IF 10 16 17 26 DO NOT PRINT CURVE DATA
IF(IDITO-26)580,580,500
500 IF(LIST)580,502,502
C COMPUTE ARC LENGTH FOR PRINTING
502 DIST1=DIST1*ANGLE+.00005
C PRINT CURVE DATA
CALL CGDMS(ANGLE,IDEG,MIN,SEC)
WRITE(MOUT,505)J,(ZWHOL(I),(IZ(M,I),M=1,4),I=1,2),
* IDEG,MIN,SEC,NS,DIST1
505 FORMAT(/,' CC ',I4,2(1X,F10.0,4I1)
* ,1X,'DELTA=',I3,'-',I2,'-',F4.1,1X,A1,2X,'L=',F10.4/)
GO TO 580
540 IF(KGD)580,580,541
541 IF(IDITO-89)542,542,550
542 CALL CGDMS(CGNRM((BSAVE-ASAVE-PI)*ISGG),IDEG,MIN,SEC
* )
NS=MBL
GO TO 556
550 ANGLE=CGNRM(BSAVE-ASAVE+PI)-PI
IF(ANGLE)554,552,552
552 NS=ML
554 CALL CGDMS(ABS(ANGLE),IDEG,MIN,SEC)
556 IF(LIST)580,558,558
558 WRITE(MOUT,559)J,(ZWHOL(I),(IZ(M,I),M=1,4),I=1,2),IDEG,MIN,SEC,NS
559 FORMAT(I8,2(1X,F10.0,4I1),I10,'-',I2,'-',F4.1,1XA1)
580 IF(LIST)700,590,590
590 EXAZ=CGNRM((BSAVE+AZEZ)*ISGG)
IF(IDITO-16)1000,1600,591
591 IF(IDITO-26)1700,700,592
592 IF(IDITO-28)2700,1700,593
593 IF(IDITO-72)2700,2700,594
594 IF(IDITO-89)1700,8900,8900
C PRINT - 10
1000 WRITE(MOUT,1005)J,N,DIST
1005 FORMAT(20X,'FROM',I5,' TO',I5,F14.4,' FT.',/)
GO TO 180
C PRINT - 16
1600 CALL CGDMS(EXAZ,IDEG,MIN,SEC)
WRITE(MOUT,1605)J,N,IDEG,MIN,SEC,DIST
1605 FORMAT(20X,'FROM',I5,' TO',I5,I10,'-',I2,'-',F4.1,F16.4/)
GO TO 180
C COMPUTE BEARING - 17 28 73
1700 NQUAD=IFIX(SNGL(EXAZ/HFPI))+1
M13=3-(NQUAD-2)*(NQUAD-3)
M24=NQUAD/3*2+2
ANGLE=HFPI-ABS(ABS(EXAZ-PI)-HFPI)
CALL CGDMS(ANGLE,IDEG,MIN,SEC)
IF(IDITO-26)1710,2800,2800
C PRINT - 17
1710 WRITE(MOUT,1715)J,N,MAXES(M13),IDEG,MIN,SEC,MAXES(M24),DIST
1715 FORMAT(20X,'FROM',I5,' TO',I5,6XA1,I3,'-',I2,'-',F4.1,1XA1,F14.4/
1)
GO TO 180
C PRINT AZIMUTH - 27 72
2700 CALL CGDMS(EXAZ,IDEG,MIN,SEC)
WRITE(MOUT,2705)IDEG,MIN,SEC,DIST
2705 FORMAT(45XI3,'-',I2,'-',F4.1,F16.4)
GO TO 600
C PRINT BEARING 28 73
2800 WRITE(MOUT,2805)MAXES(M13),IDEG,MIN,SEC,MAXES(M24),DIST
2805 FORMAT(44XA1,I3,'-',I2,'-',F4.1,1XA1,F14.4)
GO TO 600
C PRINT DISTANCE - 89 90
8900 WRITE(MOUT,8905)DIST
8905 FORMAT(58X,F14.4)
KGD=1
GO TO 600
C PRINT COORDS (NO SPACE AFTER PRINTING)
600 IF(LIST)700,602,602
602 CALL CGFCD(ZTEM2,ZL,ISGZ,IXYF,ZWHOL,IZ,10)
C IF THIS IS A CC, DO NOT PRINT IT NOW.
IF(KURVA)700,660,700
660 IF(KGD)670,670,700
670 WRITE(MOUT,671)N,(ZWHOL(I),(IZ(M,I),M=1,4),I=1,2)
671 FORMAT(I8,2(1X,F10.0,4I1))
C ACCUMULATE AREA
700 A=A+(XTEM2-XTEM1)*((YTEM2+YTEM1)/2.-YLOC)
C SAVE COORD OF THIS POINT
GO TO 180
C END OF POINT LIST OR FIGURE
C RETURN IF 10 16 17
800 IF(IDITO-26)900,801,801
C SPACE PRINTER AND RETURN IF 72 73
801 IF(IDITO-72)807,804,804
C PRINT LAST COORD AND RETURN IF 89 90
804 IF(IDITO-89)850,860,860
C COMMAND IS 26 27 28. IS AREA CLOSED
807 IF(J-IPTA)808,870,808
C NO - AREA IS UNDEFINED
808 AREA=CLEAR
WRITE(MOUT,93)
93 FORMAT(' #####','FIRST POINT DIFFERENT FROM LAST')
GO TO 900
C RETURN SEQUENCE FOR 72 73
850 IF(LIST)900,851,851
851 WRITE(MOUT,852)
852 FORMAT(1X)
GO TO 900
C RETURN SEQUENCE FOR 89 90
860 IF(LIST)900,861,861
861 WRITE(MOUT,671)N,(ZWHOL(I),(IZ(M,I),M=1,4),I=1,2)
GO TO 850
C RETURN SEQUENCE FOR 26 27 28
870 AREA=ABS(A)
IF(LIST)900,872,872
872 AP=AREA+.0005
ACRES=AREA/43560.+.000000005
WRITE(MOUT,875)AP,ACRES
875 FORMAT(/14X,5HAREA=,F13.3,8H SQ.FT.=,F13.8,6H ACRES/)
GO TO 900
C END OF CODING FOR 10 16 17 26 27 28 72 73
900 CALL RTNONE
RETURN
END
SUBROUTINE CGNVS
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IBUF(6)
DIMENSION IIBUF(4)
DIMENSION ZBUF(2),ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(LFTA,LFGA)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ZBUF(1),IIBUF(1),XBUF),(ZBUF(2),IIBUF(3),YBUF)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
DATA MBL /' '/
IF(IDITO-8)1,800,1
1 IF(IDITO-62)2,6200,3
2 IF(IDITO-29)3,2900,2900
3 IF(IDITO-81)900,8100,8300
800 CONTINUE
IF(DATA(12))8100,802,8100
802 IF(ND-2)804,900,814
804 DATA(1)=7
DATA(2)=9
DATA(3)=9
DATA(4)=9
DATA(5)=1
DATA(12)=1
ND=0
DO 809 NKL=1,LK
IF(IN(NKL)-MBL)809,810,809
809 CONTINUE
810 CALL CGDFG
814 IB=DATA(3)
IF(IB)890,804,816
816 IF(IB-DATA(3))890,818,890
818 IA=DATA(1)
IF(IA)890,890,820
820 IF(IB-9999)822,822,890
822 IF(IB-IA)890,824,824
824 ISGN=1
IF(LIST)900,8113,8113
890 WRITE(MOUT,891)
891 FORMAT(' #####','INVALID DUMP ADDRESS')
GO TO 900
C START OF CODING FOR 29 SEGMENT
C 30 SEGMENT/PLUS
C 31 SEGMENT/MINUS
2900 J = DATA(1)
N = DATA(2)
RR= DATA(3)
C COMPUTE AND VALIDATE CHORD LENGTH
CALL CGGET(J,XTEM1,YTEM1)
CALL CGGET(N,XTEM2,YTEM2)
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,ANGLE,DIST1)
IF(DIST1 - 2.*RR)2917,2914,2916
2914 ANGLE=PI
GO TO 2918
2916 WRITE(MOUT,2990)
2990 FORMAT(' #####','RADIUS LESS THAN HALF CHORD')
GO TO 900
C COMPUTE CENTRAL ANGLE
2917 ANGLE=2.*ATAN(DIST1/SQRT(4.*RR*RR - DIST1*DIST1))
C COMPUTE ARC LENGTH FOR PRINTING ONLY
2918 XL1= RR*ANGLE+.00005
C FIND SEGMENT AREA
ASEG = RR*RR * (ANGLE-SIN(ANGLE))/2.
SEGAC = ASEG/43560.
C PRINT SEGMENT OUTPUT
CALL CGDMS(ANGLE,IDEG,MIN,SEC)
RR=RR+.00005
DIST1=DIST1+.00005
IF(LIST)2925,2921,2921
2921 WRITE(MOUT,2922)ASEG,SEGAC,RR,DIST1,IDEG,MIN,SEC,XL1
2922 FORMAT(6X,'SEGMENT AREA=',F13.3,' SQ.FT.=',F13.8,' ACRES R=',F10.4
1//
*22X,'CHORD=',F10.4,' DELTA=',I3,'-',I2,'-',F4.1,4X,'L=',F10.4)
C SPACE AND RETURN IF COMMAND IS 29
2925 IF(IDITO-30)850,2931,2932
C
C FIND CUMULATIVE AREA.
C
C SEGMENT/PLUS
C
2931 AREA=AREA+ASEG
GO TO 871
C
C SEGMENT/MINUS
C
2932 AREA=AREA-ASEG
GO TO 871
850 IF(LIST)900,851,851
851 WRITE(MOUT,852)
852 FORMAT(1X)
GO TO 900
C RETURN SEQUENCE FOR 30 31
871 IF(LIST)900,872,872
872 AP=AREA+.0005
ACRES=AREA/43560.+.000000005
IF(AREA)873,874,874
873 AP=AREA-.0005
ACRES=AREA/43560.-.000000005
874 WRITE(MOUT,875)AP,ACRES
875 FORMAT(/14X,5HAREA=,F13.3,8H SQ.FT.=,F13.8,6H ACRES/)
GO TO 900
C START OF CODING FOR 62 ANGLE
C GET AZIMUTH AND LENGTH INTO FIRST SIDE
6200 CONTINUE
KTF=DATA(1)
J=0
K=0
6210 I=J
XI=XJ
YI=YJ
J=K
XJ=XK
YJ=YK
CALL CGFIG(KTF,K,IEND)
IF(IEND)6214,900,6214
6214 CALL CGGET(K,XK,YK)
IF(I)6220,6210,6220
6220 CALL CGINV(XJ,YJ,XI,YI,AZJI,DJI)
CALL CGINV(XJ,YJ,XK,YK,AZJK,DJK)
ANGLE=AZJK-AZJI
C PRINT ANGLE AND SIDES
CALL CGDMS(CGNRM(ANGLE*ISGG),IDEG,MIN,SEC)
DJI=DJI+.00005
DJK=DJK+.00005
IF(LIST)6210,6225,6225
6225 WRITE(MOUT,6226)I,J,K,DJI,IDEG,MIN,SEC,DJK
6226 FORMAT(3X,'ANGLE',3I5,1XF14.4,I10,'-',I2,'-',F4.1,F16.4/)
GO TO 6210
C LIST COORDINATES
C PUNCH COORDINATES
8100 CONTINUE
8300 CONTINUE
IF(LIST)900,8110,8110
8110 KTF=DATA(1)
8112 CALL CGFRG(KTF,IA,IB,ISGN)
IF(ISGN) 8113,8114,8113
8114 IF(IDITO-83) 900,8116,900
8116 CONTINUE
GO TO 900
8113 IBB=IB
IF(IA-LCDA)8118,8118,8115
8115 IA=LCDA
IF(IB-LCDA)8122,8122,8112
8118 IF(IB-LCDA)8122,8122,8119
8119 IBB=LCDA
8122 CALL CGDBF(KFTB,6,0,LHDRS+LFGA+IA,IBUF)
IIBUF(1)=IBUF(2)
IIBUF(2)=IBUF(3)
IIBUF(3)=IBUF(5)
IIBUF(4)=IBUF(6)
IF(XBUF-CLEAR)8124,8140,8140
8124 IF(IDITO-81)8130,8130,8330
8130 CALL CGPCD(IA)
IF(IDITO-8)8140,8132,8140
8132 IF(DATA(5))8140,8140,8330
8330 CONTINUE
8332 CALL CGFCD(ZBUF,ZL,ISGZ,IXYF,ZWHOL,IZ,0)
WRITE(MTC,8341)IA,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2)
8341 FORMAT( 'STORE',I5,2(1X,F10.0,4I1))
8140 IA=IA+ISGN
IF((IBB-IA)*ISGN)8142,8122,8122
8142 IF(IDITO-8)8112,8144,8112
8144 IF(DATA(12))8112,900,8112
900 CALL RTNONE
RETURN
END
SUBROUTINE CGOFF
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
IF(NCURV)3690,10,10
10 IF(IDITO-38)200,300,400
C
C COORD/POA AND COORD OFFSET
C
200 OFF = DATA(3)
N = DATA(1)
S = DATA(2)
IF(S - SPC) 217,217,229
C
C POINT ON BACK TANGENT
C
217 DIST1 = SPC - S
CALL CGGET(NPC,XTEM1,YTEM1)
CALL CGXTL(XTEM1,YTEM1,BA,DIST1,XTEM1,YTEM1)
AZ=APC
223 DIST1 = OFF*SGN
224 CALL CGXTL(XTEM1,YTEM1,AZ,DIST1,XN,YN)
CALL CGPUT(N,XN,YN)
C OUTPUT COORDS OF THE POA OR THE OFFSET POINT.
CALL CGPCD(N)
GO TO 900
229 IF(S - SPT) 234,231,231
C
C POINT ON AHEAD TANGENT.
C
231 DIST1 = S - SPT
CALL CGGET(NPT,XTEM1,YTEM1)
CALL CGXTL(XTEM1,YTEM1,AA,DIST1,XTEM1,YTEM1)
AZ=APT
GO TO 223
C
C POINT ON CURVE.
C
234 AZ = APC + ((S-SPC)*SGN)/ R
DIST1 = R +OFF*SGN
CALL CGGET(NC,XTEM1,YTEM1)
GO TO 224
C
C STATION/FROM/COORD
C
300 N = DATA(1)
GO TO 500
C
C OFFSET/ALIGNMENT
C
400 NP =DATA(1)
N =DATA(2)
C FIND OUT WHERE THE OFFSET IS
500 CALL CGGET(NC,XC,YC)
CALL CGGET(N,XN,YN)
CALL CGINV(XC,YC,XN,YN,AZCN,DIST)
ANGLE=CGNRM((AZCN-APC)*SGN)
DEFAN=CGNRM((APT-APC)*SGN)
IF(ANGLE-DEFAN)502,502,504
C OFFSET IS TO THE CURVE
502 S=SPC+R*ANGLE
OFF=(DIST-R)*SGN
CALL CGXTL(XC,YC,AZCN,R,XP,YP)
GO TO 514
504 IF(ANGLE-DEFAN/2.-PI)508,506,506
C OFFSET IS TO THE BACK TANGENT
506 CALL CGGET(NPC,XP,YP)
AZR=BA-PI
SR=SPC
GO TO 510
C OFFSET IS TO THE AHEAD TANGENT
508 CALL CGGET(NPT,XP,YP)
AZR=AA
SR=SPT
510 CALL CGINV(XP,YP,XN,YN,AZ,DIST)
ANGLE=AZR-AZ
S=COS(ANGLE)*DIST
CALL CGXTL(XP,YP,AZR,S,XP,YP)
S=SR+S
OFF=SIN(ANGLE)*DIST
514 IF(LIST)534,515,515
515 SR=S+.00005
IF(S)516,518,518
516 SR=S-.00005
518 OFFR=OFF+.00005
IF(OFF)532,533,533
532 OFFR=OFF-.00005
533 WRITE (MOUT,5001) N,SR,OFFR
5001 FORMAT(10X,'POINT',I5,4X,'STATION =',F14.4,4X,'OFFSET =',F10.4/)
534 IF(IDITO-38)900,900,536
536 CALL CGPUT(NP,XP,YP)
CALL CGPCD(NP)
GO TO 900
C
3690 WRITE(MOUT,3691)
3691 FORMAT(' #####','NO CURVE DEFINED')
900 CALL RTNONE
RETURN
END
SUBROUTINE CGPBG
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * PLOT BEGIN ROUTINE - SET UP MAP
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
IF(LK-NKL)74724,74724,74720
74720 WRITE(MTT,74721)(IN(I),I=NKL,LK)
74721 FORMAT(10X80A1)
74724 IF(INDPLT.NE.0) GO TO 74725
CALL PLOTSF(PNAME,-1,IANS)
74725 INDPLT=1
74730 J=INCPI/20
C MAKE SURE STARTING POINT IS AT LEAST 1/4 INCH FROM
C EDGE OF PAPER
JJ=INCPI/4
CALL CGPLT(1,0,-JJ)
CALL CGPLT(1,0,JJ)
74744 CONTINUE
I=-J
CALL CGPLT(1,I,I)
74750 CALL CGPDN
K=J+J
DO 74759 I=1,4
CALL CGPLT(0,K,0)
CALL CGPLT(0,0,K)
74759 K=-K
CALL CGPLT(1,J,J)
DO 74764 I=1,2
CALL CGPDN
74764 CALL CGPUP
XPINC=0.
YPINC=0.
IF(XLP-CLEAR)74772,74770,74770
74770 XLP=XL
YLP=YL
74772 IF(NPREC)900,900,74800
74800 CALL CGPLB
74990 SFPI=0.
900 CALL RTNONE
RETURN
END
SUBROUTINE CGPCD(N)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION ZTEM2(2),ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(ZTEM2(1),XTEM2),(ZTEM2(2),YTEM2)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
CALL CGGET(N,XTEM2,YTEM2)
IF(LIST)900,502,502
502 CALL CGFCD(ZTEM2,ZL,ISGZ,IXYF,ZWHOL,IZ,10)
WRITE(MOUT,570)N,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2)
570 FORMAT(I8,2(1X,F10.0,4I1)/)
900 RETURN
END
SUBROUTINE CGPDN
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA KDN/-1/
CALL CGPLT(KDN,0,0)
RETURN
END
SUBROUTINE CGPFG
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
KTF=DATA(1)
N=DATA(3)
NPF=0
20 CALL CGFSG(
*KTF,NPF,DATA(2),XA,YA,XB,YB,KV,XC,YC,KVN,XN,YN)
IF(XA-CLEAR)22,900,900
22 CALL CGPUT(N,XA,YA)
CALL CGPCD(N)
N=N+1
IF(NPF)40,40,20
40 CALL CGPUT(N,XB,YB)
CALL CGPCD(N)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGPFL
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION NMBFB(100),NMBFE(100)
DIMENSION XBF(20),YBF(20),NBF(20),NSBF(20)
DIMENSION IPBUF(10)
DIMENSION IPBFF(10)
DIMENSION IPBFP(10)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(IPBUF(1),N),(IPBUF(4),XN),(IPBUF(6),YN),
* (IPBUF(8),KVUD),(IPBUF(9),KRSZ),(IPBUF(10),NMSZ)
EQUIVALENCE(IPBFF(1),NF),(IPBFF(4),XNF),(IPBFF(6),YNF),
* (IPBFF(8),KVUDF),(IPBFF(9),KRSZF),(IPBFF(10),NMSZF)
EQUIVALENCE(IPBFP(1),NP),(IPBFP(4),XNP),(IPBFP(6),YNP),
* (IPBFP(8),KVUDP),(IPBFP(9),KRSZP),(IPBFP(10),NMSZP)
EQUIVALENCE(LFGA,LFTA)
DATA LNB/20/
DATA LNMBF/100/
C IGNORE COMMAND IF SYSTEM HAS NO PLOTTER
IF(INCPI)900,900,50
C IS THERE PRESENTLY A PLOT FILE
50 IF(NPREC)100,100,200
C NO - COMPUTE ADDRESS FOR PLOT FILE (AT WS)
100 KFPL=KFPLB
C IS THIS WS IN USE AS A TABLE
IF(KFPL-KFTB)200,150,200
C YES - TAKE HALF OF UNUSED AREA FOR PLOT FILE
150 LUNU=LUNU-LUNU/106*53
C COMPUTE ADDRESS FOR PLOT FILE (AFTER TABLE)
KFPL=KFPLB+(LHDRS+LFGA+LCDA+LUNU)/53
C COMPUTE LENGTH OF PLOT FILE
200 LPFL=(KFPL/4096*4096+1600-KFPL)*32.
C SET POINTER FOR STORING DATA IN FILE
NPRIN=NPREC
C SET UP LOCAL ORIGIN FOR PLOTTING
IF(XLP-CLEAR)300,240,240
240 IF(LCDA)300,300,260
260 XLP=XL
YLP=YL
C SELECT THE PROPER ROUTINE FOR THIS COMMAND
300 IF(IDITO-76)75000,310,310
310 IF(IDITO-77)76000,77000,93000
C PLOT COMMENT COMMAND
C N=-1 INDICATES PLOT COMMENT
75000 N=-1
XN=CLEAR
IF(DATA(1))75002,75010,75002
C * * * GET COORDS OR ANNOTATION START POINT
75002 CALL CGGET(IFIX(SNGL(DATA(1))),XN,YN)
IF(XN-CLEAR)75010,900,900
C * * * COMPUTE POINT FOR LABELING
75010 XN=XL-XLP+XN
YN=YL-YLP+YN
IXYL=3-IXYF
C * * * COMPUTE SHIFT DISTANCE
KVUD=DATA(IXYF+2)*INCPI*ISGX
KRSZ=DATA(IXYL+2)*INCPI*ISGY
C * * * CALC NO. COLUMNS IN COMMENT
NMSZ=LK-NKL
C * * * IS THERE A COMMENT? (NO,NO,YES)
IF(NMSZ)75900,75900,75030
C * * * IS THERE ROOM IN THE PLOT FILE? (YES,NO,NO)
75030 IF(NPRIN+(NMSZ+8)/9-LPFL)75034,75902,75902
C * * * CALC RECORD NO IN PLOT FILE
75034 NPRIN=NPRIN+1
C * * * WRITE RECORD TO PLOT FILE
CALL CGDBF(KFPL,10,1,NPRIN,IPBUF)
C * * * IS THIS THE END OF THE COMMENT? (NO,YES,YES)
IF(NKL-LK)75042,800,800
75042 DO 75049 I=2,10
C * * * IS THIS THE END OF THE COMMENT?
IF(NKL-LK)75044,75034,75034
C * * * POINT TO NEXT CHAR. OF THE COMMENT
75044 NKL=NKL+1
C * * * GET A CHAR OF THE COMMENT
75049 IPBUF(I)=IN(NKL)
C * ** GO WRITE 1 RECORD OF COMMENT
GO TO 75034
C
C * * * PLOT POINTS COMMAND
C
76000 CONTINUE
C
C * * * PLOT LINES COMMAND
C
77000 CONTINUE
C * * * CALC LINE TYPE CODE ; 0=PLOT POINTS, 1=PLOT LINES
KVUDN=IDITO-76
C * * * GET POINTER TO FIGURE (DISK RECORD NO.)
KTF=DATA(1)
KNB=LNB
NP=0
KVUDP=0
KRSZP=0
NMSZP=0
XNP=CLEAR
KNMBF=0
C
C * * * THE CODE DOWN TO STATEMENT 76010 CREATES A TABLE OF ALL
C * * * POINTS CURRENTLY WRITTEN ONTO THE PLOT FILE
C * * * USED TO DETERMINE IF A POINT HAS BEEN WRITTEN ONCE OR NOT
C
C * * * GET RECORD NO. OF LAST RECORD WRITTEN TO PLOT FILE
INSCN=NPRIN
C * * * HAVE WE REACHED THE BEGINNING OF THE PLOT FILE?(YES,YES,NO)
76002 IF(INSCN)76010,76010,76004
C * * * READ A RECORD FROM THE PLOT FILE
76004 CALL CGDBF(KFPL,10,0,INSCN,IPBFF)
C * * * IS IT A COMMENT? (PLT ANNOTATION, PLT COMMENT, REGULAR POINT)
IF(NF+1)76010,76008,76006
C * * * ADD THE POINT TO THE TABLE
76006 CALL CGRGS(NF,NIN,NMBFB,NMBFE,LNMBF,KNMBF)
C * * * BACK UP ONE MORE TIME
76008 INSCN=INSCN-1
GO TO 76002
C
C * * * GETS FIGURE DATA IN ARRAYS NBF,NSBF, COORDS IN XBF,YBF
C * * * (OR GETS NEXT SET OF COORDS WHEN KNB<LNB)
76010 CALL CGFBG(KTF,NFG,NS,XN,YN,NBF,NSBF,XBF,YBF,LNB,KNB
* )
N=NFG
KVUD=KVUDN
C * * * ARE WE DONE? (CURVE,YES,NO)
IF(NS)76200,76344,76100
C * * * IS THIS SAME AS LAST POINT? (NO,YES,NO)
76100 IF(N-NP)76101,76010,76101
C * * * SET CROSS SIZE
76101 KRSZ=KRSZN
C * * * SET NUMBER SIZE
NMSZ=NMSZN
C * * * DOES THIS POINT EXIST? (YES,NO,NO)
IF(XN-CLEAR)76103,76102,76102
C * * * CLEAR LINE TYPE
76102 KVUD=0
C * * * CLEAR CROSS SIZE
KRSZ=0
C * * * CLEAR NUMBER SIZE
NMSZ=0
GO TO 76344
C * * * ADJUST POINTS FOR PLOTTING
76103 XN=XL-XLP+XN
YN=YL-YLP+YN
C * * * IS THIS FIRST POINT ON FIGURE? (NO,YES,YES)
IF(XNP-CLEAR)76215,76104,76104
C * * * MAKE SURE NO LINE DRAWN TO THIS POINT
76104 KVUD=0
GO TO 76215
C * * * (REACHED A CURVE) IS THIS SAME AS LAST POINT?(NO,YES,NO)
76200 IF(N-NP)76201,76010,76201
C * * * DOES THIS POINT EXIST? (YES,NO,NO)
76201 IF(XN-CLEAR)76203,76102,76102
C * * * INDICATE CC
76203 KVUD=NS*1000-KRSZN-KRSZN
C * * * SET CROSS SIZE FOR LABELING CC
KRSZ=KRSZC
C * * * SET NUMBER SIZE FOR LABELING CC
NMSZ=NMSZC
C * * * GET NEXT POINT ON FIGURE
CALL CGFBG(
*KTF,NFG,NS,XNT,YNT,NBF,NSBF,XBF,YBF,LNB,KNB)
NT=NFG
KVUDT=0
C * * * WAS LAST POINT DEFINED? (YES,NO,NO)
IF(XNP-CLEAR)76204,76360,76360
C * * * IS THIS POINT DEFINED? (YES,NO,NO)
76204 IF(XNT-CLEAR)76205,76215,76215
C * * * ADJUST COORDS FOR PLOTTING
76205 XNT=XL-XLP+XNT
YNT=YL-YLP+YNT
C * * * SET LINE TYPE
KVUDT=KVUDN
C * * * CHECK TABLE
76215 CALL CGRGS(N,NIN,NMBFB,NMBFE,LNMBF,KNMBF)
C * * * WAS IT IN THE TABLE? (NO,NO,YES)
IF(NIN)76340,76340,76216
C * * * SET PLOT FILE RECORD NO.
76216 NR=INSCN
76217 NR=NR+1
C * * * HAVE WE REACHED TO UNWRITTEN PART YES? (NO,NO,YES)
IF(NR-NPRIN)76218,76218,76340
C * * * READ POINT
76218 CALL CGDBF(KFPL,10,0,NR,IPBFF)
C * * * POINT? (NO,NO,YES) (NO - COMMENT OR ANNOTATION)
IF(NF)76217,76217,76219
C * * * IS THIS SAME POINT? (NO,YES,NO)
76219 IF(N-NF)76217,76108,76217
C * * * ARE COORDS THE SAME? (NO,YES,NO)
76108 IF(XN-XNF)76217,76109,76217
76109 IF(YN-YNF)76217,76110,76217
76110 KWR=0
C * * * ARE CROSS SIZES THE SAME? (PICK LARGEST)
IF(KRSZ-KRSZF)76116,76116,76114
76114 KRSZF=KRSZ
KWR=1
C * * * SET NEW CROSS SIZE (PLOT THE POINT ONLY ONCE)
76116 KRSZ=0
C * * * ARE NUMBER SIZES THE SAME (PICK LARGEST)
IF(NMSZ-NMSZF)76117,76117,76118
C * * * DID WE CHANGE THE CROSS? (NO,NO,YES)
76117 IF(KWR)76120,76120,76119
C * * * CHANGE NUMBER SIZE
76118 NMSZF=NMSZ
C * * * WRITE THE OLD RECORD BACK TO DISK
76119 CALL CGDBF(KFPL,10,1,NR,IPBFF)
76120 NMSZ=0
C * * * WHAT TYPE OF LINE TO BE PLOTTED? (CC,NOLINE,LINE)
IF(KVUD)76240,76340,76128
C * * * WAS A LINE PLOTTED TO THE LAST POINT? (CC,NOLINE,LINE)
76128 IF(KVUDP)76340,76130,76130
C * * * HOW ABOUT THE POINT BEFORE? (CC,NOLINE,LINE)
76130 IF(KVUDF)76217,76140,76132
C * * * GO BACK ONE MORE POINT
76132 CALL CGDBF(KFPL,10,0,NR-1,IPBFF)
C * * * WAS A LINE DRAWN TO IT? (CC,NOLINE,LINE)
IF(KVUDF)76140,76134,76134
C * * * WAS IT THE SAME POINT AS THIS? (NO,YES,NO)
76134 IF(XNF-XNP)76140,76136,76140
76136 IF(YNF-YNP)76140,76150,76140
C * * * IS THIS THE END OF THE WRITTEN AREA? (NO,YES,YES)
76140 IF(NR-NPRIN)76142,76148,76148
C * * * READ THE RECORD ONE UP
76142 CALL CGDBF(KFPL,10,0,NR+1,IPBFF)
C * * * IS IT A POINT? (NO,NO,YES)
IF(NF)76217,76217,76143
C * * * WHAT KIND OF LINE? (NOLINE,NOLINE,LINE)
76143 IF(KVUDF)76217,76217,76144
C * * * IS THIS THE SAME POINT? (NO,YES,NO)
76144 IF(XNF-XNP)76217,76146,76217
76146 IF(YNF-YNP)76217,76150,76217
C * * * WHAT KIND OF LINE? (NOLINE,NOLINE,LINE)
76148 IF(KVUDP)76217,76217,76150
C * * * SET NO LINE TO BE DRAWN
76150 KVUD=0
GO TO 76340
C * * * WHAT KIND OF LINE TO PT? (NLINE,NOLINE,LINE)
76240 IF(KVUDT)76340,76340,76248
C * * * WHAT IS THIS POINT? (CC,OTHER,OTHER)
76248 IF(KVUDF)76250,76217,76217
C * * * ARE THEY BOTH CC'S? (NO,YES,NO)
76250 IF(KVUDF/1000-KVUD/1000)76270,76252,76270
C * * * IS THIS THE END OF THE WRITTEN AREA? (NO,YES,YES)
76252 IF(NR-NPRIN)76254,76217,76217
C * * * GET NEXT REC.
76254 CALL CGDBF(KFPL,10,0,NR+1,IPBFF)
C * * * WHAT LINE TYPE? (NOLINE,NOLINE,LINE)
IF(KVUDF)76217,76217,76256
C * * * IS THIS SAME POINT? (NO,YES,NO)
76256 IF(XNF-XNT)76217,76258,76217
76258 IF(YNF-YNT)76217,76260,76217
C * * * GET PREVIOUS POINT
76260 CALL CGDBF(KFPL,10,0,NR-1,IPBFF)
C * * * IS THIS SAME POINT? (NO,YES,NO)
IF(XNF-XNP)76217,76262,76217
76262 IF(YNF-YNP)76217,76290,76217
C * * * IS THIS THE END OF THE WRITTEN AREA? (NO,YES,YES)
76270 IF(NR-NPRIN)76274,76272,76272
C * * * WHAT KIND OF LINE ON LAST POINT? (NOLINE,NOLINE,LINE)
76272 IF(KVUDP)76217,76217,76280
C * * * GET NEXT POINT
76274 CALL CGDBF(KFPL,10,0,NR+1,IPBFF)
C * * * WHAT LINE TYPE? (NOLINE,NOLINE,LINE)
IF(KVUDF)76217,76217,76276
C * * * IS THIS SAME POINT? (NO,YES,NO)
76276 IF(XNF-XNP)76217,76278,76217
76278 IF(YNF-YNP)76217,76280,76217
C * * * GET PREVIOUS POINT
76280 CALL CGDBF(KFPL,10,0,NR-1,IPBFF)
C * * * IS THIS SAME POINT? (NO,YES,NO)
IF(XNF-XNT)76217,76282,76217
76282 IF(YNF-YNT)76217,76290,76217
C * * * SET NO LINE
76290 KVUDT=0
GO TO 76217
C * * * WHAT KIND OF POINT? (CC,NOLINE,LINE)
76340 IF(KVUD)76341,76344,76350
C * * * WHAT KIND OF LINE TO PT? (NOLINE,NOLINE,LINE)
76341 IF(KVUDT)76344,76344,76350
C * * * WAS THERE A LINE TO THE PC? (NO,NO,YES)
76344 IF(KVUDP)76346,76346,76350
C * * * SHOULD THIS POINT BE PLOTTED?(NO,NO,YES)
76346 IF(KRSZP+NMSZP)76360,76360,76350
C * * * IS THE PLOT FILE ULL? (NO,YES,YES)
76350 IF(NPRIN-LPFL)76354,75902,75902
76354 NPRIN=NPRIN+1
C * * * WRITE THE CURRENT POINT
CALL CGDBF(KFPL,10,1,NPRIN,IPBFP)
76360 IF(NS)76364,800,76364
C * * * SET PARAMS FOR PREVIOUS POINT
76364 NP=N
XNP=XN
YNP=YN
KVUDP=KVUD
KRSZP=KRSZ
NMSZP=NMSZ
C * * * WAS THIS A CC? (YES,NO,NO)
IF(KVUD)76366,76010,76010
C * * * SET FOR LAST CC
76366 N=NT
XN=XNT
YN=YNT
KVUD=KVUDT
GO TO 76100
C * * * PLOT ANNOTATION COMMAND
C * * * SET ANNOTATION CODE
93000 N=-2
C * * * GET LINE ANNOTATION CODE
XN=DATA(2)
C * * * GET CHARACTER LENGTH OF ANNOTATION SIZE SPECIFICATION
NMSZ=LK-NKL
C * * * WRITE IT TO THE PLOT FILE
GO TO 75030
75900 WRITE(MOUT,75901)
75901 FORMAT(' #####','NO COMMENT TO PLOT')
GO TO 900
75902 CONTINUE
WRITE(MOUT,75903)
75903 FORMAT(' #####','PLOT FILE FULL')
800 NPREC=NPRIN
IF(SFPI)900,900,880
880 RETURN
900 CALL RTNONE
RETURN
END
SUBROUTINE CGPFM(XF,YF,XM,YM,IFIT)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA ROTS/1.E20/
C REAL NUMBER TRUNCATION
IF(ROTS-ROT)10,20,10
10 ROTS=ROT
SINR=SIN(ROTS)
COSR=COS(ROTS)
20 XT=(XF*COSR-YF*SINR-XORG)*INCPI/SFPI
YT=(YF*COSR+XF*SINR-YORG)*INCPI/SFPI
IF(XT)32,34,34
32 XT=XT-.5
GO TO 40
34 XT=XT+.5
40 IF(YT)42,44,44
42 YT=YT-.5
GO TO 50
44 YT=YT+.5
50 XT=CGWHL(XT)
YT=CGWHL(YT)
XM=XT-XPINC
YM=YT-YPINC
IFIT=1
IF(XT)90,62,62
62 IF(YT)90,64,64
64 IF(XT-DFLOAT(IPAPR)*INCPI)66,66,90
66 IF(YT-DFLOAT(JPAPR)*INCPI)900,900,90
90 IFIT=0
900 RETURN
END
SUBROUTINE CGPIN(XA,YA,XB,YB,XC,YC,XD,YD,XI,YI)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CALL CGCLR(XI,YI)
XBA=XB-XA
YBA=YB-YA
XDC=XD-XC
YDC=YD-YC
XDYB=XDC*YBA
XBYD=XBA*YDC
DENOM=XDYB-XBYD
IF(ABS(DENOM/SQRT((XBA*XBA+YBA*YBA)*(XDC*XDC+YDC*YDC)))-
*.484813681E-4)900,20,20
20 XI=(XA*XDYB-XC*XBYD+(YC-YA)*XBA*XDC)/DENOM
YI=(YC*XDYB-YA*XBYD+(XA-XC)*YBA*YDC)/DENOM
900 RETURN
END
SUBROUTINE CGPLA
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION KAR(45),KCARS(12)
DIMENSION ZLABL(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C * * COMMON STATEMENTS BELOW ADDED AUGUST 1973 - LGB
C * * (VARIABLES OCCUPY SPACE IN COMMON ARRAY 'KMMON' DEFINED IN THE
C * * 'COGO' MAINLINE.)
COMMON ANSIZ,JBRAZ,NPLTR
C * (ANNOT. HGT. IN INCHES,BEAR/AZM CODE,PLOTTER NUMBER)
EQUIVALENCE(ZLABL(1),XLABL),(ZLABL(2),YLABL)
DATA KAR( 1)/2040/,KAR( 2)/5155/,KAR( 3)/4626/,KAR( 4)/1511/
DATA KAR( 5)/2025/,KAR( 6)/3630/,KAR( 7)/2040/,KAR( 8)/1526/
DATA KAR( 9)/4655/,KAR( 10)/5411/,KAR( 11)/1050/,KAR( 12)/1526/
DATA KAR( 13)/4655/,KAR( 14)/5443/,KAR( 15)/3343/,KAR( 16)/5251/
DATA KAR( 17)/4020/,KAR( 18)/1140/,KAR( 19)/4612/,KAR( 20)/5211/
DATA KAR( 21)/2040/,KAR( 22)/5153/,KAR( 23)/4414/,KAR( 24)/1656/
DATA KAR( 25)/1343/,KAR( 26)/5251/,KAR( 27)/4020/,KAR( 28)/1114/
DATA KAR( 29)/3646/,KAR( 30)/1656/,KAR( 31)/2023/,KAR( 32)/1415/
DATA KAR( 33)/2646/,KAR( 34)/5554/,KAR( 35)/4323/,KAR( 36)/1211/
DATA KAR( 37)/2040/,KAR( 38)/5152/,KAR( 39)/4320/,KAR( 40)/3052/
DATA KAR( 41)/5546/,KAR( 42)/2615/,KAR( 43)/1423/,KAR( 44)/5312/
DATA KAR( 45)/5200/
DATA KCARS/ 1, 10, 15, 23, 36, 40, 49, 59, 62, 78, 88, 90/
C REAL NUMBER TRUNCATION
C GET UNITS DIGIT FROM A REAL NUMBER
JDU(VALUE)=ABS(VALUE-CGWHL(VALUE/10.)*10.)
C PLOT GRID IF A MAP IS IN PROGRESS
IF(SFPI)94800,94800,94000
C SUPPRESS GRID IF ANY DATA PRESENT
94000 IF(ND)94020,94020,94800
C PLOT GRID
94020 CONTINUE
C COMPUTE SIZE OF CHARACTERS FOR PLOTTING
KARSZ=INCPI/10
C COMPUTE MAX NUMBER OF GRID POINTS IN A ROW
MXGPS=(IPAPR+JPAPR)/GRID
C COMPUTE GRID SIZE IN FEET
GRIF=CGWHL(GRID*SFPI+.5)
C SET SWITCH - ARROW NOT PLOTTED YET
KAROW=0
C INITIALIZE 0.2 INCH CROSS
COSCR=INCPI/10*COS(ROT-AZEZ)
IF(COSCR)220,230,230
220 COSCR=COSCR-.5
GO TO 240
230 COSCR=COSCR+.5
240 COSCR=CGWHL(COSCR)
SINCR=INCPI/10*SIN(ROT-AZEZ)
IF(SINCR)260,270,270
260 SINCR=SINCR-.5
GO TO 280
270 SINCR=SINCR+.5
280 SINCR=CGWHL(SINCR)
C INITIALIZE SCANNING DIRECTIONS
XPD=0.
YPD=0.
IF(ROT-HFPI)94062,94064,94064
94062 XPD=-GRIF
GO TO 94080
94064 IF(ROT-PI)94066,94068,94068
94066 YPD=GRIF
GO TO 94080
94068 IF(ROT-(PI+HFPI))94070,94072,94072
94070 XPD=GRIF
GO TO 94080
94072 YPD=-GRIF
94080 XSD=YPD
YSD=XPD
C INITIALIZE LOOP TO PLOT GRID INTERSECTIONS
C FIND THE GRID POINT NEAREST CORNER OF MAP
X=((XORG+IPAPR*SFPI)*COS(ROT)+(YORG+JPAPR*SFPI)*SIN(ROT)+XLP)/GRIF
IF(X)94122,94123,94123
94122 X=X-.5
GO TO 94124
94123 X=X+.5
94124 X=CGWHL(X)*GRIF-XLP
Y=((YORG+JPAPR*SFPI)*COS(ROT)-(XORG+IPAPR*SFPI)*SIN(ROT)+YLP)/GRIF
IF(Y)94126,94127,94127
94126 Y=Y-.5
GO TO 94128
94127 Y=Y+.5
94128 Y=CGWHL(Y)*GRIF-YLP
C FIND FIRST GRID POINT TO PLOT
CALL CGPFM(X,Y,XM,YM,IFIT)
IF(IFIT)94140,94140,94230
94140 CALL CGPFM(X-XSD,Y-YSD,XM,YM,IFIT)
IF(IFIT)94160,94160,94240
94160 X=X+XSD
Y=Y+YSD
CALL CGPFM(X,Y,XM,YM,IFIT)
IF(IFIT)94210,94210,94230
C FIND NEXT GRID POINT TO PLOT
94200 X=X+XSD
Y=Y+YSD
CALL CGPFM(X,Y,XM,YM,IFIT)
IF(IFIT)94210,94210,94264
94210 X=X+XPD
Y=Y+YPD
94220 CALL CGPFM(X,Y,XM,YM,IFIT)
IF(IFIT)94240,94240,94230
94230 X=X+XSD
Y=Y+YSD
GO TO 94220
94240 XSD=-XSD
YSD=-YSD
DO 94249 I=1,MXGPS
X=X+XSD
Y=Y+YSD
CALL CGPFM(X,Y,XM,YM,IFIT)
IF(IFIT)94249,94249,94264
94249 CONTINUE
GO TO 7490
94264 CONTINUE
C YES - PLOT A GRID POINT
C MOVE PEN TO 90 DEG END OF CROSS
265 CALL CGPMV(XM+SINCR,YM-COSCR)
C LOWER PEN AND MOVE -90 DEG .2 INCHES
CALL CGPDN
CALL CGPMV(-2.*SINCR,2.*COSCR)
C RAISE PEN AND MOVE 180 DEG .1 INCHES AND
C *90 DEG .1 INCHES
CALL CGPUP
CALL CGPMV(SINCR-COSCR,-COSCR-SINCR)
C LOWER PEN AND MOVE ZERO DEG .2 INCHES
CALL CGPDN
CALL CGPMV(2.*COSCR,2.*SINCR)
C HAS ARROW BEEN PLOTTED
IF(KAROW)7460,7460,266
C MAKE SURE COORDS WILL FIT
7460 IF(XPINC-KARSZ*20)266,7461,7461
C FIND COORDS OF 1.5 INCH ARROW TIP
7461 CALL CGXTL(X,Y,-AZEZ,1.5D0*SFPI,XP,YP)
CALL CGPFM(XP,YP,XM,YM,IFIT)
IF(IFIT)266,266,7462
C DRAW ARROW SHANK
7462 CALL CGPMV(XM,YM)
C DRAW ARROW HEAD
CALL CGXTL(X,Y,.3D0-AZEZ,.5D0*SFPI,XP,YP)
CALL CGPFM(XP,YP,XM,YM,IFIT)
CALL CGPMV(XM,YM)
C DRAW LINE BACK TO SHANK
CALL CGXTL(X,Y,-AZEZ,.65D0*SFPI,XP,YP)
CALL CGPFM(XP,YP,XM,YM,IFIT)
CALL CGPMV(XM,YM)
C LABEL COORDS OF GRID INTERSECTION
CALL CGPFM(X,Y,XM,YM,IFIT)
K=INCPI/10
IF(YM)7466,7466,7468
7466 K=-INCPI/4
7468 INC=-XM
JNC=-IFIX(SNGL(YM))-K
XPINC=XPINC-INC
YPINC=YPINC-JNC
XLABL=(X+XLP)*ISGX
YLABL=(Y+YLP)*ISGY
IXYL=3-IXYF
C START ROUTINE TO LABEL ARROW WITH COORDS
C A=Y COORD OF GRID POINT WITH ARROW
A=ZLABL(IXYL)
C INITIALIZE DIGIT POINTER TO UNITS DIGIT
7481 T=1.
C LOCATE CODE FOR THIS DIGIT
7471 ICAR=1+JDU(A/T)
7489 NSS=KCARS(ICAR+1)
NSSE=KCARS(ICAR)
C * * * STATEMENT BELOW CHANGED 07/27/72 - LGB
C*** KPEN=2
KPEN=1
INC=INC+KARSZ
XPINC=XPINC-KARSZ
C PLOT THE DIGIT (7478-7477+1)
C PLOT THE DIGIT (BACKWARDS)
7478 NSS=NSS-1
IF(NSS-NSSE)7479,7472,7472
C EXTRACT NEXT PEN MOVEMENT FROM CODE
7472 I=(NSS+1)/2
JP=KAR(I)/100
IF(2*I-NSS)7473,7474,7473
7474 JP=KAR(I)-JP*100
7473 IP=JP/10
JP=JP-IP*10
C DRAW ONE SEGMENT OF CHARACTER
INX=(IP*KARSZ+2)/5
JNX=(JP*KARSZ+2)/5
CALL CGPLT(KPEN,INX-INC,JNX-JNC)
INC=INX
JNC=JNX
C * * * STATEMENT BELOW CHANGED 07/27/72 - LGB
C*** KPEN=-KPEN/2
KPEN = (-1)
GO TO 7478
C THIS CHAR PLOTTED
C ADVANCE DIGIT POINTER
7479 T=T*10.
C HAS HIGH ORDER DIGIT BEEN PLOTTED
IF (IFIX(SNGL(A/T)))7471,7486,7471
C YES - IS COORD NEGATIVE
7486 IF (A) 7487,7480,7480
C YES - SET COORD TO 1 SO ROUTINE WILL NOT
C FIND COORD NEG AGAIN
7487 A=1.
C SET UP CODE FOR MINUS SIGN
ICAR=11
C PLOT MINUS SIGN
GO TO 7489
C WAS THIS EAST OR NORTH
7480 IF(KAROW)7482,7482,7488
C EAST - NOW PLOT NORTH
7482 KAROW=1
C SPACE BETWEEN COORDINATES
INC=INC+KARSZ
XPINC=XPINC-KARSZ
C COMPUTE OTHER COORD OF GRID POINT
A=ZLABL(IXYF)
C GO PLOT OTHER COORD, RETURN TO 266
GO TO 7481
C UPDATE PEN PSN AFTER PLOTTING CHARS
7488 XPINC=XPINC+INC
YPINC=YPINC+JNC
266 CALL CGPUP
GO TO 94200
C END OF LOOP TO PLOT GRID INTERSECTIONS
C GO PLOT CROSS AT CHECK POINT
7490 CALL CGPMV(-XPINC,-YPINC)
K=INCPI/20
MTWOK=-K-K
CALL CGPLT(-1,K,0)
CALL CGPLT(0,MTWOK,0)
CALL CGPLT(0,K,0)
CALL CGPLT(0,0,K)
CALL CGPLT(0,0,MTWOK)
CALL CGPLT(0,0,K)
CALL CGPUP
C MOVE TO (END OF MAP + 1 INCH,RIGHT HAND STOP)
C UNLESS THIS IS A FLATBED PLOTTER
A=-YPINC
IF(IABS(KPLEJ).EQ.3) GO TO 94782
C--- DRUM PLOTTER - MOVE TO (END OF MAP +1 INCH,
C--- AND RIGHT HAND STOP)
CALL CGPMV(DFLOAT(IPAPR)*INCPI+INCPI-XPINC,A)
GO TO 94800
C--- FLATBED PLOTTER - DO GENUINE NEWMAP (CALCOMP TYPE)
94782 CALL NEWMAP
C RESET PLOTTING PARAMETERS FOR NEW MAP
94800 XLP=CLEAR
KRSZN=INCPI/10
NMSZN=INCPI/10
KRSZC=INCPI/10
NMSZC=INCPI/10
NPREC=0
SFPI=0.
JBRAZ = 0
ANSIZ = 0.08
C IF TABLE AND PLOT FILE WERE SHARING WS,
C *RETURN ENTIRE WS TO TABLE.
IF(KFTB-KFWS)94900,94880,94900
94880 LFILE=(1600-KFWS)*53.
LUNU=LFILE-(LHDRS+LCDA+LFGA)
94900 IF(IDITO-4)30,31,900
31 IF(IFIX(SNGL(SFPI*1000.))) 32,30,32
32 CALL CGPLT(999,0,0)
C RETURN FROM END OF JOB OR END OF RUN COMMAND
C 30 CALL CGMIX
30 CONTINUE
RETURN
C RETURN FROM NEW MAP COMMAND
900 CALL RTNONE
RETURN
END
SUBROUTINE CGPLB
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL XNOW,YNOW,FNOW,X,Y
DIMENSION NPOFS(6)
DIMENSION IPBUF(10)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(IPBUF(1),N),(IPBUF(4),XN),(IPBUF(6),YN),
* (IPBUF(8),KVUD),(IPBUF(9),KRSZ),(IPBUF(10),NMSZ)
DATA TRIES/100./
DATA NPOFM/6/
C GET A DIGIT FROM AN INTEGER
JDI(NUM,NTENS)=IABS(NUM/NTENS-NUM/NTENS/10*10)
C REAL NUMBER TRUNCATION
C PLOT/POINT PLOT/LINE
7600 CONTINUE
7700 CONTINUE
C RAISE PEN IN CASE OPERATOR LEFT IT DOWN
CALL CGPUP
C IS THIS INITIAL CALL OR IS IT RETURN FROM CGPLC
IF(DATA(12))77010,77010,77004
77004 KTF=DATA(12)
DATA(12)=0.
GO TO 77040
77010 KTF=0
77040 LOR=0
C IUD=NEG... PREV PNT NOT PLOTTED. PEN IS UP.
C IUD=ZERO... PREV PNT PLOTTED. PEN IS UP.
C IUD=POS... PREV PNT PLOTTED. PEN IS DOWN.
C IUD=ZERO DURING FIRST PNT OR DURING CC OR
C CURVE OR PT OR DURING PNT WITH NO LINE
C TO IT... PEN IS UP.
IUD=0
NPOF=0
C GET NEXT POINT NUMBER
77050 CONTINUE
77052 PLOR=LOR
XP=XN
YP=YN
XIP=XIN
YIP=YIN
IF(KTF-NPREC)77056,77900,77900
77056 KTF=KTF+1
CALL CGDBF(KFPL,10,0,KTF,IPBUF)
IF(N)77057,77057,77062
77057 DATA(12)=KTF
CALL CGPUP
IF(NPOF)77059,77059,77058
77058 WRITE(MOUT,77653)(NPOFS(I),I=1,NPOF)
77059 CALL CGPLC
77062 LOR=0
IF(KVUD)77064,77280,77150
C THIS IS A CC
77064 LOR=KVUD/1000
C SET TICK MARK SIZE
TIKSZ=(LOR*1000-KVUD)*SFPI/INCPI
C SET CURVE DIRECTION
LOR=-LOR-2
C SET SW INDICATING IF CC IS TO BE PLOTTED
ICCPL=KRSZ+NMSZ
C FIND AZ FROM CC TO PC
CALL CGINV(XN,YN,XP,YP,AZCPC,RAD)
C GO PLOT CC IF IT HAS A CROSS OR LABEL
IF(ICCPL)77050,77050,77280
C IS THIS A PT
77150 IF(PLOR)77200,77300,77200
C YES - PLOT CURVE
77200 IF(ICCPL+TIKSZ)77204,77204,77201
77201 IF(IUD)77204,77204,77202
77202 CALL CGPUP
IUD=0
C FIND AZ FROM CC TO PT
77204 CALL CGINV(XP,YP,XN,YN,AZCPT,RAD)
C ADJUST IT IF ARC CROSSES DUE NORTH
IF((AZCPT-AZCPC)*PLOR)77210,77210,77220
77210 AZCPT=AZCPT+TWOPI*PLOR
C SET CHORD LENGTH FOR PEN UP AND DOWND
77220 DAZUP=(AZCPT-AZCPC)/TRIES
DAZDN=SQRT(SFPI/INCPI/RAD)*PLOR
C FIRST POINT IS ACTUALLY TIP OF TICK MARK
RAP=RAD-TIKSZ
C PLOT A POC IF IT IS ON THE PAPER
77230 CALL CGPFM(
*XP+RAP*COS(AZCPC),YP+RAP*SIN(AZCPC),XM,YM,IFIT)
IF(IFIT)77240,77240,77250
C POC IS OFF - WAS PREV POC PLOTTED
77240 IF(IUD)77244,77244,77242
C YES - RAISE PEN
77242 CALL CGPUP
IUD=0
C IS THIS THE START OF THE PC TICK MARK
77244 IF(RAP-RAD)77245,77248,77248
C YES - IS IT POSSIBLE FOR ANY OF THIS CURVE
C TO BE ON THE PAPER
C IF SO, CC WILL BE LESS THAN 1 RAD FROM PAPER
77245 CALL CGPFM(XP,YP,XM,YM,IFIT)
C CHECK X DISTANCE FROM PAPER CENTER TO CC
IF(ABS((XPINC+XM)/INCPI-IPAPR/2)-IPAPR/2+RAD/SFPI)
* 77247,77247,77290
C CHECK Y DISTANCE FROM PAPER CENTER TO CC
77247 IF(ABS((YPINC+YM)/INCPI-JPAPR/2)-JPAPR/2+RAD/SFPI)
* 77254,77254,77290
C COMPUTE NEXT POC
77248 AZCPC=AZCPC+DAZUP
GO TO 77258
C POC IS ON - WAS PREV POC PLOTTED
77250 CALL CGPMV(XM,YM)
IF(IUD)77252,77252,77256
C NO - LOWER PEN
77252 CALL CGPDN
IUD=1
C IS THIS THE START OF THE PC TICK MARK
IF(RAP-RAD)77254,77256,77256
C YES - NOW PLOT PC (RAP=RAD, AZCPC NOT CHANGED)
77254 RAP=RAD
GO TO 77258
C COMPUTE NEXT POC
77256 AZCPC=AZCPC+DAZDN
C HAS LAST POC BEEN PLOTTED
77258 IF((AZCPT-AZCPC)*PLOR)77260,77230,77230
C YES - PLOT PT - DOES IT FIT
77260 CALL CGPFM(XN,YN,XM,YM,IFIT)
IF(IFIT)77280,77280,77264
C YES - WAS PREV POC PLOTTED
77264 CALL CGPMV(XM,YM)
IF(IUD)77266,77266,77270
C NO - LOWER PEN
77266 CALL CGPDN
IUD=1
C DRAW TICK MARK
77270 IF(TIKSZ)77290,77290,77272
77272 CALL CGPFM(
*XN-COS(AZCPT)*TIKSZ,YN-SIN(AZCPT)*TIKSZ,XM,YM,IFIT)
CALL CGPMV(XM,YM)
C END OF CURVE ROUTINE
C RAISE PEN IF IT IS DOWN
77280 IF(IUD)77290,77290,77282
77282 CALL CGPUP
IUD=0
77290 CONTINUE
GO TO 77400
C DRAW LINE TO POINT
C CHECK PREVIOUS POINT
77300 IF(IUD)77302,77360,77400
C PREV POINT OFF PAPER - LOOK FOR POL ON PAPER
C GET PLOTTER COORDINATES OF THIS POINT
77302 CALL CGPFM(XN,YN,XM,YM,IFIT)
XIN=XPINC+XM
YIN=YPINC+YM
XE=0.
IF(XIN-XIP)77304,77312,77305
77304 XE=DFLOAT(IPAPR)*INCPI
77305 IF((XIN-XE)*(XE-XIP))77312,77306,77306
77306 YE=(YIN-YIP)/(XIN-XIP)*(XE-XIP)+YIP
IF(YE)77312,77308,77308
77308 IF(YE-DFLOAT(JPAPR)*INCPI)77319,77319,77312
77312 YE=0.
IF(YIN-YIP)77314,77600,77315
77314 YE=DFLOAT(JPAPR)*INCPI
77315 IF((YIN-YE)*(YE-YIP))77600,77316,77316
77316 XE=(XIN-XIP)/(YIN-YIP)*(YE-YIP)+XIP
IF(XE)77600,77318,77318
77318 IF(XE-DFLOAT(IPAPR)*INCPI)77319,77319,77600
77319 XIP=CGWHL(XE+.5)
YIP=CGWHL(YE+.5)
C POL ON PAPER FOUND OR PREV POINT ON PAPER
77360 CALL CGPMV(XIP-XPINC,YIP-YPINC)
CALL CGPDN
IUD=1
C PLOT THIS POINT - DOES IT FIT
77400 CALL CGPFM(XN,YN,XM,YM,IFIT)
XIN=XPINC+XM
YIN=YPINC+YM
IF(IFIT)77600,77600,77500
C YES - MOVE THE PEN TO THE POINT
77500 CALL CGPMV(XM,YM)
C IS A CROSS TO BE PLOTTED
IF(KRSZ)77504,77504,77508
77504 IF(IUD)77506,77524,77524
C SET SW - PREVIOUS POINT PLOTTED
77506 IUD=0
GO TO 77524
C YES - LOWER PEN IF IT IS UP
77508 IF(IUD)77510,77510,77520
77510 CALL CGPDN
C SET SWITCH- PREV POINT WAS PLOTTED. PEN IS DOWN.
77520 IUD=1
KRSHF=KRSZ/2
C DRAW CROSS
KRSWL=-KRSHF-KRSHF
CALL CGPLT(0,KRSHF,0)
CALL CGPLT(0,KRSWL,0)
CALL CGPLT(0,KRSHF,0)
CALL CGPLT(0,0,KRSHF)
CALL CGPLT(0,0,KRSWL)
CALL CGPLT(0,0,KRSHF)
C IS POINT TO BE LABELED
77524 IF(NMSZ)77050,77050,77526
77526 CONTINUE
C DETERMINE NUMBER OF DIGITS TO BE PLOTTED
NDIGIT=0
50 NDIGIT=NDIGIT+1
IF(N/10**NDIGIT.NE.0) GO TO 50
C GET PRESENT PEN POSITION
CALL WHERE(XNOW,YNOW,FNOW)
C COMPUTE START OF CHARACTER STRING
X=XNOW-FLOAT(NMSZ*NDIGIT)/FLOAT(INCPI)-0.04
Y=YNOW+0.04
CALL NUMBER(X,Y,FLOAT(NMSZ)/FLOAT(INCPI),FLOAT(N),0.0,-1)
C RETURN TO STARTING POSITION
CALL PLOTT(XNOW,YNOW,3)
C SET PEN UP INDICATOR
IUD=0
GO TO 77050
C GO GET NEXT POINT
C IF YES, GO GET NEXT POINT TO PLOT
C THIS POINT DOES NOT FIT
C WAS PREV POINT OR POL PLOTTED
77600 IF(IUD)77630,77630,77602
C YES - LOOK FOR POL ON PAPER
77602 XE=0.
IF(XIN-XIP)77605,77612,77604
77605 IF((XIN-XE)*(XE-XIP))77612,77606,77606
77604 XE=DFLOAT(IPAPR)*INCPI
77606 YE=(YIN-YIP)/(XIN-XIP)*(XE-XIP)+YIP
IF(YE)77612,77608,77608
77608 IF(YE-DFLOAT(JPAPR)*INCPI)77619,77619,77612
77612 YE=0
IF(YIN-YIP)77615,77624,77614
77614 YE=DFLOAT(JPAPR)*INCPI
77615 IF((YIN-YE)*(YE-YIP))77624,77616,77616
77616 XE=(XIN-XIP)/(YIN-YIP)*(YE-YIP)+XIP
IF(XE)77624,77618,77618
77618 IF(XE-DFLOAT(IPAPR)*INCPI)77619,77619,77624
77619 XM=CGWHL(XE+.5)-XPINC
YM=CGWHL(YE+.5)-YPINC
CALL CGPMV(XM,YM)
77624 CALL CGPUP
77630 IUD=-1
IF(NPOF-NPOFM)77656,77652,77652
77652 WRITE(MOUT,77653)NPOFS
77653 FORMAT(' #####','OFF PAPER',I4,5I5)
NPOF=0
77656 NPOF=NPOF+1
NPOFS(NPOF)=N
GO TO 77050
77900 CALL CGPUP
IF(NPOF)900,900,77910
77910 WRITE(MOUT,77653)(NPOFS(I),I=1,NPOF)
900 CALL CGPLD
RETURN
END
SUBROUTINE CGPLC
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IPBUF(10)
DIMENSION LINE(80)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(IPBUF(1),N),(IPBUF(4),XN),(IPBUF(6),YN),
* (IPBUF(8),KVUD),(IPBUF(9),KRSZ),(IPBUF(10),NMSZ)
C REAL NUMBER TRUNCATION
C
CHHGT = 0.120
KARSZ=INCPI/10
KTF=DATA(12)
CALL CGDBF(KFPL,10,0,KTF,IPBUF)
XNS=XN
YNS=YN
IS=KVUD
JS=KRSZ
KARS=NMSZ
KOL=0
7514 IF(KOL-KARS)7516,7520,7520
7516 KTF=KTF+1
CALL CGDBF(KFPL,10,0,KTF,IPBUF)
DO 7519 I=2,10
KOL=KOL+1
7519 LINE(KOL)=IPBUF(I)
GO TO 7514
7520 CONTINUE
C PLOT/COMMENT
C GET PLOTTER COORDS FOR START OF COMMENT
7522 IF(XNS-CLEAR)7540,7530,7530
C STARTING POINT NOT GIVEN
C DISTANCES GIVEN ARE FROM PAPER EDGE
7530 X=IS
IF(IS)7531,7532,7532
7531 X=DFLOAT(IPAPR)*INCPI+IS
7532 Y=JS
IF(JS)7533,7534,7534
7533 Y=DFLOAT(JPAPR)*INCPI+JS
7534 IF(X)7593,7535,7535
7535 IF(X+INCPI/10*KARS-DFLOAT(IPAPR)*INCPI)7536,7536,7593
7536 IF(Y)7593,7537,7537
7537 IF(Y-DFLOAT(JPAPR)*INCPI)7538,7538,7593
7538 XM=X-XPINC
YM=Y-YPINC
GO TO 7543
C STARTING POINT GIVEN
7540 CALL CGPFM(
*XNS+IS*SFPI/INCPI,YNS+JS*SFPI/INCPI,XM,YM,IFIT)
C MAKE SURE ENDS OF COMMENT WILL FIT
IF(IFIT)7593,7593,7542
7542 IF(XPINC+XM+INCPI/10*KARS-DFLOAT(IPAPR)*INCPI)7543,7543,7593
7593 WRITE(MOUT,7594)
7594 FORMAT(' #####','COMMENT OFF PAPER')
GO TO 880
C
C * PLOT COMMENT
7543 CALL CGPLE(
*XM,YM+INCPI/50,CHHGT ,0.0,LINE,KARS)
GO TO 880
C
880 DATA(12)=KTF
900 CALL CGPLB
RETURN
END
SUBROUTINE CGPLD
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C * * PASS PLOT FILE AND ANNOTATE LINES AND ARCS IF REQUESTED
C
C
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C * * COMMON STATEMENTS BELOW ADDED AUGUST 1973 - LGB
C * * (VARIABLES OCCUPY SPACE IN COMMON ARRAY 'KMMON' DEFINED IN THE
C * * 'COGO' MAINLINE.)
COMMON ANSIZ,JBRAZ,NPLTR
C * (ANNOT. HGT. IN INCHES,BEAR/AZM CODE,PLOTTER NUMBER)
C
DIMENSION KQUAD(4),LQUAD(4)
DIMENSION IBUF(10),JBUF(10),KBUF(10)
DIMENSION LBUF(20),MBUF(20),NBUF(20)
DIMENSION ISYM(20,3),NCLN(3)
C
EQUIVALENCE (LBUF(1),ISYM(1,1)),(MBUF(1),ISYM(1,2)),
1 (NBUF(1),ISYM(1,3))
EQUIVALENCE (NPZ,IBUF(1)),(XT,IBUF(4)),(YT,IBUF(6)),
1 (KVUD,IBUF(8))
EQUIVALENCE (XF,JBUF(4)),(YF,JBUF(6))
EQUIVALENCE (XC,KBUF(4)),(YC,KBUF(6))
C
EQUIVALENCE (IBLNK,LBUF(1)),(LBUF2,LBUF(2)),(LBUF3,LBUF(3)),
1 (MBUF2,MBUF(2)),(MBUF3,MBUF(3)),(KBUF8,KBUF(8))
EQUIVALENCE (NBUF2,NBUF(2))
C
EQUIVALENCE (NCLN1,NCLN(1)),(NCLN2,NCLN(2)),(NCLN3,NCLN(3))
C
DATA KC440,KD940,KD340/'D','R','L'/
DATA LBUF,MBUF,NBUF/ 60 * ' ' /
DATA KQUAD,LQUAD/ 'N','N','S','S','E','W','W','E' /
C
C
C * * EXIT IF NO ANNOTATION
IF(JBRAZ)900,900,5
5 IF(NPREC)900,900,10
C
C * * INITIALIZE
10 KTF = 1
PIHF = PI+HFPI
ANHFT = ANSIZ*SFPI
ANWFT = ANHFT/1.2
C
C * * GET FIRST PLOT RECORD INTO IBUF
CALL CGDBF(KFPL,10,0,KTF,IBUF)
C
C * * BEGIN MAIN LOOP
25 DO 30 I=1,10
JBUF(I) = IBUF(I)
30 CONTINUE
C
C
35 ICV = 2
40 KTF = KTF+1
IF(KTF-NPREC)50,50,900
50 CALL CGDBF(KFPL,10,0,KTF,IBUF)
IF(NPZ)25,25,55
55 IF(KVUD)60,25,75
C
C
C * * CURVE CENTER FOUND
60 DO 65 I=1,10
KBUF(I) = IBUF(I)
65 CONTINUE
ICV = 1
GO TO 40
C
C
C * * LINE OR ARC REQUIRED - SEE IF LINE OR ARC CHORD ON PAPER
75 CALL CGPFM(XF,YF,XB,YB,IFIT)
CALL CGPFM(XT,YT,XD,YD,INDXX)
IF(IFIT+INDXX-2)25,80,25
C
C * * ON PAPER - GET PARAMETERS
80 CALL CGINV(XF,YF,XT,YT,ANGLE,DIST)
PANG = ANGLE
PANG2 = CGNRM(PANG-HFPI)
YOFF = 1.5 * ANHFT
YOINC = YOFF
XOFF = 1.0
GO TO(200,100),ICV
C
C
C * * SET UP TO PUT BEAR/AZM AND DISTANCE ON LINE
C * * CONVERT CCW FROM +X TO CW FROM NORTH
100 ANGLE = CGNRM(TWOPI+HFPI-ANGLE)
C * * CONVERT TO BEARING OR SOUTH AZIMUTH IF REQUIRED
GO TO(140,120,110),JBRAZ
C * * SOUTH AZIMUTH
110 ANGLE = CGNRM(ANGLE-PI)
GO TO 140
C * * BEARING
120 NQSW = 1
IF(ANGLE-HFPI)139,139,125
125 ANGLE = ANGLE-PI
IF(ANGLE)136,136,130
130 IF(ANGLE-HFPI)137,135,135
135 ANGLE = PI-ANGLE
GO TO 138
136 NQSW = NQSW+1
137 NQSW = NQSW+1
138 NQSW = NQSW+1
139 ANGLE = ABS(ANGLE)
C
LBUF2 = KQUAD(NQSW)
INDXX = 3
GO TO 145
C
C * * CONVERT BEAR/AZM TO SYMBOL STRING
140 INDXX = 2
145 CALL CGASY(ANGLE,LBUF,INDXX)
IF(JBRAZ-2)400,148,400
148 LBUF(INDXX) = LQUAD(NQSW)
INDXX = INDXX+1
GO TO 400
C
C * * CONVERT DISTANCE TO SYMBOL STRING
150 CALL CGFSY(DIST,MBUF,INDXX)
GO TO 410
C
C
C * * SET UP TO PUT DLTA,RAD,ARCLN ON ARC CHORD
200 ICCSW = KBUF8/1000 + 2
CALL CGINV(XC,YC,XF,YF,BANG,RAD)
CALL CGINV(XC,YC,XT,YT,EANG,RAD)
IF(ICCSW)205,900,210
C * * CCW
205 DANG = CGNRM(EANG-BANG)
GO TO 215
C * * CW
210 DANG = CGNRM(BANG-EANG)
215 ARCL = RAD * DANG
C
C * * GET PANG2 SET TOWARDS CTR PT
PANG3 = CGNRM( EANG + DANG/2.0*DFLOAT(ICCSW)+PI)
C
C * * IF PANG3 OPPOSITE TO PANG2, MODIFY YOFF AND YOINC
IF( ABS(PANG2-PANG3) - HFPI )225,900,220
220 YOFF = 3.5 * ANHFT
YOINC = -YOINC
225 PANG2 = PANG3
C
C * * CONVERT DELTA ANGLE TO SYMBOL STRING
LBUF2 = KC440
LBUF3 = IBLNK
INDXX = 4
CALL CGASY(DANG,LBUF,INDXX)
GO TO 400
C
C * * CONVERT RADIUS TO SYMBOL STRING
240 MBUF2 = KD940
MBUF3 = IBLNK
CALL CGFSY(RAD,MBUF,INDXX)
GO TO 410
C
C * * CONVERT ARC LENGTH TO SYMBOL STRING
250 NBUF2 = KD340
CALL CGFSY(ARCL,NBUF,INDXX)
NBUF(INDXX) = IBLNK
NCLN3 = INDXX
C
C * * REVERSE PLOTTING ANGLE TO MAKE READABLE FROM BOTTOM IF NECESSARY
300 CALL CGINV(XB,YB,XD,YD,PANG4,PD)
IF(PANG4-HFPI)305,301,301
301 IF(PANG4-PIHF)302,305,305
302 PANG4 = CGNRM(PANG4+PI)
PANG = CGNRM(PANG +PI)
XOFF = -XOFF
YOINC = -YOINC
YOFF = YOFF + 0.5*ANHFT
GO TO(303,305),ICV
303 YOFF = YOFF + 1.5*ANHFT
IF(YOFF - 4.0*ANHFT)305,304,304
304 YOFF = 1.5*ANHFT
C
C
C * * GET BEGINNING POINT FOR ANNOTATION
305 XOFF = XOFF * DIST/2.0 - ANTOT/2.0
CALL CGXTL(XF,YF,PANG,XOFF, XB,YB)
C
C * * SEE IF ANNOTATION BOX COMPLETELY INSIDE
CALL CGXTL(XB,YB,PANG2,ANHFT/2.0D0,XD,YD)
IFIT =0
315 CALL CGPFM(XD,YD,XM,YM,JFIT)
IF(JFIT)25,25,319
319 IFIT = IFIT+1
GO TO(320,330,340,350),IFIT
320 CALL CGXTL(XD,YD,PANG,ANTOT,XD,YD)
GO TO 315
330 CALL CGXTL(XD,YD,PANG2,ANHFT*4.0D0,XD,YD)
GO TO 315
340 CALL CGXTL(XB,YB,PANG2,ANHFT*4.5D0,XD,YD)
GO TO 315
C
C * * DO THE PLOTTING
350 JL = 4-ICV
DO 360 J= 1,JL
CALL CGXTL(XB,YB,PANG2,YOFF,XD,YD)
CALL CGPFM(XD,YD,XM,YM,IFIT)
CALL CGPLE(XM,YM,ANSIZ,PANG4,ISYM(1,J),NCLN(J))
YOFF = YOFF + YOINC
360 CONTINUE
GO TO 25
C
C
C
C * * BYPASS ANNOTATION IF LINE 1 TOO LONG
400 ANTOT = ANWFT*DFLOAT(INDXX)
IF(ANTOT-DIST)405,405,25
405 LBUF(INDXX) = IBLNK
NCLN1 = INDXX
INDXX = 6 - 2*ICV
GO TO(240,150),ICV
C
C
410 MBUF(INDXX) = IBLNK
NCLN2 = INDXX
INDXX = 4
GO TO(250,300),ICV
C
C
900 NPREC = 0
CALL RTNONE
RETURN
C
END
SUBROUTINE CGPLE(XM,YM,HGT,ANG,LINE,NCH)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
C SET UP STANDARD PRECISION REALS FOR DUMMY ARGUMENTS
REAL X,Y,XNOW,YNOW
DIMENSION LINE(80)
C
C * XM,Y, - DELTA INCREMENTS FROM CURR. POSITION TO LEFT
C * END OF SYMBOL STRING.
C * HGT - CHAR. HEIGHT IN INCHES (WDH=HGT/1.2).
C * ANG - PLOTTING ANGLE IN CCW RADIANS FROM +X
C * LINE- ARRAY CONTAINING A1 CHARACTER STRING (SEE DATA
C * STATEMENT 'MCARS' FOR VALID CHARACTERS. ALL OTHERS
C * PLOTTED AS BLANKS).
C * NCH - NUMBER OF CHARACTERS IN 'LINE'.
C * INCPI - INCREMENTS PER INCH FROM COGO COMMON
C *
C
C DETERMINE THE PRESENT PEN LOCATION
CALL WHERE(XNOW,YNOW,X)
C GET STARTING X AND Y COORDINATE FOR SYMBOL
X=XNOW+SNGL(XM)/FLOAT(INCPI)
Y=YNOW+SNGL(YM)/FLOAT(INCPI)
C SET UP STRING IN A5 FORMAT
ENCODE(NCH,102,IN) (LINE(J),J=1,NCH)
102 FORMAT(80A1)
CALL SYMBOL(X,Y,SNGL(HGT),IN,SNGL(ANG)*360.0/SNGL(TWOPI),NCH)
C MOVE BACK TO STARTING POSITION
CALL PLOTT(XNOW,YNOW,3)
RETURN
END
SUBROUTINE CGPLT(N,IX,IY)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C THIS SUBROUTINE IS TO PROVIDE COMPATABILITY WITH THE SELLS
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C VERSION 3 COGO PLOTTING ROUTINE
C N - IS A PEN CONTROL INDICATOR AS FOLLOWS
C +1 - PEN LIFTED BEFORE MOVEMENT
C -1 - PEN LOWERED BEFORE MOVEMENT
C 0 - NO CHANGE
C IX - NUMBER OF PLOTTER INCREMENTS TO MOVE THE PEN FROM
C IY ITS PRESENT POSITION. FOR OUR PLOTTER A VALUE O 1
C WOULD MOVE THE PEN 0.005 INCHES
C
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
IF(N) 1,3,2
1 CALL PLOTT (SNGL(XZ),SNGL(YZ),2)
GO TO 3
2 CALL PLOTT (SNGL(XZ),SNGL(YZ),3)
3 XZ=XZ+DFLOAT(IX)/DFLOAT(INCPI)
YZ=YZ+DFLOAT(IY)/DFLOAT(INCPI)
CALL PLOTT (SNGL(XZ),SNGL(YZ),1)
RETURN
END
SUBROUTINE CGPMV(X,Y)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
TX=X
TY=Y
XPINC=XPINC+TX
YPINC=YPINC+TY
NX=IABS(IFIX(SNGL(TX/8192.)))
NY=IABS(IFIX(SNGL(TY/8192.)))
IF(NX+NY)20,20,30
20 CALL CGPLT(0,IFIX(SNGL(TX)),IFIX(SNGL(TY)))
RETURN
30 IF(NX-NY)40,50,50
40 NX=NY
50 IX=TX/(NX+1)
IY=TY/(NX+1)
60 CALL CGPLT(0,IX,IY)
TX=TX-IX
TY=TY-IY
NX=NX-1
IF(NX)80,80,60
80 CALL CGPLT(0,IFIX(SNGL(TX)),IFIX(SNGL(TY)))
RETURN
END
SUBROUTINE CGPNT
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION NPLST (12)
DIMENSION LBUF(6)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AXLT
EQUIVALENCE(LBUF(2),XBUF),(LBUF(5),YBUF)
DATA NPL/0/
100 FORMAT(12I6)
101 FORMAT(/)
WRITE(MOUT,101)
C SUBROUTINE TO CHECK FOR POINT NUMBERS THAT HAVE
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C DEFINED COORDINATES WITHIN THE RANGE OF A FIGURE
C DESCRIPTION.
C
C INITIALIZE FIGURE NUMBER
KTF=DATA(1)
C GET POINT NUMBER IN FIGURE DESCRIPTION
1 CALL CGFIG(KTF,NPF,NS)
C ARE WE THROUGH WITH POINTS IN FIGURE DESCRIPTION
IF(NS)90,90,2
C CHECK THAT POINT IS IN DEFINED AREA OF TABLE
2 IF(NPF)90,90,3
3 IF(NPF-LCDA)4,4,90
C GET COORDINATES IN MEMORY
4 CALL CGDBF(KFTB,6,0,LHDRS+LFGA+NPF,LBUF)
C IF POINT IS UNDEFINED GO ON TO NEXT POINT NO.
IF(XBUF-CLEAR)5,1,1
C ADD POINT NUMBER TO LIST
5 NPLST(NPL+1)=NPF
NPL=NPL+1
C IF BUFFER IS FULL - PRINT
IF(NPL-12)1,6,6
6 WRITE(MOUT,100) (NPLST (KEN),KEN=1,NPL)
NPL=0
GO TO 1
C DUMP LAST BUFFER IF ANY POINTS LEFT
90 IF(NPL)900,900,91
91 WRITE(MOUT,100) (NPLST(KEN),KEN=1,NPL)
900 WRITE(MOUT,101)
CALL RTNONE
RETURN
END
SUBROUTINE CGPOA
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION ZPOA(2),ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(ZPOA(1),XPOA),(ZPOA(2),YPOA)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
C REAL NUMBER TRUNCATION
C 95 POINTS ON ALIGNMENT
C 96 LOCATE FROM ALIGNMENT
95000 CONTINUE
96000 CONTINUE
KTF=DATA(1)
NPOA=DATA(4)
CALL CGGET(IFIX(SNGL(DATA(2))),XN,YN)
IF(XN-CLEAR)95200,96800,96800
95200 CALL CGGSF(KTF,0.,XN,YN,I,STA,OFF)
STA=DATA(3)-STA
OFSET=DATA(7)
IF(I)96800,96800,95210
95210 IF(IDITO-96)95220,96220,96220
95220 STINT=DATA(4)
IF(STINT)95090,95090,95300
95300 NPOA=DATA(5)
STFR=STA
STTO=CLEAR
IF(ND-8)95440,95440,95420
95420 STFR=DATA(9)
STTO=DATA(10)
95440 STDES=CGWHL(STFR/STINT)*STINT
IF(STDES-STFR)95460,95480,95480
95460 STDES=STDES+STINT
95480 IF(STDES-STTO)95500,95500,900
95500 CALL CGFIG(KTF,N,NS)
CALL CGGET(N,XN,YN)
95600 IP=NP
NP=N
XP=XN
YP=YN
CALL CGFIG(KTF,N,NS)
IF(NS)95640,95610,95620
95610 IF(STTO-CLEAR)95614,900,900
95614 N=NP
NP=IP
IF(LOR)95616,95634,95616
95616 APC=APT
GO TO 95642
95620 LOR=0
CALL CGGET(N,XN,YN)
CALL CGINV(XP,YP,XN,YN,A,DIST)
STA=STA+DIST
95630 IF(STDES-STA)95634,95634,95632
95632 IF(NS)95644,95634,95600
95634 CALL CGXTL(XN,YN,A,STDES-STA,XPOA,YPOA)
CALL CGXTL(XPOA,YPOA,A-HFPI,OFSET,XPOA,YPOA)
GO TO 95660
95640 LOR=-NS-2
CALL CGGET(N,XCC,YCC)
CALL CGINV(XCC,YCC,XP,YP,APC,RAD)
CALL CGFIG(KTF,N,I)
IF(STDES-STA)95642,95644,95644
95642 A=APC+HFPI*LOR
RAD=0.
GO TO 95634
95644 CALL CGGET(N,XN,YN)
CALL CGINV(XCC,YCC,XN,YN,APT,RAD)
STA=STA+RAD*CGNRM((APT-APC)*LOR)
95650 IF(STDES-STA)95654,95654,95600
95654 CALL CGXTL(
*XCC,YCC,APT+(STDES-STA)/RAD*LOR,RAD+OFSET*LOR,
* XPOA,YPOA)
95660 IF(IDITO-96)95662,96660,96660
95662 CALL CGPUT(NPOA,XPOA,YPOA)
IF(LIST)95680,95670,95670
95670 CALL CGFCD(ZPOA,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
WRITE(MOUT,95671)NPOA,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),NP,N,STDES
95671 FORMAT(I8,2(1X,F10.0,4I1),4X,'SEG',2I5,5X,'STA',F8.0/)
95680 STDES=STDES+STINT
NPOA=NPOA+1
IF(STDES-STTO)95688,95688,900
95688 IF(LOR*RAD)95650,95630,95650
95090 WRITE(MOUT,95091)STINT
95091 FORMAT(' #####','INVALID STATION INTERVAL',F7.0)
GO TO 900
96220 STDES=DATA(5)
STTO=0.
GO TO 95500
96800 IF(IDITO-96)900,96900,96900
96900 CALL CGCLR(XPOA,YPOA)
96660 CALL CGPUT(NPOA,XPOA,YPOA)
96670 CALL CGPCD(NPOA)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGPOC(KV,XA,YA,XB,YB,XP,YP)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
IF(((YB-YA)*(XP-XA)-(XB-XA)*(YP-YA))*KV)90,900,900
90 CALL CGCLR(XP,YP)
900 RETURN
END
SUBROUTINE CGPOL(LKA,XA,YA,LKB,XB,YB,XP,YP)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DX=XB-XA
DY=YB-YA
IF(LKA)50,50,20
20 IF((XP-XA)*DX)90,30,30
30 IF((YP-YA)*DY)90,50,50
50 IF(LKB)900,900,60
60 IF((XB-XP)*DX)90,70,70
70 IF((YB-YP)*DY)90,900,900
90 CALL CGCLR(XP,YP)
900 RETURN
END
SUBROUTINE CGPOT(NPUT,XPUT,YPUT)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION LBUF(6)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE( LBUF(2),XBUF),( LBUF(5),YBUF)
C ROUTINE TO PUT COORDS (XPUT AND YPUT) OF A POINT
C (NPUT) AND PRINT MESSAGE IF POINT IS INVALID.
CALL CGCLR(XBUF,YBUF)
C CHECK THAT POINT NUMBER IS IN THE VALID RANGE
IF(NPUT)9000,9000,105
105 IF(NPUT-9999)110,110,9000
110 IF(NPUT-(LCDA+LUNU))200,200,9000
9000 WRITE(MOUT,9001)NPUT
9001 FORMAT(' #####','INVALID POINT',I6)
9009 CALL RTNONE
300 IF(XPUT-CLEAR)310,900,900
310 LCDA=LCDA+1
LUNU=LUNU-1
CALL CGDBF(KFTB,6,1,LHDRS+LFGA+LCDA,LBUF)
200 CONTINUE
206 IF(NPUT-LCDA) 260,260,300
260 XBUF=XPUT
YBUF=YPUT
CALL CGDBF(KFTB,6,1,LHDRS+LFGA+NPUT,LBUF)
900 RETURN
END
SUBROUTINE CGPPA(FR,TO,XT,YT,A,LOR,RAD)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION ZPOA(2),ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(ZPOA(1),XPOA),(ZPOA(2),YPOA)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
EQUIVALENCE(DATA(3),STA),(DATA(5),STINT)
EQUIVALENCE(DATA(7),STFR),(DATA(8),STTO)
DATA MOC/'OC'/
DATA MOL/'OL'/
C REAL NUMBER TRUNCATION
IF(STINT)78200,78200,78550
78550 STDES=CGWHL(FR/STINT)*STINT
IF(STDES-FR)78560,78560,78562
78560 STDES=STDES+STINT
78562 IF(STDES-TO)78564,78200,78200
78564 IF(ND-6)78568,78568,78566
78566 IF(STDES-STTO)78567,78567,78200
78567 IF(STDES-STFR)78560,78568,78568
78568 IF(LOR)78772,78770,78772
78770 CALL CGXTL(XT,YT,A,STDES-TO,XPOA,YPOA)
MOLOC=MOL
GO TO 78774
78772 CALL CGXTL(XT,YT,A+(STDES-TO)/RAD*LOR,RAD,XPOA,YPOA)
MOLOC=MOC
78774 CALL CGFCD(ZPOA,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
WRITE(MOUT,78777)MOLOC,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2),STDES
78777 FORMAT(' P'A2,4X,2(1X,F10.0,4I1),F14.0)
GO TO 78560
78200 RETURN
END
SUBROUTINE CGPST
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IPBUF(10)
DIMENSION ZTEM2(2),ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2),ZLP(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(ZTEM2(1),XTEM2),(ZTEM2(2),YTEM2)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ZLP(1),XLP),(ZLP(2),YLP)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
EQUIVALENCE(IPBUF(1),N),(IPBUF(4),XN),(IPBUF(6),YN),
* (IPBUF(8),KVUD),(IPBUF(9),KRSZ),(IPBUF(10),NMSZ)
C REAL NUMBER TRUNCATION
IF(INCPI)900,900,74000
74000 IF(SFPI)74010,74010,74900
74010 SFPI=DATA(1)
IF(SFPI)74904,74904,74020
74020 IPAPR=DATA(3)
IF(IPAPR)74906,74026,74022
74022 IF(IPAPR-1000)74030,74030,74906
74026 IF(ND-7)74028,74028,74906
74028 IPAPR=IPDEF
74030 GRID=DATA(5)
IF(GRID)74032,74034,74032
C COMPUTE GRID SIZE IN FEET
74032 GRIF=CGWHL(GRID*SFPI+.5)
IF(GRIF)74908,74908,74040
74034 GRID=10.
GRIF=CGWHL(GRID*SFPI+.5)
IF(GRIF)74036,74036,74040
74036 GRIF=1.
GRID=GRIF/SFPI
74040 ROT=DATA(7)
IF(ND-7)74100,74100,74042
74042 CALL CGGET(IFIX(SNGL(DATA(9))),XCHLD,YCHLD)
IF(XCHLD-CLEAR)74044,74990,74990
74044 IF(XLP-CLEAR)74046,74100,74100
74046 XCHLD=XL-XLP+XCHLD
YCHLD=YL-YLP+YCHLD
C FIT MAP ON PAPER
C DXMAX = X DISTANCE IN INCHES FROM CENTER
C *OF PAPER TO EDGE
74100 DXMAX=IPAPR/2.*SFPI
C DYMAX = Y DISTANCE IN INCHES FROM CENTER
C *OF PAPER TO EDGE
DYMAX=JPAPR/2.*SFPI
C INITIALIZE NUMBER OF POINTS NOT FITTING
C *IN BEST FIT SO FAR
NPMS=30000
C INITIALIZE PAPER LENGTH NEEDED TO FIT
C *ALL POINTS
NEED=0
C SET J TO ZERO INDICATING ONLY ONE ATTEMPT
C *AT FITTING IS TO BE MADE
C THIS IS IN CASE USER ENTERED ROTATION ANGLE
J=0
C DID USER ENTER ROTATION ANGLE
IF(ND-7)200,204,204
C INITIALIZE LOOP,RANGE IS TO STATEMENT 250+2
C THIS LOOP CHECKS FIT AT 10 ROTATION ANGLES
200 J=16
MP=1
BRAN=0.
ROT=0.
204 SINA=SIN(ROT)
COSA=COS(ROT)
C INITIALIZE LOOP TO FIND MAX AND MIN
C LOOP RANGE IS TO STAEMENT 509
XMAX=-1.E20
XMIN=1.E20
YMAX=-1.E20
YMIN=1.E20
I=NPREC
470 IF(I)530,530,474
474 CALL CGDBF(KFPL,10,0,I,IPBUF)
IF(N)509,509,480
480 IF(KVUD)509,501,501
501 XI=XN*COSA-YN*SINA
YI=YN*COSA+XN*SINA
IF(YMAX-YI)502,503,503
502 YMAX=YI
503 IF(YMIN-YI)505,505,504
504 YMIN=YI
505 IF(XMAX-XI)506,507,507
506 XMAX=XI
507 IF(XMIN-XI)509,509,508
508 XMIN=XI
509 I=I-1
GO TO 470
C END OF LOOP TO FIND MAX AND MIN
C HAS OPERATOR SPECIFIED THE CENTER
530 IF(ND-7)550,550,540
C YES, GET THE CENTER COORDINATES
540 XCENT=XCHLD*COSA-YCHLD*SINA
YCENT=YCHLD*COSA+XCHLD*SINA
IF(XMAX-XMIN)239,400,400
C NO, COMPUTE COORDS OF CENTER OF PAPER
550 IF(XMAX-XMIN)74902,552,552
552 XCENT=(XMAX+XMIN)/2.
YCENT=(YMAX+YMIN)/2.
400 IF(NEED)402,402,410
C FIND PAPER NEEDED TO PLOT ALL POINTS
C CHECK WIDTH BECAUSE IF WIDTH IS TO GREAT
C *THEN ALL POINTS WILL NOT FIT NO MATTER
C *HOW LONG THE PAPER IS
402 IF(YCENT+DYMAX-YMAX)410,404,404
404 IF(YCENT-DYMAX-YMIN)406,406,410
C PAPER NEEDED (WITH TYPE OF FITTING
C *SPECIFIED) IS DISTANCE FROM XCENT TO XMAX
406 XNEED=XMAX-XCENT
C *OR, IF DISTANCE FROM XMIN TO XCENT IS
IF(XNEED-(XCENT-XMIN))408,409,409
C *GREATER, DISTANCE FROM XMIN TO XCENT
408 XNEED=XCENT-XMIN
C *TIMES TWO ROUNDED BECAUSE OF TRUNCATION
409 NEED=(XNEED*2.)/SFPI+1.
410 CONTINUE
C ADD BORDER OF ONE GRID INTERVAL TO PLOT
XMIN=XMIN-GRIF
YMIN=YMIN-GRIF
XMAX=XMAX+GRIF
YMAX=YMAX+GRIF
C INITIALIZE NUMBER OF POINTS NOT FITTING
C *AT THIS ROTATION
NPM=0
C INITIALIZE FIT INDICATOR
IFIT=1
C DO ALL POINTS FIT ON MAP (X)
IF(XCENT+DXMAX-XMAX)412,414,414
C XMAX IS BEYOND PAPER LENGTH. SET IT BACK
C * TO END OF PAPER
412 XMAX=XCENT+DXMAX
IFIT=0
414 IF(XCENT-DXMAX-XMIN)420,420,416
C YMIN IS BEYOND PAPER LENGTH. SET IT BACK
C *TO END OF PAPER
416 XMIN=XCENT-DXMAX
IFIT=0
C DO ALL POINTS FIT ON MAP (Y)
420 IF(YCENT+DYMAX-YMAX)422,424,424
C YMAX IS BEYOND PAPER WIDTH. SET IT BACK
C *TO EDGE OF PAPER
422 YMAX=YCENT+DYMAX
IFIT=0
424 IF(YCENT-DYMAX-YMIN)430,430,426
C YMIN IS BEYOND PAPER WIDTH. SET IT BACK
C *TO EDGE OF PAPER
426 YMIN=YCENT-DYMAX
IFIT=0
C WERE ANY MAX'S OR MIN'S CHANGED ABOVE
430 IF(IFIT)300,300,330
C YES - START LOOP TO FIND OUT HOW MANY
C *POINTS DON'T FIT
300 DO 329 I=1,NPREC
IKEN=I
CALL CGDBF(KFPL,10,0,IKEN,IPBUF)
IF(N)329,329,322
322 IF(KVUD)329,323,323
323 XI=XN*COSA-YN*SINA
YI=YN*COSA+XN*SINA
C DOES THIS POINT FIT
IF(XMAX-XI)328,325,325
325 IF(XI-XMIN)328,326,326
326 IF(YMAX-YI)328,327,327
327 IF(YI-YMIN)328,329,329
C NO INCREMENT COUNT OF POINTS NOT FITTING
328 NPM=NPM+1
329 CONTINUE
C END OF LOOP TO FIND OUT HOW MANY POINTS
C *DON'T FIT
C PRINT THE ANGLE AND NUMBER OF POINTS
C *NOT FITTING SO THAT THE
C *OPERATOR WILL KNOW WHAT IS HAPPENING
330 CALL CGDMS(CGNRM(ROT*ISGG),IDEG,MIN,SEC)
WRITE(MTT,10003)IDEG,MIN,SEC,NPM
10003 FORMAT(10X,'AT ANGLE',I4,'-',I2,'-',F4.1,I7,' POINTS DO NOT FIT')
C IF NPM=0, ONLY BORDER WAS CUT
74600 IF(NPM)231,231,305
C IF BEST FIT SO FAR, SAVE VALUES
305 IF(NPM-NPMS)11,248,248
11 XMINS=XMIN
XMAXS=XMAX
XCNTS=XCENT
YCNTS=YCENT
ROTS=ROT
NPMS=NPM
C SELECT THE NEXT ROTATION ANGLE
248 IF(MP)249,249,250
C BASE ROATION ANGLE IS ANGLE OF BEST FIT
C *SO FAR
249 BRAN=ROTS
C ANGLE FROM BASE TO TRIAL IS HALF OF WHAT
C *IT WAS
J=J/2
C COMPUTE NEXT TRAIL ROTATION ANGLE
250 ROT=BRAN+MP*J/16.*HFPI
C TRY OTHER SIDE OF BASE NEXT
MP=-MP
C KEEP COMPUTED ANGLES BETWEEN -90 AND +90 DEGREES
IF(ROT-HFPI)256,256,254
254 ROT=ROT-PI
C GO TRY IF OPERATOR DID NOT ENTER ROTATION
C *AND LESS THAN 10 TRIES HAVE BEEN MADE
256 IF(J)260,260,204
C END OF LOOP TO CHECK FIT
C RESTORE SAVED VALUES FOR BEST FIT
260 XMIN=XMINS
XMAX=XMAXS
XCENT=XCNTS
YCENT=YCNTS
ROT=ROTS
NPM=NPMS
C NOTIFY OPERATOR THAT ALL POINTS DO NOT FIT
IF(NEED)264,264,262
262 WRITE(MTT,120)NEED,IPAPR
120 FORMAT(10X,'IF THE PAPER LENGTH WERE',I4,', INCHES ALL POINTS WOUL
1D FI
*T',/10X,'BUT SINCE IT IS ONLY',I4,' INCHES')
264 WRITE(MTT,115)NPM
115 FORMAT(I14,' POINTS DO NOT FIT.')
C IF CENTER COORDINATES WERE TYPED IN,
C USE ENTIRE PAPER LENGTH.
C IF CENTER COORDINATES WERE COMPUTED,
C USE ONLY AS MUCH PAPER AS REQUIRED.
231 IF(ND-7)235,235,239
C COMPUTE WHOLE NUMBER OF INCHES REQUIRED
C ADD ONE TO ACCOUNT FOR TRUNCATION
235 I=(XMAX-XMIN)/SFPI+1.
C DO NOT EXCEED XSIZE
IF(I-IPAPR)238,239,239
238 IPAPR=I
239 WRITE(MTT,270)IPAPR
270 FORMAT(/10X,'PAPER LENGTH USED =',I4,' INCHES')
C COMPUTE COORDS OF CHECKPOINT
XORG=XCENT-IPAPR/2.*SFPI
YORG=YCENT-DYMAX
C NORMALIZE ROTATION ANGLE
ROT=CGNRM(ROT)
C CONVERT ROTATION TO DEGREES FOR TYPING
CALL CGDMS(CGNRM(ROT*ISGG),IDEG,MIN,SEC)
C COMPUTE CENTER IN ORIGINAL COORDINATE
C *SYSTEM FOR TYPING
XTEM2=XCENT*COS(ROT)+YCENT*SIN(ROT)
YTEM2=YCENT*COS(ROT)-XCENT*SIN(ROT)
IF(XLP-CLEAR)273,272,272
272 CALL CGFCD(ZTEM2,ZL,ISGZ,IXYF,ZWHOL,IZ,1)
GO TO 274
273 CALL CGFCD(ZTEM2,ZLP,ISGZ,IXYF,ZWHOL,IZ,1)
274 WRITE(MOUT,275)IDEG,MIN,SEC,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2)
275 FORMAT(10X,'ROTATION ANGLE =',I4,'-',I2,'-',F4.1/
* 9X,2(F10.0,4I1,1X),'= CENTER OF PAPER'/)
CALL CGPBG
74900 WRITE(MOUT,74901)
74901 FORMAT(' #####','PLOTTER ALREADY STARTED')
GO TO 900
74902 WRITE(MOUT,74903)
74903 FORMAT(' #####','NO FITTING DATA SUPPLIED')
GO TO 74990
74904 WRITE(MOUT,74905)SFPI
74905 FORMAT(' #####','INVALID SCALE',F10.4)
GO TO 74990
74906 WRITE(MOUT,74907)IPAPR
74907 FORMAT(' #####','INVALID PAPER LENGTH',I6)
GO TO 74990
74908 WRITE(MOUT,74909)GRID
74909 FORMAT(' #####','INVALID GRID SIZE',F10.4)
74990 SFPI=0.
900 CALL RTNONE
RETURN
END
SUBROUTINE CGPUP
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA KUP/1/
CALL CGPLT(KUP,0,0)
RETURN
END
SUBROUTINE CGPUT(NPUT,XPUT,YPUT)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION LBUF(6)
DIMENSION LLBUF(4)
DIMENSION ZBUF(2),ZWHOL(2),IZ(4,2),ZL(2),ISGZ(2)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(ZBUF(1),LLBUF(1),XBUF),(ZBUF(2),LLBUF(3),YBUF)
EQUIVALENCE(ZL(1),XL),(ZL(2),YL)
EQUIVALENCE(ISGZ(1),ISGX),(ISGZ(2),ISGY)
C ROUTINE TO PUT COORDS (XPUT AND YPUT) OF A POINT
C (NPUT) AND PRINT MESSAGE IF POINT IS INVALID.
NENTRY=1
GO TO 500
ENTRY CGPAT(NPUT,XPUT,YPUT)
NENTRY=2
500 CONTINUE
CALL CGCLR(XBUF,YBUF)
C CHECK THAT POINT NUMBER IS IN THE VALID RANGE
IF(NPUT)9000,9000,105
105 IF(NPUT-9999)110,110,9000
110 IF(NPUT-(LCDA+LUNU))200,200,9000
9000 WRITE(MOUT,9001)NPUT
9001 FORMAT(' #####','INVALID POINT',I6)
9009 CALL RTNONE
300 IF(XPUT-CLEAR)310,900,900
310 LCDA=LCDA+1
LUNU=LUNU-1
LBUF(2)=LLBUF(1)
LBUF(3)=LLBUF(2)
LBUF(5)=LLBUF(3)
LBUF(6)=LLBUF(4)
CALL CGDBF(KFTB,6,1,LHDRS+LFGA+LCDA,LBUF)
200 CONTINUE
206 IF(NPUT-LCDA)210,210,300
210 CALL CGDBF(KFTB,6,0,LHDRS+LFGA+NPUT,LBUF)
LLBUF(1)=LBUF(2)
LLBUF(2)=LBUF(3)
LLBUF(3)=LBUF(5)
LLBUF(4)=LBUF(6)
IF(XBUF-CLEAR)214,260,260
214 IF(XBUF-XPUT)220,216,220
216 IF(YBUF-YPUT)220,900,220
220 CALL CGFCD(ZBUF,ZL,ISGZ,IXYF,ZWHOL,IZ,10)
GO TO (501,502),NENTRY
501 CONTINUE
WRITE(MOUT,221)NPUT,NPUT,(ZWHOL(I),(IZ(J,I),J=1,4),I=1,2)
221 FORMAT(' #####','POINT',I5,' CHANGED', T1,
* ' PREVIOUS VALUE OF POINT',I5,' WAS',/,8X,
1 4(1X,F10.0,4I1))
502 CONTINUE
260 XBUF=XPUT
YBUF=YPUT
LBUF(2)=LLBUF(1)
LBUF(3)=LLBUF(2)
LBUF(5)=LLBUF(3)
LBUF(6)=LLBUF(4)
CALL CGDBF(KFTB,6,1,LHDRS+LFGA+NPUT,LBUF)
900 RETURN
END
SUBROUTINE CGPZB(A)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MBL/' '/
ANGLE=CGNRM((A+AZEZ)*ISGG)
M13=MBL
M24=MBL
IF(IDITO-107)78332,78332,78330
78330 NQUAD=IFIX(SNGL(ANGLE/HFPI))+1
M13=3-(NQUAD-2)*(NQUAD-3)
M24=NQUAD/3*2+2
M13=MAXES(M13)
M24=MAXES(M24)
ANGLE=HFPI-ABS(ABS(ANGLE-PI)-HFPI)
78332 CALL CGDMS(ANGLE,IDEG,MIN,SEC)
WRITE(MOUT,78335)M13,IDEG,MIN,SEC,M24
78335 FORMAT(59X,A1,I3,'-',I2,'-',F4.1,1X,A1)
RETURN
END
SUBROUTINE CGRED
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
COMMON /COGCOM/ KBFLG,IBU(322)
DATA MBL /' '/
DATA ME,MO,MR/'E','O','R'/
DATA PROMPT/"035744020100/
DATA ILA/"605004020100/,ILZ/"751004020100/,MASK/"577777777777/
C CHECK IF CTL C HAS BEEN HIT
CALL CTPCNT(IRET)
IF(IRET.NE.0) GO TO 200
CALL LOGDEV(INDEV,NDEV)
IF(NDEV.EQ.'TTY') WRITE(INDEV,102) PROMPT
102 FORMAT(1X,A2,$)
READ(INDEV,1000,END=100)IN
1000 FORMAT(80A1)
C INCREMENT RECORD COUNT
NUSE=NUSE+1
C FIND LAST COLUMN USED
LK=81
1110 LK=LK-1
IF(LK)899,899,1112
1112 IF(IN(LK)-MBL)899,1110,899
C TERMINATE PROGRAM BECAUSE OF CTL C
200 WRITE(MOUT,201)
201 FORMAT(' ##### JOB TERMINATED VIA CTL C')
GO TO 202
100 WRITE (MOUT,101)
101 FORMAT (' #####','END-OF-FILE ON JOB INPUT FORCES E O R')
202 DO 1046 I=1,80
1046 IN(I)=MBL
IN(1)=ME
IN(3)=MO
IN(5)=MR
LK=5
GO TO 900
899 DO 6666 II=1,LK
IF(IN(II).GE.ILA.AND.IN(II).LE.ILZ) IN(II)=IN(II).AND.MASK
6666 CONTINUE
900 RETURN
END
SUBROUTINE CGRGS(NM,NMIN,NMBFB,NMBFE,LNMBF,KNMBF)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C * * * USED TO SEE IF A POINT HAS BEEN WRITTEN TO THE PLOT FILE
C * * * NMBFB - BEGINNING OF RANGE
C * * * NMBFE - ENDING OF RANGE
C * * * LNMBF - LENGTH OF TABLE (LIMIT)
C * * * KNMBF - CURRENT LENGTH OF TABLE IN USE
C * * * NMIN - 0= NM WAS NO IN TABLE; 1= NM WAS IN TABLE
C * * * NM - POINT NUMBER TO CHECK IN TABLE
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION NMBFB(1),NMBFE(1)
I=0
16 KPUT=I
20 I=I+1
IF(I-KNMBF)22,22,40
22 IF(NM+1-NMBFB(I))20,24,26
24 NMBFB(I)=NM
GO TO 16
26 IF(NM-1-NMBFE(I))80,28,20
28 NMBFE(I)=NM
GO TO 16
40 IF(KPUT)50,50,60
50 IF(KNMBF-LNMBF)44,60,60
44 KNMBF=KNMBF+1
NMBFB(KNMBF)=NM
NMBFE(KNMBF)=NM
60 NMIN=0
GO TO 900
80 NMIN=1
900 RETURN
END
SUBROUTINE CGSAF
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C DESCRIBE ALIGNMENT AZIMUTHS
10700 CONTINUE
C DESCRIBE ALIGNMENT BEARINGS
10800 CONTINUE
9100 KA=DATA(1)
CALL CGGET(IFIX(SNGL(DATA(2))),XF,YF)
IF(XF-CLEAR)9110,9792,9792
9110 CALL CGGSF(KA,0.,XF,YF,NSEG,STA,OFF)
IF(NSEG)9794,9794,9114
9114 STST=DATA(3)-STA
KF=DATA(4)
IF(IDITO-97)9120,9720,10780
9120 CALL CGFIG(KF,NF,IND)
IF(IND)9130,900,9130
9130 CALL CGGET(NF,XF,YF)
CALL CGGSF(KA,STST,XF,YF,NSEG,STA,OFF)
CALL CGGSN(KA,NSEG,NBSEG,NESEG,KV,NCC)
IF(LIST)9158,9140,9140
9140 STAPR=STA+0.00005
IF(STA)9142,9144,9144
9142 STAPR=STA-0.00005
9144 OFFPR=OFF+0.00005
IF(OFF)9146,9150,9150
9146 OFFPR=OFF-0.00005
9150 WRITE(MOUT,9155)NBSEG,NESEG,NF,STAPR,OFFPR
9155 FORMAT(10X'SEG'2I5,5X'PNT,STA,OFF'I5,F14.4,F14.4/)
9158 IF(IDITO-97)9120,9760,9760
9720 NF=DATA(5)
GO TO 9130
9760 IF(XF-CLEAR)9762,9790,9790
9762 CALL CGGET(NBSEG,XBSEG,YBSEG)
CALL CGGET(NESEG,XESEG,YESEG)
CALL CGINV(XBSEG,YBSEG,XESEG,YESEG,AZ,DIST)
CALL CGGSF(KA,STST,XBSEG,YBSEG,NSEG,STAPR,OFFPR)
STAPR=STA-STAPR
IF(KV)9764,9768,9764
9764 CALL CGGET(NCC,XCC,YCC)
CALL CGINV(XCC,YCC,XBSEG,YBSEG,AZ,DIST)
IF(STAPR)9766,9766,9770
9766 AZ=AZ+HFPI*KV
9768 CALL CGXTL(XBSEG,YBSEG,AZ,STAPR,XN,YN)
GO TO 9789
9770 CALL CGGSF(KA,STST,XESEG,YESEG,NSEG,STAPR,OFFPR)
STAPR=STA-STAPR
CALL CGINV(XCC,YCC,XESEG,YESEG,AZ,DIST)
IF(STAPR)9772,9776,9776
9772 CALL CGXTL(XCC,YCC,AZ+KV*STAPR/DIST,DIST,XN,YN)
GO TO 9789
9776 AZ=AZ+HFPI*KV
CALL CGXTL(XESEG,YESEG,AZ,STAPR,XN,YN)
9789 N=DATA(4)
CALL CGPUT(N,XN,YN)
CALL CGPCD(N)
GO TO 900
9790 CALL CGCLR(XN,YN)
GO TO 9789
9792 IF(IDITO-97)900,9110,900
9794 IF(IDITO-97)900,9790,900
10780 IF(LIST)900,10782,10782
10782 DATA(3)=STST
CALL CGDAL
900 CALL RTNONE
RETURN
END
SUBROUTINE CGSCU
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
C EQUIVALENCE IS USED TO PUT NPI1 AND NEC1 INTO COMMON FOR
C BENIFIT OF FIT/ALIGNMENT ROUTINE.
EQUIVALENCE (DATA(11),XLS2),(DATA(10),CENTA),(DATA(9),DEFAN)
C
IF(IDITO-35)3300,3500,3300
C
C DEFINE/CURVE
C
3500 NCURV = DATA(1)
NPC = DATA(2)
SPC = DATA(3)
NPI = DATA(4)
NPT = DATA(5)
SPT = DATA(6)
NC = DATA(7)
SGN = DATA(8)*ISGG
C REESTABLISH APC,R
CALL CGGET(NC,XC,YC)
CALL CGGET(NPC,XPC,YPC)
CALL CGINV(XC,YC,XPC,YPC,APC,R)
C REESTABLISH APT
CALL CGGET(NPT,XPT,YPT)
CALL CGINV(XC,YC,XPT,YPT,APT,DIST1)
C REESTABLISH BA
CALL CGGET(NPI,XPI,YPI)
CALL CGINV(XPI,YPI,XPC,YPC,BA,DIST1)
C REESTABLISH AA
CALL CGINV(XPI,YPI,XPT,YPT,AA,DIST1)
GO TO 900
C SIMPLE/CURVE ROUTINE
3300 NCRV1= DATA(1)
NB1 = DATA(2)
NBC1 = DATA(3)
NPI1 = DATA(4)
NEC1 = DATA(5)
DC1=CGNRM(DATA(6)*ISGG)
SGN1 = DATA(8)*ISGG
C
C FIND BACK AZIMUTH
C
CALL CGGET(NB1,XB1,YB1)
CALL CGGET(NBC1,XNBC,YNBC)
CALL CGINV(XB1,YB1,XNBC,YNBC,BACAZ,DIST1)
C
C FIND RADIUS
C
RC = 100./DC1
C
C FIND TANGENT LENGTH.
C
ANGLE=CGNRM(DATA(7)*ISGG)
TC = RC * (SIN(ANGLE/2.)/COS(ANGLE/2.))
C
C FIND ARC LENGTH.
C
AC = ANGLE*RC
C
C LOCATE P.I.
C
CALL CGXTL(XNBC,YNBC,BACAZ,TC,XNPI,YNPI)
CALL CGPUT(NPI1,XNPI,YNPI)
FINAZ=CGNRM(BACAZ+ANGLE*SGN1)
C
C LOCATE NEC1
C
CALL CGXTL(XNPI,YNPI,FINAZ,TC,XNEC,YNEC)
CALL CGPUT(NEC1,XNEC,YNEC)
C
C OUTPUT SECTION
C
IF(LIST)800,7,7
7 WRITE(MOUT,1000) NCRV1
1000 FORMAT(3X,12HSIMPLE CURVE,I5/)
C OUTPUT COORDS OF NBC1,NPI1,NEC1
CALL CGPCD(NBC1)
CALL CGPCD(NPI1)
CALL CGPCD(NEC1)
DIST1=TC+.00005
DIST2=AC+.00005
WRITE(MOUT,1001)DIST1,DIST2
1001 FORMAT(15X,F14.4,' = TAN LENGTH',F14.4,' = CURVE LENGTH'/)
CALL CGDMS(CGNRM((BACAZ+AZEZ)*ISGG),IDEG,MIN,SEC)
WRITE(MOUT,1002) IDEG,MIN,SEC
1002 FORMAT(39X,'BACK AZIMUTH =',I4,'-',I2,'-',F4.1)
CALL CGDMS(CGNRM((FINAZ+AZEZ)*ISGG),IDEG,MIN,SEC)
WRITE(MOUT,1003) IDEG,MIN,SEC
1003 FORMAT(36X,'FORWARD AZIMUTH =',I4,'-',I2,'-',F4.1/)
800 IF(DATA(12))815,900,815
C
C COMMAND IS FIT/ALIGNMENT
C NOW ENTER VALUES FOR SPIRAL 2, AND CALL SIMSP.
C
815 DATA(1) = NCRVS
DATA(2) = NPI1
DATA(3) = NCRVS + 7
DATA(4) = NCRVS + 6
DATA(5) = NEC1
DATA(6) = -XLS2
DATA(7) = DC*ISGG
DATA(8) = SGNSP*ISGG
C CALL CGSIM
RETURN
900 CALL RTNONE
RETURN
END
SUBROUTINE CGSGN(ISGN)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * GET THE SIGN (IF THERE IS ONE) FROM THE INPUT
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MINUS/'-'/
DATA MPLUS/'+'/
CALL CGCOL(KN)
IF(KN-MPLUS)14,22,14
14 IF(KN-MINUS)900,24,900
22 ISGN=1
GO TO 30
24 ISGN=-1
30 NKL=NKL+1
900 RETURN
END
SUBROUTINE CGSIM
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE (DATA(11),XLS2),(DATA(10),CENTA),(DATA(9),DEFAN)
C
NCRVS = DATA(1)
NB = DATA(2)
NTS = DATA(3)
NPISP = DATA(4)
NSC = DATA(5)
XLS = ABS(DATA(6))
DC=CGNRM(DATA(7)*ISGG)
SGNSP = DATA(8)*ISGG
C
C FIND DEFLECTION ANGLE(THR).
C
THR = XLS *DC/200.
FACT1 =1.-THR*THR/10. + THR**4/216. - THR**6/9360.
FACT2 = THR/3. - THR**3/42. + THR**5/1320. - THR**7/75600.
XS = XLS*FACT1
YS = XLS*FACT2
C
C FIND TANGENT LENGTHS (SHORT TAN + LONG TAN)
C
ST = YS/SIN(THR)
XLT= XS - YS*(COS(THR)/SIN(THR))
CALL CGGET(NB,XNB,YNB)
IF(DATA(6)) 8,6,6
C
C SPIRAL IN ........(NTS IS KNOWN, NSC TO BE CALCULATED)
C
6 CALL CGGET(NTS,XTS,YTS)
CALL CGINV(XNB,YNB,XTS,YTS,ANGLE,DIST1)
C
C LOCATE P.I.
C
CALL CGXTL(XTS,YTS,ANGLE,XLT,XPISP,YPISP)
CALL CGPUT(NPISP,XPISP,YPISP)
C
C LOCATE CORNER
C
CALL CGXTL(XTS,YTS,ANGLE,XS,XCOR,YCOR)
C
C LOCATE S.C.
C
ANGTM=ANGLE+SGNSP*HFPI
CALL CGXTL(XCOR,YCOR,ANGTM,YS,XSC,YSC)
CALL CGPUT(NSC,XSC,YSC)
C
C TANGENT AZIMUTHS
C
AZST = ANGLE + SGNSP*THR
AZLT = ANGLE
GO TO 10
C
C SPIRAL OUT ........(NSC IS KNOWN,NTS TO BE CALCULATED)
C
8 CALL CGGET(NSC,XSC,YSC)
CALL CGINV(XNB,YNB,XSC,YSC,ANGLE,DIST1)
C
C LOCATE P.I.
C
CALL CGXTL(XSC,YSC,ANGLE,ST,XPISP,YPISP)
CALL CGPUT(NPISP,XPISP,YPISP)
AZINT = ANGLE - (HFPI - THR)*SGNSP
C
C LOCATE CORNER
C
CALL CGXTL(XSC,YSC,AZINT,YS,XCOR,YCOR)
C
C TANGENT AZIMUTHS
C
AZLT = AZINT + HFPI*SGNSP
AZST = ANGLE
C
C LOCATE T.S.
C
CALL CGXTL(XCOR,YCOR,AZLT,XS,XTS,YTS)
CALL CGPUT(NTS,XTS,YTS)
C
C WRITE OUTPUT...
C
10 IF(LIST)26,12,12
12 DIST1=XLS+.00005
CALL CGDMS(DC,JDEG,JMIN,SECJ)
CALL CGDMS(THR,IDEG,MIN,SEC)
WRITE(MOUT,1000) NCRVS,DATA(8),DIST1,JDEG,JMIN,SECJ,IDEG,MIN,SEC
1000 FORMAT(3X,6HSPIRAL,I4,6H SIGN=,F3.0,3H L=,F14.4,4H DC=,
*I3,'-',I2,'-',F4.1,
1 11H DEFLN ANG=,I3,1H-,I2,1H-,F4.1,/)
CALL CGDMS(CGNRM((AZLT+AZEZ)*ISGG),IDEG,MIN,SEC)
DIST1=XLT+.00005
WRITE(MOUT,1001)DIST1,IDEG,MIN,SEC
1001 FORMAT(3X,11HLONG TAN L=,F15.4,4H AZ=,I4,1H-,I3,1H-,F5.1/)
CALL CGDMS(CGNRM((AZST+AZEZ)*ISGG),IDEG,MIN,SEC)
DIST1=ST+.00005
WRITE(MOUT,1002)DIST1,IDEG,MIN,SEC
1002 FORMAT(3X,13HSHORT TAN L =,F14.4,4H AZ=,I4,1H-,I3,1H-,F5.1/)
CALL CGPCD(NTS)
CALL CGPCD(NPISP)
CALL CGPCD(NSC)
C
C CONVERT SPIRAL OUT TO SPIRAL IN
C
26 IF(DATA(6))28,38,38
28 SGNSP=-SGNSP
AZLT=CGNRM(AZLT-PI)
C
38 IF(DATA(12))800,900,800
C COMMAND IS FIT/ALIGNMENT
800 IF(DATA(4)-DATA(3))820,810,810
C NOW THAT SPIRAL 1 HAS BEEN CALCULATED, ENTER VALUES TO THE CURVE
C AND CALL SIMCU.
C
810 DATA(1) = NCRVS
DATA(2) = NPISP
DATA(3) = NSC
DATA(4) = NCRVS + 4
DATA(5) = NCRVS + 5
DATA(6) = DC*ISGG
DATA(7) = CENTA*ISGG
DATA(8) = SGNSP*ISGG
C CALL CGSCU
INDPLT=INDPLT+5
RETURN
C 820 CALL CGFIT
820 RETURN
900 CALL RTNONE
RETURN
END
SUBROUTINE CGSLF
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IBUF(6),JBUF(6)
DIMENSION LINE(70)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA MC /'C'/
DATA ML /'L'/
DATA MR /'R'/
DATA MZERO/'0'/
DATA MINUS/'-'/
DATA MBL /' '/
DATA MLPAR/'('/
DATA MRPAR/')'/
DATA MMST /'ST'/
DATA MMOR /'OR'/
DATA MMEBL/'E '/
DATA MMFI /'FI'/
DATA MMGU /'GU'/
DATA MMRE /'RE'/
C CONVERSION OF UNITS DIGIT TO A1 FORMAT
C* IBC(N)=(N-N/10*10)*256+MZERO
IBC(N)=(N-N/10*10)*2**29+MZERO
IF(IDITO-70)2,7000,2
2 IF(IDITO-82)3,8200,3
3 IF(IDITO-84)4,8400,4
4 IF(IDITO-86)900,8600,900
7000 CONTINUE
8600 CONTINUE
NFG=DATA(1)
IF(NFG)7090,7090,7012
7012 IF(NFG-9999)7020,7020,7090
7020 LDND=0
7022 LRBLD=LDND
7023 LDND=LDND+1
IF(LDND-LFTOT)7024,7024,7060
7024 CALL CGDBF(KFTB,6,0,LHDRS+LDND,IBUF)
J=IBUF(6)-10000
IF(J)7023,7026,7026
7026 IF(J-NFG)7022,7030,7022
7030 IF(LFTOT-LFPRM)7050,7050,7031
7031 I=LRBLD
LRBNW=LFPRM
7032 I=I+1
LRBNW=LRBNW+1
CALL CGDBF(KFTB,6,0,LHDRS+I,IBUF)
CALL CGDBF(KFTB,6,0,LHDRS+LRBNW,JBUF)
DO 7034 J=1,6
IF(JBUF(J)-IBUF(J))7036,7034,7036
7034 CONTINUE
GO TO 7032
7036 IF(IBUF(J)-10000)7050,7038,7038
7038 IF(JBUF(J)-10000)7050,7040,7040
7040 IF(IDITO-86)7041,86900,7041
7041 IF(LIST)900,7042,7042
7042 WRITE(MOUT,7043)NFG
7043 FORMAT(I17)
GO TO 900
7050 IA=NFG
IB=NFG
ISGN=1
GO TO 8210
7054 LRBLD=LRBLD+1
LDND=LDND+1
CALL CGDBF(KFTB,6,0,LHDRS+LDND,IBUF)
CALL CGDBF(KFTB,6,1,LHDRS+LRBLD,IBUF)
IF(LDND-LFTOT)7054,7058,7058
7058 I=KGFGT(0)
7060 IF(LFTOT-LFPRM)7066,7066,7061
7061 DO 7064 I=1,6
IF(IBUF(I)-10000)7064,7062,7062
7062 IBUF(I)=10000+NFG
7064 CONTINUE
CALL CGDBF(KFTB,6,1,LHDRS+LRBLD,IBUF)
7066 LFPRM=LRBLD
GO TO 7040
7090 WRITE(MOUT,7091)NFG
7091 FORMAT(' #####INVALID FIGURE'I6)
GO TO 900
8200 CONTINUE
8400 CONTINUE
IF(LIST)900,8202,8202
8202 NDX=DATA(1)
82002 CALL CGFRG(NDX,IA,IB,ISGN)
IF(ISGN)8204,900,8204
8204 CONTINUE
8210 CONTINUE
C DUMP EACH FIGURE IN RANGE
C FIND NEXT FIGURE
K=IB+ISGN
KTFS=0
NPF=0
82101 NPF=NPF+6
IF(NPF-6*LFPRM)82102,82102,82108
82102 NS=KGFGT(NPF)-10000
IF(NS)82101,82103,82103
82103 IF((NS-IA)*ISGN)82106,82104,82104
82104 IF((NS-K)*ISGN)82105,82106,82106
82105 K=NS
KTF=KTFS+1
82106 KTFS=NPF
GO TO 82101
C DUMP IT OR RETURN
82108 IF((K-IB)*ISGN)8212,8212,82002
C SET UP COMMAND NAME FOR PUNCHED OUTPUT
8212 IF(IDITO-82)82122,82129,82122
82122 IF(IDITO-84)82124,82129,82124
82124 WRITE(MOUT,82125)K,K
82125 FORMAT(' #####','FIGURE',I5,' CHANGED', T1,
* ' PREVIOUS VALUE OF FIGURE',I5,' WAS')
82129 LINE(1)=MMST
LINE(2)=MMOR
LINE(3)=MMEBL
LINE(4)=MMFI
LINE(5)=MMGU
LINE(6)=MMRE
C FILL REMAINDER OF OUTPUT AREA WITH BLANKS
DO 8214 I=7,70
8214 LINE(I)=MBL
C INITIALIZE COLUMN POINTER TO COLUMN 8
NDTA=8
C PLACE FIGURE NUMBER RIGHT JUSTIFIED IN COL 11
NT=1000
8216 I=K/NT
IF(I)8218,8218,8217
8217 LINE(NDTA)=IBC(I)
8218 NDTA=NDTA+1
NT=NT/10
IF(NT)8219,8219,8216
C SKIP A COLUMN
8219 NDTA=NDTA+1
C PLACE LEFT PARENTHESIS
LINE(NDTA)=MLPAR
C GET NEXT ENTRY FROM FIGURE TABLE
8220 NPF=KGFGT(KTF)
KTF=KTF+1
C IS THIS THE END OF THE FIGURE
IF(NPF-10000)8222,8226,8226
C NO - PRINT IF OUTPUT AREA IS FULL
8222 IF(NDTA-63)8250,8250,8228
C YES - PLACE RIGHT PARENTHESIS AND PRINT
8226 LINE(NDTA)=MRPAR
C IS PUNCHING REQUESTED
8228 IF(IDITO-84)8240,8229,8240
8229 CONTINUE
C PUNCH THE CARD
8232 WRITE(MTC,8243)(LINE(I),I=1,NDTA)
8240 DO 8242 I=1,6
8242 LINE(I)=MBL
IF(IDITO-84)82425,82435,82425
C PRINT THE LINE
82425 WRITE(MOUT,8243)(LINE(I),I=1,NDTA)
8243 FORMAT(6A2,64A1)
C RESET COLUMN TO 10
82435 NDTA=12
C PUT BLANKS IN OUTPUT AREA
DO 8244 I=7,70
8244 LINE(I)=MBL
C GET NEXT LINE OF THIS FIGURE OR START NEXT FIG
IF(NPF-10000)8250,8278,8278
C IF THIS IS A NEGATIVE POINT NUMBER
8250 IF(NPF)8252,8254,8254
C PLACE MINUS SIGN
8252 LINE(NDTA)=MINUS
NPF=-NPF
C ADVANCE POINTER AND CHECK FOR CURVE
8254 NDTA=NDTA+1
NS=KGFGT(KTF)+10001
IF(NS)8256,8256,8258
8256 LINE(NDTA)=MC
KTF=KTF+1
NDTA=NDTA+1
C PLACE THIS POINT NUMBER IN THE OUTPUT AREA
8258 NT=1000
8260 I=NPF/NT
IF(I)8264,8264,8262
8262 LINE(NDTA)=IBC(I)
NDTA=NDTA+1
8264 NT=NT/10
IF(NT)8266,8266,8260
C PLACE R OR L IF THIS IS CC
8266 IF(NS)8267,8268,8220
8267 LINE(NDTA)=ML
GO TO 8269
8268 LINE(NDTA)=MR
8269 NDTA=NDTA+1
GO TO 8220
C SPACE ONE LINE AFTER FIGURE
8278 IF(IDITO-84)82782,82784,82782
82782 WRITE(MOUT,8243)
C ADVANCE TO NEXT FIGURE
82784 IA=K+ISGN
IF(IDITO-70)82786,7054,82786
82786 IF(IDITO-86)8204,8650,8204
8650 CALL CGDBF(KFTB,6,0,LHDRS+LDND,IBUF)
DO 8654 I=1,6
IF(IBUF(I)-10000)8654,8652,8652
8652 IBUF(I)=10000
8654 CONTINUE
CALL CGDBF(KFTB,6,1,LHDRS+LDND,IBUF)
CALL CGDBF(KFTB,6,0,LHDRS+LRBLD+1,IBUF)
IBUF(1)=0
CALL CGDBF(KFTB,6,1,LHDRS+LRBLD+1,IBUF)
IF(LFTOT-LFPRM)86900,86900,8660
8660 CALL CGDBF(KFTB,6,0,LHDRS+LFTOT,IBUF)
DO 8664 I=1,6
IF(IBUF(I)-10000)8664,8662,8662
8662 IBUF(I)=10000+NFG
8664 CONTINUE
CALL CGDBF(KFTB,6,1,LHDRS+LFTOT,IBUF)
LFPRM=LFTOT
86900 CALL CGGFF
900 CALL RTNONE
RETURN
END
SUBROUTINE CGSPF
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
IF(NCRVS)5590,5510,5510
5510 CONTINUE
C
C INITIALIZATION.
C
ARC = 0.0
ERROR = 0.00005
IND = 0
I = 0
C INPUT DATA.
LS = DATA(1)
L = DATA(2)
C
C FIND DISTANCE NSC-L (STORE AS DIST2)
C
CALL CGGET(NSC,XSC,YSC)
CALL CGGET(L,XSL,YSL)
CALL CGINV(XSC,YSC,XSL,YSL,ANGLE,DIST2)
C
C FIND ANGLE AT J , FROM L TO P.I.
C
CALL CGGET(NTS,XTS,YTS)
CALL CGGET(NPISP,XPISP,YPISP)
XTEM1=XTS
YTEM1=YTS
DO 7 K=1,2
CALL CGINV(XTEM1,YTEM1,XSL,YSL,AZ,DIST1)
CALL CGINV(XTEM1,YTEM1,XPISP,YPISP,ANGLE,DIST1)
C
C DETERMINE POSITION OF POINT L
C
IF(ABS(ABS(AZ-ANGLE)-PI)-HFPI)3,6,6
C
C CASE WHERE NO INTERSECTION OF OFFSET AND SPIRAL.
C
3 WRITE(MOUT,1000)
1000 FORMAT(' #####NO OFFSET POSSIBLE')
CALL CGPUT(LS,CLEAR,CLEAR)
CALL CGPCD(LS)
GO TO 900
C
6 XTEM1=XSC
YTEM1=YSC
C
C FIND ANGLE AT NSC, FROM P.I. TO L.. REPEAT CHECKING PROCEDURE.
C
7 CONTINUE
C
C FIND SPIRAL ARC LENGTH
C
8 ARC = XLS - DIST2*COS(ANGLE)
C
C CALCULATE VALUES OF X(LS), Y(LS)
C
9 THETA = ((ARC/XLS)**2)*THR*SGNSP
Y1 = (THETA*THETA)/42.0
THET4 = THETA**4
Y2 = THET4/1320.
X1 = THETA*THETA/216.
X2 = THET4/9360.
C POINT JJ IS AN INTERMEDIATE POINT.
XTEM2 = ARC*(1. - THETA*THETA*(1./10. - X1 + X2))
YTEM2 = ARC*THETA*(1./3. - Y1 + Y2)
C POINT M IS THE ORIGIN.
C FIND DISTANCE FROM M TO JJ.
CALL CGINV(0.D0,0.D0,XTEM2,YTEM2,ANGLE,DIST1)
ROT = ANGLE + AZLT
CALL CGXTL(XTS,YTS,ROT,DIST1,XINT,YINT)
C
C FIND ANGLE OF TANGENT AT LS.
C
AZ = AZLT + THETA - PI
C
C FIND DISTANCE FROM LS TO L (STORE AS DIST2).
C
CALL CGINV(XINT,YINT,XSL,YSL,ANGLE,DIST2)
C
C FIND ANGLE AT LS FROM KK TO L.
C
ANGLE=ANGLE-AZ
C
C FIND DIFF AND COMPARE WITH ERROR.
C
DIFF = DIST2 * COS(ANGLE)
IF(IND) 32,32,46
32 IF(ABS(DIFF) - ERROR) 33,33,43
33 IND = 1
GO TO 9
43 ARC = ARC - DIFF
C
C AFTER 1000 ITERATIONS,DISCONTINUE.
C
I = I + 1
IF(I - 1000) 9,3,3
C
C OUTPUT PHASE
C
46 CALL CGPUT(LS,XINT,YINT)
IF(LIST)900,48,48
48 CALL CGPCD(LS)
C OUTPUT OFFSET DISTANCE AND ARC LENGTH.
DIST1=DIST2+.00005
WRITE(MOUT,1001) NTS,LS,ARC,DIST1
1001 FORMAT(3X,8HARC FROM,I4,3H TO,I4,1H=,F14.4,8H OFFSET=,F14.4/)
GO TO 900
5590 WRITE(MOUT,5591)
5591 FORMAT(' #####NO SPIRAL DEFINED')
900 CALL RTNONE
RETURN
END
SUBROUTINE CGSPL
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA PI/3.1415926535897932D0/
C
NCRVS = DATA(1)
NTS = DATA(2)
NSC = DATA(3)
NPISP = DATA(4)
AZLT = DATA(5)
SGNSP = DATA(6)*ISGG
C
C FIND DIST. + AZIMUTH OF NTS-NSC.
C
CALL CGGET(NTS,XTS,YTS)
CALL CGGET(NSC,XSC,YSC)
CALL CGINV(XTS,YTS,XSC,YSC,ANG1,X1)
C
C FIND DEFLECTION ANGLE
C
DEFA = ABS(CGNRM(ANG1 - AZLT+PI)-PI)
C
C ROTATE SPIRAL TO HORIZONTAL + STORE ROTATED S.C. IN 1000
C
XDIFF = ABS(X1*COS(DEFA))
YDIFF = ABS(X1*SIN(DEFA))
C
C CALCULATE TOTAL SPIRAL ANGLE FROM DEFLECTION ANGLE
C
THR=3.0D0*(DEFA + ((.0031D0*((3.0D0*57.2957795130823216D0*DEFA)
1 **3))*.00000483D0))
FACT1 = 1. - THR*THR/10. + THR**4/216. - THR**6/9360.
C
C LENGTH OF SPIRAL.
C
XLS = XDIFF/FACT1
C
C DEGREE OF CURVATURE.
C
DC = (THR*200.)/XLS
C
C CALCULATE SHORT AND LONG TANGENT LENGTHS.
C
ST = YDIFF/SIN(THR)
XLT= XDIFF - YDIFF*(COS(THR)/SIN(THR))
C
C LOCATE P.I.
C
CALL CGXTL(XTS,YTS,AZLT,XLT,XPISP,YPISP)
CALL CGPUT(NPISP,XPISP,YPISP)
C
C OUTPUT SECTION.
C
IF(LIST)900,30,30
30 DIST1=XLS+.00005
CALL CGDMS(DC,IDEG,MIN,SEC)
WRITE(MOUT,1000) NCRVS,DIST1,IDEG,MIN,SEC
1000 FORMAT(3X,6HSPIRAL,I5,3H L=,F14.4,4H DC=,I3,'-',I2,'-',F4.1/)
C
C OUTPUT BACK-AZIMUTH.
DIST1=XLT+.00005
CALL CGDMS(CGNRM((AZLT+AZEZ)*ISGG),IDEG,MIN,SEC)
WRITE(MOUT,1001)DIST1,IDEG,MIN,SEC
1001 FORMAT(3X,12HLONG TAN L=,F14.4,4H AZ=,I4,1H-,I3,1H-,F5.1/)
C
C OUTPUT AZIMUTH OF SHORT TANGENT
AZST = AZLT + SGNSP*THR
DIST1=ST+.00005
CALL CGDMS(CGNRM((AZST+AZEZ)*ISGG),IDEG,MIN,SEC)
WRITE(MOUT,1002)DIST1,IDEG,MIN,SEC
1002 FORMAT(3X,12HSHORT TAN L=,F14.4,4H AZ=,I4,1H-,I3,1H-,F5.1/)
C
C OUTPUT COORDS OF T.S., P.I., S.C.
CALL CGPCD(NTS)
CALL CGPCD(NPISP)
CALL CGPCD(NSC)
900 CALL RTNONE
RETURN
END
SUBROUTINE CGSPS
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
IF(NCRVS)5990,5910,5910
5910 CONTINUE
C
C INPUT DATA
C
N3 = DATA(1)
N4 = DATA(2)
XL2 = DATA(4)
R2 = DATA(5)*ISGG
C
C SPIRAL 1...NTS,AZLT,XLS,DC ARE KNOWN. FIND R1.
C
R1 = (100./DC) * SGNSP
C
C SPIRAL 2...N4,XL2,R2 ARE READ. FIND ANGLE A
C
A=DATA(3)
C
SINB = SIN(AZLT)
COSB = COS(AZLT)
C
C FIND INTERSECTION OF THE 2 BACKTANGENTS - POINT N1 = 1000
C
CALL CGGET(NTS,XTS,YTS)
CALL CGGET(N4,XN4,YN4)
CALL CGZIN(XTS,YTS,AZLT,XN4,YN4,A,XTEM1,YTEM1)
C
SINA = SIN(A)
COSA = COS(A)
T1 = 1./ (2.*R1*XLS)
P1 = 1./ (2.*R2*XL2)
C
C FIND DISTANCE FROM NTS TO 1000. STORE AS XX.
C
CALL CGINV(XTEM1,YTEM1,XTS,YTS,ANGLE,XX)
C
C FIND DISTANCE FROM N4 TO 1000. STORE AS D.
C
CALL CGINV(XTEM1,YTEM1,XN4,YN4,ANGLE,D)
88 T2 = XX - XX**5 * T1**2/10.0
T3 = XX**3 * T1/3.0 - XX**7 * T1**3 / 42.0
T4 = 1.0 - XX**4 *T1**2 /2.0
T5 = XX**2 * T1 - XX**6 * T1**3 / 6.0
P2 = D**5 *P1**2 /10.0 - D
P3 = D**7 *P1**3 /42.0 - D**3 * P1/3.0
P4 = D**4 *P1**2 /2.0 - 1.0
P5 = D**6 *P1**3 /6.0 - D**2 * P1
F1 = T2 * COSB - T3*SINB + P2*COSA - P3*SINA + XTS - XN4
F2 = T2 * SINB + T3*COSB + P2*SINA + P3*COSA + YTS - YN4
PF1L = T4*COSB - T5*SINB
PF2L = T4*SINB + T5*COSB
PF1D = P4*COSA - P5*SINA
PF2D = P4*SINA + P5*COSA
C
C COMPUTE AND MAKE CORRECTIONS.
C
DELL = (PF1D*F2 - PF2D*F1)/(PF1L*PF2D -PF1D*PF2L)
DELD = -(PF2L*DELL + F2)/PF2D
XX = XX + DELL
D = D + DELD
IF(ABS(DELL) + ABS(DELD) - 0.01) 89,89,88
89 CALL CGPUT(N3,XN4-P2*COSA+P3*SINA,YN4-P2*SINA-P3*
* COSA)
C
C OUTPUT PHASE.
C
IF(LIST)900,800,800
800 CALL CGPCD(N3)
DIST1=XX+.00005
DIST2=D+.00005
WRITE(MOUT,1000) NTS,DIST1,N4,DIST2
1000 FORMAT(3X,9HDIST FROM,I4,25H TO INTERSECTION POINT IS,F14.4/)
GO TO 900
5990 WRITE(MOUT,5991)
5991 FORMAT(' #####','NO SPIRAL DEFINED')
900 CALL RTNONE
RETURN
END
SUBROUTINE CGSTI
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION MEDGE(4)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
EQUIVALENCE(IN(3),KTFA),(IN(6),KTB),(IN(9),FSTA),(IN(12),FSTB),
*(IN(15),M),(IN(18),XM),(IN(21),YM),(IN(24),SGINT),(IN(27),SGPRS),
*(IN(30),XI),(IN(33),YI),(IN(36),LKAB),(IN(39),LKBB),(IN(42),KVB),
*(IN(45),XAB),(IN(48),YAB),(IN(51),XBB),(IN(54),YBB),(IN(57),XCB),
*(IN(60),YCB)
DATA MBL/' '/
DATA MCL/'CL'/
DATA MEDGE/'LL','LR','RL','RR'/
IF(IDITO-102)10060,10200,10200
10060 IF(SGINT)10070,10064,10070
10064 WRITE(MOUT,10065)
10065 FORMAT(' #####','NO INTERSECTION')
XI=CLEAR
YI=CLEAR
GO TO 10082
10070 IF(LIST)10082,10071,10071
10071 KSGB=SGINT/10000.
KSGA=SGINT-10000.*KSGB
CALL CGGSN(KTFA,KSGA,NPA,NNA,KVA,NCCA)
MINT=MBL
KTFB=DATA(3)
IF(IDITO-100)10084,10078,10076
10076 MINT=MCL
KTFB=DATA(4)
10078 CALL CGGSN(KTFB,KSGB,NPB,NNB,KVB,NCCB)
WRITE(MOUT,10081)MINT,NPA,NNA,NPB,NNB
10081 FORMAT(10XA2,' INTERSECTION IS AT SEGMENTS',2I5,' AND',2I5)
10082 IF(IDITO-100)10086,10086,10083
10083 N=DATA(7)
IF(N)10087,10088,10087
10084 WRITE(MOUT,10085)NPA,NNA
10085 FORMAT(10X,'INTERSECTION IS AT SEGMENT',2I5)
10086 N=DATA(1)
10087 CALL CGPUT(N,XI,YI)
CALL CGPCD(N)
10088 IF(IDITO-100)900,900,10212
10200 IF(ND)10204,10204,10201
10201 ND=0
C RESET MULTICARD ERROR SWITCH
C IF BAD DATA OCCURED ON CONTINUATION CARD, THE
C CARD CANNOT BE USED AS NEXT COMMAND BECAUSE
C THE CARD IMAGE IS DESTROYED BY THIS COMMAND.
MLTCD=0
KTFA=DATA(2)
KTB=DATA(4)
FSTA=0.
FSTB=0.
SGPRS=0.
SGINT=0.
LKAB=0
LKBB=0
M=DATA(6)
CALL CGGET(IABS(M),XM,YM)
IF(XM-CLEAR)10203,10064,10064
10203 CALL CGFIN
10204 IF(DATA(12))10210,10210,10220
10210 M=1
XM=XI
YM=YI
GO TO 10060
10212 IF(SGINT)10220,10213,10220
10213 DO 10219 I=8,11
N=DATA(I)
IF(N)10214,10219,10214
10214 CALL CGPUT(N,CLEAR,CLEAR)
CALL CGPCD(N)
IF(DATA(1))10219,10219,10215
10215 DO 10217 J=1,2
N=N+1
CALL CGPUT(N,CLEAR,CLEAR)
10217 CALL CGPCD(N)
10219 CONTINUE
GO TO 900
10220 KA=1
KB=1
DO 10227 NR=8,11
KB=-KB
IF(KB)10222,10224,10224
10222 KA=-KA
10224 NP=DATA(NR)
IF(NP)10229,10227,10229
10227 CONTINUE
GO TO 900
10229 IF(DATA(12))10230,10230,10240
10230 FSTA=KA*(DATA(3)/2.+DATA(1))
FSTB=KB*(DATA(5)/2.+DATA(1))
KTB=DATA(4)
SGPRS=0.
SGINT=0.
LKAB=0
LKBB=0
DATA(12)=1.
CALL CGFIN
10240 KSGB=SGINT/10000.
KSGA=SGINT-10000.*KSGB
CALL CGGSN(KTFA,KSGA,NPA,NNA,KVA,NCCA)
KTFB=DATA(4)
CALL CGGSN(KTFB,KSGB,NPB,NNB,KVB,NCCB)
IF(LIST)10244,10242,10242
10242 WRITE(MOUT,10081)MEDGE(NR-7),NPA,NNA,NPB,NNB
10244 CALL CGPUT(NP,XI,YI)
CALL CGPCD(NP)
DATA(NR)=0.
DATA(12)=0.
IF(DATA(1))10220,10220,10246
10246 FSTA=DATA(3)
10250 CALL CGGET(NPA,XPA,YPA)
CALL CGGET(NNA,XNA,YNA)
R=DATA(1)
IF(KVA)10252,10262,10252
10252 CALL CGGET(NCCA,XCC,YCC)
CALL CGINV(XPA,YPA,XCC,YCC,AZP,D)
CALL CGINV(XNA,YNA,XCC,YCC,AZN,D)
CALL CGINV(XI,YI,XCC,YCC,AZ,D)
IF((CGNRM(AZN-AZP)-CGNRM(AZ-AZP))*KVA)10254,10264,10264
10254 FSTA=KVA*KA*(FSTA/2.+R)
CALL CGXTL(XI,YI,AZP,FSTA,XP,YP)
CALL CGXTL(XI,YI,AZN,FSTA,XN,YN)
CALL CGINV(XP,YP,XPA,YPA,AZPA,D)
CALL CGINV(XN,YN,XNA,YNA,AZNA,D)
IF(ABS(ABS(ABS(AZP-AZPA)-PI)-HFPI)-
* ABS(ABS(ABS(AZN-AZNA)-PI)-HFPI))10256,10258,10258
10256 AZ=AZP
GO TO 10264
10258 AZ=AZN
GO TO 10264
10262 CALL CGINV(XPA,YPA,XNA,YNA,AZ,D)
AZ=AZ+HFPI
KVA=1
10264 CALL CGXTL(XI,YI,AZ,KA*KVA*R,XP,YP)
NP=NP+1
CALL CGPUT(NP,XP,YP)
CALL CGPCD(NP)
IF(KB)10270,10220,10270
10270 NPA=NPB
NNA=NNB
KVA=KVB
NCCA=NCCB
KA=KB
KB=0
FSTA=DATA(5)
GO TO 10250
900 CALL RTNONE
RETURN
END
SUBROUTINE CGSTK
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
C
C 113 STAKING NOTES
C
C
C CGSTK IS THE DEC VERSION OF OLD 1130 SUR09 PROGRAM.
C ALL POINTS IN THE PRESENT COGO FILE WITHIN A GIVEN
C RADIUS FROM A GIVEN INSTRUMENT STATION ARE LOCATED.
C POINTS ARE LOCATED BY DISTANCE FROM INSTRUMENT STATION
C AND RIGHT AZIMUTH FROM GIVEN BACKSITE STATION.
C BEARING FROM INSTRUMENT STATION TO ALL LOCATED POINTS
C IS ALSO PRINTED (NARROW PRINTOUT FOR FIELDBOOKS).
C
WRITE(MOUT,4)
4 FORMAT(1H0,T8,'TRAN TO BS'/
*1H ,T16'FS',T23'BEAR.'T35'DIST.'T44'AZI.RT.')
C
C GET INSTRUMENT STA, BACKSITE & SEARCH RADIUS
C
INST = DATA(1)
IBS=DATA(2)
RAD=DATA(3)
C
C GET COORDS OF INST STA
C
CALL CGGET(INST,XI,YI)
C
C GET COORDS OF BACKSITE STA
C
CALL CGGET(IBS,XB,YB)
N=0
ICONT=0
C
C GET DIST AND AZ FROM INST TO BACKSITE
C
CALL CGINV(XI,YI,XB,YB,AZI,DISTI)
C
C GET BEARING OF INST TO BS
C
EXAZ=CGNRM((AZI+AZEZ)*ISGG)
NQUAD=IFIX(SNGL(EXAZ/HFPI)) +1
M13=3-(NQUAD-2)*(NQUAD-3)
M24=NQUAD/3*2+2
ANGLE=HFPI-ABS(ABS(EXAZ-PI)-HFPI)
CALL CGDMS(ANGLE,IDEG,MIN,SEC)
C
C
C PRINT OUT COURSE TO BACKSITE
C
WRITE(MOUT,7)INST,IBS,MAXES(M13),IDEG,MIN, SEC,MAXES(M24),DISTI
7 FORMAT(1H0,T7,I4,T15,I4,T20,A1,I2,'-',I2,'-',F4.1,A1,T33,F7.2)
C
C IF NO VALUE FOR FIG NO. SEARCH ENTIRE TABLE
C
IF(DATA(5)) 80,80,82
80 NS=LCDA+1
GO TO 100
82 KTF=DATA(5)
83 CALL CGFIG(KTF,N,NS)
GO TO 110
C
C GET COORDS OF POINT FROM FIG OR TABLE
C
100 N=N+1
NS=NS-1
110 IF(NS) 700,700,120
120 IF(N-INST) 130,500,130
130 IF(N-IBS) 140,500,140
C
140 CALL CGGET(N,XPT,YPT)
C
C GET DIST AND BEARING FROM INST TO PT
C
CALL CGINV(XI,YI,XPT,YPT,AZPT,DISTPT)
C
C TEST TO SEE IF PT IS WITHIN RANGE
C
IF(DISTPT-RAD) 150,150,500
150 EXAZ=CGNRM((AZPT+AZEZ)*ISGG)
NQUAD=IFIX(SNGL(EXAZ/HFPI)) +1
N13=3-(NQUAD-2)*(NQUAD-3)
N24=NQUAD/3*2+2
ANGLE=HFPI-ABS(ABS(EXAZ-PI)-HFPI)
CALL CGDMS(ANGLE,IDEGBR,MINBR,SECBR)
C
C GET AZ TO RT AT INST FROM BS TO PT
C
AZRT=AZI-AZPT
IF(AZRT) 160,170,170
160 AZRT=TWOPI+AZRT
170 CALL CGDMS(AZRT,IDEGRT,MINRT,SECRT)
ICONT=1
C
C A POINT WAS FOUND WITHIN THE RADIUS, PRINT IT OUT
C
WRITE(MOUT,11) N,MAXES(N13),IDEGBR,MINBR, SECBR,MAXES(N24),DIST
1PT,IDEGRT,MINRT, SECRT
11 FORMAT(1H ,T15,I4,1X,A1,I2,'-',I2,'-',F4.1,A1,1X,F7.2,2X,I3,'-',I2
1,'-',F4.1)
500 IF(DATA(5))100,100,83
700 IF(ICONT) 750,750,800
750 WRITE(MOUT,13) RAD
13 FORMAT(1H ,T70,' NO POINTS WITHIN ',F10.2,' FEET')
800 WRITE(MOUT,799)
799 FORMAT(1H0)
CALL RTNONE
RETURN
END
SUBROUTINE CGTRV
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C
C
C 43 ADJUST TRAVERSE COMPASS
C 44 ADJUST TRAVERSE CRANDALL
C 45 ADJUST TRAVERSE TRANSIT
C
C
C MAKE SURE SUFFICIENT DATA PRESENT BEFORE STARTING
IF(ND-3) 900,3,3
C CLEAR LENGTH OF TRAVERSE TO ZERO
3 TLNTH=0.0
C SET CONSTANTS FOR CRANDALL METHOD TO ZERO
C1=0.0
C2=0.0
C3=0.0
C SET TOTAL X AND Y TO ZERO FOR TRANSIT METHOD
XTOTL=0.0
YTOTL=0.0
C INITIALIZE FIGURE NUMBER
KTF=DATA(1)
C GET STARTING COORDINATE OF TRAVERSE
CALL CGFIG(KTF,NPF,NS)
N=NPF
CALL CGGET(N,XTEM2,YTEM2)
C GET NEXT COORDINATE POINT
1 CALL CGFIG(KTF,NPF,NS)
C WAS THE LAST POINT THE END OF TRAVERSE
IF(NS) 99,10,2
C NOT END YET - GET NEXT POINT
2 J=N
N=NPF
XTEM1=XTEM2
YTEM1=YTEM2
CALL CGGET(N,XTEM2,YTEM2)
C COMPUTE DISTANCE AND AZIMUTH OF COURSE
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,AZLST,DIST1)
C UPDATE CRANDALL CONSTANTS AND SUM X AND Y FOR
C TRANSIT METHOD
DELX=XTEM2-XTEM1
DELY=YTEM2-YTEM1
XTOTL=XTOTL+ABS(DELX)
YTOTL=YTOTL+ABS(DELY)
DIST2=100.0*DIST1
C1=C1+DELY*DELY/DIST2
C2=C2+DELX*DELX/DIST2
C3=C3+DELX*DELY/DIST2
C ADD LENGTH TO TOTAL AND CHECK NEXT COURSE
TLNTH=TLNTH+DIST1
GO TO 1
C COMPUTE AND PRINT ERROR OF CLOSURE
C GET COORDINATES OF CLOSURE POINT
10 J=N
N=DATA(2)
CALL CGGET(N,XCLS,YCLS)
C COMPUTE CLUSURE IN X AND Y DIRECTIONS
XDEL=XCLS-XTEM2
YDEL=YCLS-YTEM2
C COMPUTE DISTANCE AND BEARING FROM LAST PT IN FIGURE
CALL CGINV(XTEM2,YTEM2,XCLS,YCLS,CLSAZ,DIST1)
DIST=DIST1+0.00005
CLSAZ=CGNRM((CLSAZ+AZEZ)*ISGG)
NQUAD=IFIX(SNGL(CLSAZ/HFPI))+1
M13=3-(NQUAD-2)*(NQUAD-3)
M24=NQUAD/3*2+2
CLSAZ=HFPI-ABS(ABS(CLSAZ-PI)-HFPI)
CALL CGDMS(CLSAZ,IDEG,MIN,SEC)
WRITE(MOUT,110) J,N,MAXES(M13),IDEG,MIN,SEC,MAXES(M24),DIST
110 FORMAT(/1X,'TRAVERSE CLOSURE FROM',I5,' TO',I5,6XA1,I3,'-',I2,'-'
1,F4.1,
*1XA1,F14.4/)
CLOSE=TLNTH/DIST1
WRITE(MOUT,101) TLNTH,CLOSE
101 FORMAT(1X,'TRAVERSE LENGTH ',F14.4,7X,'CLOSURE IS 1.0 IN ',F14.4/)
C IF CLOSURE IS NOT WITHIN ALLOWABLE ERROR - PRINT ERR
IF(CLOSE-DATA(3)) 7,9,9
7 WRITE(MOUT,103)
103 FORMAT(1X,'TRAVERSE ERROR LARGER THAN ALLOWABLE - ADJUSTMENT TERMI
$NATED'/)
GO TO 900
C SHOULD ANGULAR ADJUSTMENT BE MADE
9 IF(ND-7) 30,11,11
C COMPUTE ANGULAR ERROR
11 BZLST=DATA(7)
AERR=BZLST-AZLST
CALL CGDMS(ABS(AERR),IDEG,MIN,SEC)
WRITE(MOUT,106) IDEG,MIN,SEC
106 FORMAT(1X,'ANGULAR ERROR OF CLOSURE IS',I4,'-',I2,'-',F4.1/)
C IF MAX ANG ERROR SPECIFIED IS IT GREATER THAN ACTUAL
IF(ND-9) 15,12,12
12 ERMAX=TWOPI-DATA(9)
IF(ABS(ERMAX)-ABS(AERR)) 13,15,15
C ANGULAR ERROR TOO LARGE - PRINT ERROR
13 WRITE(MOUT,102)
102 FORMAT(1X,'ANGULAR ERROR LARGER THAN ALLOWABLE - ADJUSTMENT TERMIN
*ATED'/)
GO TO 900
C DISTRIBUTE ANGULAR ERROR OVER TRAVERSE
C PRINT ACTUAL ERROR
15 CONTINUE
C
C ***** CODE FOR ANGULAR ADJUSTMENT MAY BE ADDED HERE AT LATER
C ***** TIME IF JUSTIFIED.
C
C DO COORDINATE ADJUSTED BY METHOD SPECIFIED
C RESET INITIAL FIGURE NUMBER
30 KTF=DATA(1)
C GET STARTING POINT NUMBER OF TRAVERSE
CALL CGFIG(KTF,NPF,NS)
C IF FIRST POINT NUMBER IS THE SAME AS THE POINT
C NUMBER TO START STORING COORDINATES IN THEN
C OVERLAY ORIGINAL FIGURE WITH NEW COORDINATE
C VALUES AND SET 'NIND'=1
C IF IT IS NOT THE FIRST POINT IN THE FIGURE THEN
C START STOREING COORDINATES IN THE POINT NUMBER
C SPECIFIED IN DATA(4) AND SET 'NIND'=2
C
C COMPUTE CRANDALL 'A' AND 'B' CONSTANTS
A=-(XDEL*C3-YDEL*C2)/(C2*C1-C3*C3)
B=-(YDEL*C3-XDEL*C1)/(C2*C1-C3*C3)
C GET OLD COORDINATES OF FIRST POINT IN TRAVERSE
N=NPF
CALL CGGET(N,XTEMP,YTEMP)
XTEM2=XTEMP
YTEM2=YTEMP
C SET UP TO STORE ADJUSTED COORDINATES IN OLD FIGURE
NSTR=N
NIND=1
C CHECK IF POINT NUMBER WAS SPECIFIED FOR
C STORING ADJUSTED COORDINATES
IF(ND-3) 33,33,29
29 NSTR=DATA(5)
IF(NPF-NSTR) 31,33,31
C SET UP TO STORE ADJUSTED POINTS IN NEW LOCATION
31 NIND=2
33 XADD=0.0
YADD=0.0
C START LOOP TO ADJUST TRAVERSE
34 XTEM1=XTEM2
YTEM1=YTEM2
C GET NEXT POINT IN FIGURE
CALL CGFIG(KTF,NPF,NS)
C CHECK IF LAST POINT WAS LAST POINT IN FIGURE
IF(NS) 99,40,35
35 N=NPF
CALL CGGET(N,XTEM2,YTEM2)
C STORE ADJUSTED COORDINATES TO COGO TABLE
CALL CGPOT(NSTR,XTEMP,YTEMP)
NSTR=NSTR+1
CALL CGINV(XTEM1,YTEM1,XTEM2,YTEM2,AZLST,DIST1)
C CHECK IF METHOD IS COMPASS OR CRANDALL
IF(IDITO-44) 37,38,38
C ***** COMPASS METHOD *****
37 XADD=XADD+XDEL*DIST1/TLNTH
YADD=YADD+YDEL*DIST1/TLNTH
GO TO 39
C ***** CRANDALL METHOD ***** OR ***** TRANSIT METHOD *****
38 DELX=XTEM2-XTEM1
DELY=YTEM2-YTEM1
C IS ADJUSTMENT BY 'CRANDALL' OR 'TRANSIT'
IF(IDITO-44) 32,32,41
32 DIST2=100.0*DIST1
C1=DELY*DELY/DIST2
C2=DELX*DELX/DIST2
C3=DELX*DELY/DIST2
XCOR=A*C3+B*C2
YCOR=A*C1+B*C3
XADD=XADD+XCOR
YADD=YADD+YCOR
GO TO 39
C ***** TRANSIT METHOD *****
41 XADD=XADD+XDEL*ABS(DELX)/XTOTL
YADD=YADD+YDEL*ABS(DELY)/YTOTL
C ADD CORRECTIONS TO BASE COORDS FOR STORE
39 XTEMP=XTEM2+XADD
YTEMP=YTEM2+YADD
GO TO (36,34),NIND
36 NSTR=N
GO TO 34
C STORE COORDINATES FOR LAST POINT
40 CALL CGPOT(NSTR,XTEMP,YTEMP)
GO TO 900
C
C CORVE USED IN TRAVERSE DEFINITION - PRINT ERROR
99 WRITE(MOUT,104)
WRITE(MOUT,105)
104 FORMAT(' #####','TRAVERSE DEFINITION INCLUDES CURVES')
105 FORMAT(' #####','** INVALID ** ADJUSTMENT ABORTED')
900 CALL RTNONE
RETURN
END
SUBROUTINE CGVRT
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
C COMMON USED BY CERTAIN PLOTTING ROUTINES
COMMON ANSIZ,JBRAZ,NPLTR
C SPECIAL COMMON USED ONLY BY THIS SUBROUTINE
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
COMMON ICNT,NEND,STA(10),ELEV(10),VCL(10),IPT(10)
COMMON /COGVRT/ NVFLG
IGOTO=IDITO-45
GO TO (46,47,48,49,50),IGOTO
C--- VERTICAL START .OR. INTERMEDIATE DATA
46 IF(NVFLG.EQ.-99) GO TO 15
C--- VERTICAL START
16 ICNT=1
NVFLG=-99
GO TO 18
C--- INTERMEDIATE DATA
15 ICNT=ICNT+1
18 IF(ICNT-10) 35,25,25
25 WRITE(MOUT,1000)
1000 FORMAT(3X,'ERROR...MORE THAN 10 POINTS'/)
GO TO 900
C--- VERTICAL END
47 ICNT=ICNT+1
NEND=ICNT
C RESET INDICATOR FOR VERTICAL START COMMAND
NVFLG=0
IF(ICNT-10) 35,35,34
34 NEND=9
GO TO 40
C
C--- INPUT DATA
C
35 IPT(ICNT)=DATA(1)
STA(ICNT)=DATA(2)
ELEV(ICNT)=DATA(3)
VCL(ICNT)= DATA(5)
IF(IGOTO-2) 900,40,900
C
C--- ALL INPUT READ -- BEGIN CALCULATIONS
C
40 WRITE(MOUT,1001) IPT(1),STA(1),ELEV(1)
1001 FORMAT(3X,'POINT',I5,7X,'STA=',F14.4,4X,'ELEV=',F14.4/)
ICNT=2
45 GB=((ELEV(ICNT)-ELEV(ICNT-1)) / (STA(ICNT)-STA(ICNT-1))) *100.
GF=((ELEV(ICNT+1)-ELEV(ICNT)) / (STA(ICNT+1)-STA(ICNT))) *100.
A= ((GB-GF)/VCL(ICNT)) *50.
HCL= 0.5 * VCL(ICNT)
C
C--- CALCULATE PC.
ELPC= ELEV(ICNT) - (HCL*GB*0.01)
STPC= STA(ICNT) -HCL
C
C--- CALCULATE PT.
ELPT = ELEV(ICNT) + (HCL*GF*0.01)
STPT = STA(ICNT) + HCL
C
C--- CALCULATE PIC.
ELPIC = ELPC + (GB-A*HCL*0.01) * HCL *0.01
STPIC = STA(ICNT)
C
C--- OUTPUT FOR ICNT
WRITE(MOUT,1001) IPT(ICNT),STA(ICNT),ELEV(ICNT)
WRITE(MOUT,1002) STPC,ELPC,STPT,ELPT,STPIC,ELPIC
1002 FORMAT(5X,'NPC',3X,'STA=',F14.4,3X,'ELEV=',F14.4/
$ 5X,'NPT',3X,'STA=',F14.4,3X,'ELEV=',F14.4/
$ 5X,'PIC',3X,'STA=',F14.4,3X,'ELEV=',F14.4/)
WRITE(MOUT,1003) IPT(ICNT-1),IPT(ICNT),GB
1003 FORMAT(5X,'GRADE FROM PT.',I5,2X,'TO PT.',I5,' = ',F10.4/)
ICNT=ICNT+1
IF(ICNT-NEND) 45,60,60
60 WRITE(MOUT,1001) IPT(ICNT),STA(ICNT),ELEV(ICNT)
WRITE(MOUT,1003) IPT(ICNT-1),IPT(ICNT),GF
GO TO 900
C
C--- EVEN STATIONS
C
48 OFFSW =0
KSWCH=1
STAT1=DATA(1)
D=DATA(2)
STAT2=DATA(3)
STATS=STAT1
IX=0
102 ICNT=2
104 HCL=0.5*VCL(ICNT)
GF=((ELEV(ICNT+1)-ELEV(ICNT)) / (STA(ICNT+1)-STA(ICNT))) *100.
106 GB=((ELEV(ICNT)-ELEV(ICNT-1)) / (STA(ICNT)-STA(ICNT-1))) *100.
STPC= STA(ICNT)-HCL
STPT= STA(ICNT)+HCL
IF(IGOTO-5) 110,330,110
110 IF(STAT1-STPC) 130,130,112
112 IF(STAT1-STPT) 140,115,115
115 ICNT=ICNT+1
IF(ICNT-NEND) 104,117,120
117 HCL=0.0
GO TO 106
120 WRITE(MOUT,1004)
1004 FORMAT(3X,'STATION OUT OF RANGE'/)
GO TO 900
130 EL1=GB*(STAT1-STA(ICNT-1)) * 0.01 + ELEV(ICNT-1)
GO TO 160
140 DIST=STAT1-STPC
A=((GB-GF)/VCL(ICNT)) *50.
ELPC=ELEV(ICNT) - (HCL*GB*0.01)
EL1 = ELPC + (GB-A*DIST*0.01) * DIST *0.01
160 IF(OFFSW) 165,165,210
165 GO TO (401,402), KSWCH
401 KSWCH=2
WRITE(MOUT,403)
403 FORMAT(//5X,'STATION',4X,'ELEVATION'/)
402 WRITE(MOUT,1005) STAT1,EL1
1005 FORMAT(1X,F12.4,1X,F12.4)
IX=IX+1
XI=IX
STAT1=STATS+XI*D
IF(D) 900,900,170
170 IF(STAT1-STAT2) 110,110,900
C
C--- OFFSET ELEVATION ROUTINE
49 N =DATA(1)
STAT1=DATA(2)
D =DATA(3)
G =DATA(4)
OFFSW=1
GO TO 102
210 ELN=EL1+D*(G/100.)
WRITE(MOUT,1006) N,STAT1,ELN
1006 FORMAT(3X,'PT.',I4,3X,'STA=',F14.4,3X,'ELEV=',F14.4/)
GO TO 900
C
C--- CURVE DRAIN ROUTINE
50 IPI=DATA(1)
NTEST=NEND-1
DO 315 ICNT=2,NTEST
IF(IPI-IPT(ICNT)) 315,104,315
315 CONTINUE
WRITE(MOUT,1007) IPI
1007 FORMAT(3X,I4,' IS NOT AN INTERSECTION POINT'/)
GO TO 900
330 STAT1=STPC + ((STPT-STPC) *GB / (GB-GF))
DIST= STAT1 - STPC
A = ((GB-GF)/VCL(ICNT)) *50.
ELPC = ELEV(ICNT) - (HCL*GB) *.01
EL1 = ELPC + (GB - A*DIST*0.01) * DIST * 0.01
WRITE(MOUT,1006) IPI,STAT1,EL1
900 CALL RTNONE
RETURN
END
SUBROUTINE CGXTL(XA,YA,AZAB,DAB,XB,YB)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C
C * * * COMPUTE THE COORDINATES XB,YB BY EXTENDING THE LINE
C * * * PASSING THROUGH XA,YA AT AZIMUTH AZAB A DISTANCE
C * * * OF DAB
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
XB=XA+DAB*COS(AZAB)
YB=YA+DAB*SIN(AZAB)
RETURN
END
SUBROUTINE CGZIN(XA,YA,AZA,XB,YB,AZB,XI,YI)
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA CLEAR/1.E20/
COSA=COS(AZA)
SINA=SIN(AZA)
COSB=COS(AZB)
SINB=SIN(AZB)
AB=COSA*SINB
BA=COSB*SINA
DENOM=AB-BA
IF(ABS(DENOM)-.484813681E-4)90,20,20
20 XI=((YA-YB)*COSA*COSB+XB*AB-XA*BA)/DENOM
YI=((XB-XA)*SINA*SINB+YA*AB-YB*BA)/DENOM
GO TO 900
90 XI=CLEAR
YI=CLEAR
900 RETURN
END
FUNCTION KGFGT(NFGT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION LFT(6)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
DATA NRPR/0/
NRDES=(NFGT+5)/6
IF(NRDES-NRPR)10,30,10
10 CALL CGDBF(KFTB,6,0,LHDRS+NRDES,LFT)
99999 CONTINUE
99998 CONTINUE
NRPR=NRDES
30 NSS=NFGT-6*NRPR+6
KGFGT=LFT(NSS)
900 RETURN
END
FUNCTION CGWHL(EPV)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CGWHL=DFLOAT(IDINT(EPV))
RETURN
END
SUBROUTINE CGCMD
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INCLUDE 'CGCMD.DAT'
C
C NEXT STMNT ADDED TO HELP RECURSION
CALL SAVSTK
1 CALL CGCMG(K,IK,JK,MAXCM)
99998 GOTO 1
END
SUBROUTINE CGKEY
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
INCLUDE 'CGKEY.DAT'
DO 49 KS=1,3
KNOW=KY(KS,IDITO)
C* KBZ=0
C* IF(KNOW)26,30,30
C* 26 KBZ=8
C* KNOW=KNOW+16384+16384
30 NKEY=KS*4
C* KN=NKEY-3
DO 48 KK=1,4
32 I=KNOW
KNOW=KNOW/10
DATA(NKEY)=I-KNOW*10
48 NKEY=NKEY-1
C* IF(NKEY-KN)49,49,32
C* 49 DATA(NKEY)=KBZ+KNOW
49 CONTINUE
C CHECK FOR OLD/FORMAT
IF(LDFMT)161,161,155
155 IF(IDITO-11)161,156,156
156 IF(IDITO-14)158,158,161
158 NSSB=3+IDITO/13
DATA(NSSB+1)=DATA(NSSB)
DATA(NSSB)=1
161 CONTINUE
ND=0
LFTOT=LFPRM
KEY=DATA(1)
CALL CGCOC(KN)
IF(KN)800,600,800
600 IF(KEY)660,660,620
620 IF(KEY-9)640,660,640
640 CALL RTNONE
660 CALL CGEDA
800 IF(KEY-7)900,901,902
900 CALL CGDCA
901 CALL CGDFG
902 CALL CGDCB
RETURN
END
SUBROUTINE CGXCM
C
C COPYRIGHT (C) 1976,1977 BY
C DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON NPG,KHDNG(75),IVC,IVT,MTP,MTT,MTC,INDEV,MOUT,LIST,PNAME
1,IN(80),NKL,LK,DATA(12),ND,IDTSV,IDITO,NXJOB,KALPH,MLTCD,INDPLT
2,ISGX,ISGY,IXYF,ISGG,AZEZ,MAXES(4),KFWS,KFTB,LHDRS,LFGA,LCDA,LUNU
3,PI,TWOPI,HFPI,CLEAR,XL,YL,AREA,LFPRM,LFTOT,MAXER,NUMER,LDFMT,NUSE
COMMON KFPLB,KFPL,NPREC,INCPI,IPDEF,KPLEJ,SFPI,IPAPR,JPAPR,GRID
*,ROT,XORG,YORG,KRSZN,NMSZN,KRSZC,NMSZC,XPINC,YPINC,XLP,YLP,XZ,YZ
COMMON NCURV,SGN,R,AA,BA,NPC,NPT,SPC,SPT,APC,APT,NC
COMMON NCRVS,NTS,NPISP,NSC,XLS,DC,SGNSP,THR,AZLT
GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,
*23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,
*45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,
*67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,
*89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,
*107,108,109,110,111,112,113,114,115,116,117,118,
*119,120,121),IDITO
C 1 OLD/FORMAT
1 CONTINUE
C 5 STORE
5 CONTINUE
C 6 KNOWN
6 CONTINUE
C 9 REDEFINE
9 CONTINUE
C 11 LOCATE/AZIMUTH
11 CONTINUE
C 12 LOCATE/BEARING
12 CONTINUE
C 13 LOCATE/ANGLE
13 CONTINUE
C 14 LOCATE/DEFLECTION
14 CONTINUE
C 15 LOCATE/LINE
15 CONTINUE
C 18 PARALLEL/LINE
18 CONTINUE
C 40 DIVIDE/LINE
40 CONTINUE
C 41 DIVIDE/ARC
41 CONTINUE
C 67 EXTEND/ARC
67 CONTINUE
CALL CGLOC
C 119 SOJ
119 CONTINUE
IDITO=2
C 2 START/OF/JOB
2 CONTINUE
CALL CGMTB
C 92 POINT LABELS
92 CONTINUE
CALL CGMIX
994 GO TO 94
C 10 DISTANCE
10 CONTINUE
C 16 INVERSE/AZIMUTH
16 CONTINUE
C 17 INVERSE/BEARING
17 CONTINUE
C 26 AREA
26 CONTINUE
C 27 AREA/AZIMUTHS