FTN4,L C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS C C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- C C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- C C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C NAME: SYMBR -- DVZ12 CHECKOUT C SOURCE: 92840-18109 C RELOC: 92840-16012 C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C PROGRAM SYMBR(,51), 92840-16012 REV.2040 800807 C C****************************************************************** C C MODIFIED BY PHIL P. OF BOISE TO CORRECT ABORT PROBLEM C WHEN LABELS EXTEND BEYOND LOGICAL LIMITS FOR THE 2040 PCO C C******************************************************************* C DIMENSION IPRAM(5),IEQT(20),IBUFR(133),IPLTB(1040) 1 ,ITEMP(50) INTEGER FNAME DIMENSION LU(3),FNAME(3) EQUIVALENCE (IPRAM,IBUFF),(IEQTP,IPRAM(2)),(IEQT(10),EANG) EQUIVALENCE (IPRAM(3),IPNT1),(IEQT(6),SCALE) CALL RMPAR(IPRAM) IF (IPRAM.EQ.0)STOP CALL Z12RV(IEQTP,IEQT,IBUFF,IBUFR) LU(1)=-IEQT(1) LU(2)=IEQT(5) LU(3)=IEQT(15) DO 5 I=1,3 5 FNAME(I)=IEQT(I+1) X=IEQT(8) Y=IEQT(9) IF (X.LT.0.) GO TO 211 PP2040 IF (Y.LT.0.) GO TO 211 PP2040 IF (X.GT.920.)GO TO 211 PP2040 YMAX=72*IEQT(16) PP2040 IF (Y.GT.YMAX)GO TO 211 PP2040 XMAX=920. PP2040 THETA=EANG ILEN=IEQT(16) CALL Z12IN(LU,1,IERR,FNAME,ILEN,IPLTB,1040,0) CALL Z12WD(IEQT(12)) CALL Z12MD(IEQT(13)) N=IBUFR(1)/2 IT1=IBUFR(N+1)/400B IT2=IBUFR(N+1)-IT1*400B IF(IT2.EQ.40B)IBUFR(1)=IBUFR(1)-1 ILF=0 IF((IT2.EQ.137B).OR.((IT2.EQ.40B).AND.(IT1.EQ.137B)))ILF=1 IF (ILF.EQ.1)IBUFR(1)=IBUFR(1)-1 IF(IEQT(14).EQ.-1)GO TO 200 SINT=SIN(THETA) COST=COS(THETA) PORX=X-7*SCALE*SINT PORY=Y+7*SCALE*COST DO 100 I=1,IBUFR J=(I-1)/2 IT1=IBUFR(J+2)/256 IT2=IBUFR(J+2)-IT1*256 DO 80 J=1,50 80 ITEMP(K)=0 IF (2*(I/2).EQ.I)IT1=IT2 NUM=1 CALL Z12FN(IEQT(1),IRBLU) CALL Z12CV(IEQT(14),ITEMP,IT1,NUM,IRBLU) IF(ITEMP(1).EQ.10000)GO TO 103 K=1 L=K DO 90 J=2,NUM IF((ITEMP(J).GT.10000).OR.(ITEMP(J).EQ.0))GO TO 92 L=L+1 90 CONTINUE 92 CONTINUE DO 93 J=K,L IVL=ITEMP(J) IF (IVL.GT.10000)IVL=IVL-10000 IF (IVL.EQ.0)GO TO 103 IX1=IVL/100 IX2=IVL-IX1*100 IPX1=IX1/10 IPY1=IX1-IPX1*10 IPX2=IX2/10 IPY2=IX2-IPX2*10 PX1=FLOAT(IPX1-1)*SCALE PY1=FLOAT(IPY1-1)*SCALE PX2=FLOAT(IPX2-1)*SCALE PY2=FLOAT(IPY2-1)*SCALE PX=PORX+PX1*COST+PY1*SINT+.5 PY=PORY+PX1*SINT-PY1*COST+.5 IF(PX.GT.XMAX.OR.PX.LT.0)GO TO 93 PP2040 IF(PY.GT.YMAX.OR.PY.LT.0)GO TO 93 PP2040 CALL Z12PT(PX,PY,3) PX=PORX+PX2*COST+PY2*SINT+.5 PY=PORY+PX2*SINT-PY2*COST+.5 IF(PX.GT.XMAX.OR.PX.LT.0)GO TO 93 PP2040 IF(PY.GT.YMAX.OR.PY.LT.0)GO TO 93 PP2040 CALL Z12PT (PX,PY,2) 93 CONTINUE 103 PORX=PORX+7*COST*SCALE 100 PORY=PORY+7*SINT*SCALE GO TO 210 211 IDX=200. PP2040 IDY=200. PP2040 GO TO 212 PP2040 200 CONTINUE CALL Z12SB(X,Y,SCALE,IBUFR,THETA,0) 210 CALL Z12CL ANGLE=THETA-1.570796327 IF (ANGLE.LT.0.0)ANGLE=ANGLE+6.283185308 DX=COS(ANGLE)*SCALE*10.0 DY=SIN(ANGLE)*SCALE*10.0 IF(ILF.EQ.1)DX=COS(THETA)*SCALE*7.*IBUFR(1) IF(ILF.EQ.1)DY=SIN(THETA)*SCALE*7.*IBUFR(1) IDX=DX IDY=DY 212 CALL Z12RL(IEQTP,IPNT1,IDX,IDY) PP2040 END C C C SUBROUTINE Z12CV (ICHST,IBFF,ICHR,NUM,LU) DIMENSION IBFF(100),ITEMP(63),IVEC(40),IMSK(7),IDOT(7,9) 1,ITP(16) DATA ITP/0,10000B,20000B,30000B,40000B,50000B,60000B,70000B 1,100000B,110000B,120000B,130000B,140000B,150000B,160000B,170000B/ IF ((ICHST.GT.15).OR.(ICHST.LT.0))ICHST=0 ICHT=ITP(ICHST+1)+ICHR INUM=NUM*9+1 CALL EXEC(1,LU,IBFF,INUM,ICHT) JCNT=0 5 DO 100 K=1,NUM DO 6 I=1,7 6 IMSK(I)=2**(7-I) DO 11 J=1,9 L=(K-1)*9+J+1 DO 10 I=1,7 IDOT(I,J)=0 L1=(J-1)*7+I IF (IAND(IBFF(L),IMSK(I)).EQ.0) GO TO 10 IDOT(I,J)=1 10 ITEMP(L1)=IDOT(I,J) 11 CONTINUE L=0 DO 30 J=1,9 DO 25 I=1,7 IF (IDOT(I,J).EQ.0)GO TO 25 DO 22 M=I,7 IF (IDOT(M,J).EQ.0)GO TO 23 IDOT(M,J)=0 22 M1=M 23 IF(M1.EQ.I)GO TO 25 L=L+1 IVEC(L)=I*1000+J*100+M1*10+J 25 CONTINUE DO 30 M1=1,7 L1=(J-1)*7+M1 30 IDOT(M1,J)=ITEMP(L1) DO 40 I=1,7 DO 35 J=1,9 IF (IDOT(I,J).EQ.0)GO TO 35 DO 32 M=J,9 IF (IDOT(I,M).EQ.0)GO TO 33 IDOT(I,M)=0 32 M1=M 33 IF(J.EQ.M1)GO TO 35 L=L+1 IVEC(L)=I*1000+J*100+I*10+M1 35 CONTINUE DO 40 M1=1,9 L1=(M1-1)*7+I 40 IDOT(I,M1)=ITEMP(L1) DO 50 J=1,8 DO 50 I=1,6 IF (IDOT(I,J).EQ.0)GO TO 50 IF (IDOT(I+1,J+1).EQ.0)GO TO 50 IF (IDOT(I,J+1).EQ.1)GO TO 50 IF (IDOT(I+1,J).EQ.1)GO TO 50 L=L+1 IVEC(L)=I*1000+J*100+(I+1)*10+(J+1) 50 CONTINUE DO 60 J=1,8 DO 60 I=2,7 IF (IDOT(I,J).EQ.0)GO TO 60 IF(IDOT(I-1,J+1).EQ.0)GO TO 60 IF(IDOT(I-1,J).EQ.1)GO TO 60 IF(IDOT(I,J+1).EQ.1)GO TO 60 L=L+1 IVEC(L)=I*1000+J*100+(I-1)*10+(J+1) 60 CONTINUE DO 70 I=1,L-1 M=I+1 DO 70 J=M,L IF(IVEC(J).NE.IVEC(I))GO TO 70 L=L-1 DO 65 M1=J,L 65 IVEC(M1)=IVEC(M1+1) 70 CONTINUE DO 280 I=1,L-1 IX1=IVEC(I)/100 IX2=IVEC(I)-IX1*100 IX3=IX1/10 IY3=IX1-10*IX3 IX4=IX2/10 IY4=IX2-IX4*10 IF (IX2.EQ.IX1+1)GO TO 150 IF (IX2.EQ.IX1+10)GO TO 140 GO TO 280 140 DO 145 M1=I+1,L IY1=IVEC(M1)/100 IY2=IVEC(M1)-IY1*100 IF (IY4.EQ.1)GO TO 141 IF((IX1.EQ.IY1).AND.(IY2.EQ.IY1-9).AND.(IDOT(IX4,IY4-1).EQ.1)) 1 IX2=IX2-1 141 IF (IY3.EQ.1)GO TO 142 IF ((IX2.EQ.IY1).AND.(IY2.EQ.IY1+11).AND.(IDOT(IX3,IY3-1).EQ.1)) 1 IX1=IX1-1 142 IF (IY4.EQ.9)GO TO 143 IF ((IX1.EQ.IY2).AND.(IY1.EQ.IY2-11).AND.(IDOT(IX4,IY4+1).EQ.1)) 1 IX2=IX2+1 143 IF (IY3.EQ.9)GO TO 145 IF ((IX2.EQ.IY2).AND.(IY1.EQ.IY2+9).AND.(IDOT(IX3,IY3+1).EQ.1)) 1 IX1=IX1+1 145 CONTINUE GO TO 280 150 DO 155 M1=I+1,L IY1=IVEC(M1)/100 IY2=IVEC(M1)-IY1*100 IF (IX3.EQ.1)GO TO 151 IF((IX2.EQ.IY1).AND.(IY2.EQ.IY1+11).AND.(IDOT(IX3-1,IY3).EQ.1)) 1 IX1=IX1-10 151 IF (IX3.EQ.7)GO TO 152 IF((IX2.EQ.IY1).AND.(IY2.EQ.IY1-9).AND.(IDOT(IX3+1,IY3).EQ.1)) 1 IX1=IX1+10 152 IF (IX4.EQ.1)GO TO 153 IF((IX1.EQ.IY2).AND.(IY1.EQ.IY2+9).AND.(IDOT(IX4-1,IY4).EQ.1)) 1 IX2=IX2-10 153 IF (IX4.EQ.7)GO TO 155 IF ((IX1.EQ.IY2).AND.(IY1.EQ.IY2-11).AND.(IDOT(IX4+1,IY4).EQ.1)) 1 IX2=IX2+10 155 CONTINUE 280 IVEC(I)=IX1*100+IX2 DO 180 I=1,L-1 M=I+1 IX1=IVEC(I)/100 IX2=IVEC(I)-IX1*100 IF((IX2.NE.IX1+11).AND.(IX2.NE.IX1-9))GO TO 180 DO 175 M1=M,L 69 IY1=IVEC(M1)/100 IY2=IVEC(M1)-IY1*100 IF (IX2.NE.IY1)GO TO 175 IF((IY2.NE.IY1+11).AND.(IY2.NE.IY1-9))GO TO 175 IF((IX2.GT.IX1).AND.(IY2.GT.IY1))GO TO 171 IF((IX2.LT.IX1).AND.(IY2.LT.IY1))GO TO 173 GO TO 175 171 IX2=IY2 L=L-1 IF (M1.GT.L)GO TO 180 DO 172 M2=M1,L 172 IVEC(M2)=IVEC(M2+1) GO TO 69 173 IX2=IY2 L=L-1 IF (L.LT.M1)GO TO 180 DO 174 M2=M1,L 174 IVEC(M2)=IVEC(M2+1) GO TO 69 175 CONTINUE 180 IVEC(I)=IX1*100+IX2 IF (L.EQ.0) GO TO 91 DO 90 I=1,L IX1=IVEC(I)/1000 IY1=IVEC(I)/100-IX1*10 IX2=IVEC(I)/10-(IX1*100+IY1*10) IY2=IVEC(I)-(IX1*1000+IY1*100+IX2*10) IF (IX1.EQ.IX2)GO TO 75 IF (IY1.EQ.IY2)GO TO 80 IT=IX1 DO 71 JT=IY1,IY2 IDOT(IT,JT)=0 IT=IT+1 IF (IX1.GT.IX2)IT=IT-2 71 CONTINUE GO TO 85 75 DO 76 M1=IY1,IY2 76 IDOT(IX1,M1)=0 GO TO 85 80 DO 81 M1=IX1,IX2 81 IDOT(M1,IY1)=0 85 CONTINUE 90 CONTINUE 91 DO 95 I=1,7 DO 95 J=1,9 IF (IDOT(I,J).EQ.0)GO TO 95 L=L+1 IVEC(L)=I*1000+J*100+I*10+J 95 CONTINUE IF (L.GT.0)GO TO 96 JCNT=JCNT+1 IBFF(JCNT)=10000 GO TO 100 96 IVEC(1)=IVEC(1)+10000 DO 99 I=1,L JCNT=JCNT+1 99 IBFF(JCNT)=IVEC(I) 100 CONTINUE NUM=JCNT RETURN END C C C SUBROUTINE Z12FN(LU,RBACK) INTEGER RBACK RBACK=6 IF (LU.NE.0) GO TO 30 RETURN 30 IDRT=IGET(1652B) LUMAX=IGET(1653B) IF (LUMAX .GT. 63) LUMAX = 63 DS2040 IF (LU.GT.LUMAX)RETURN IPNT=IDRT+(LU-1) IEQT=IAND(IGET(IPNT),77B) DO 100 I=1,LUMAX RBACK=I IPNT=IDRT+(I-1) JEQT=IAND(IGET(IPNT),77B) IF(IEQT.NE.JEQT)GO TO 100 JSC=IAND(IGET(IPNT),174000B)/2048 IF(JSC.EQ.3)RETURN 100 CONTINUE RBACK=LU RETURN END END$