FTN,L C C C CC************************************************************ C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * CC************************************************************ C C C C NAME: GCBIM (PART 2 GRAPHICS LINKAGE MODULE) C SOURCE: 92840 - 18080 C RELOC: 92840 - 16002 C C C CC*********************************************************** C SUBROUTINE GCBIM(ICODE,ICDL,IBUFR,IBUFL, 1IRW), 92840-16002 REV.2013 790904 DIMENSION IBUFR(2),IBUFL(2),IGCBF(12) DIMENSION ICODE(2),IGTBL(35) INTEGER PNPOS,ERMSK,ERRLU,ERRCD C C MNEMONIC EQUIVALENCES BETWEEN VALUES IN THE IGTBL AND WHAT C THESE VALUES ARE SUPPOSED TO REPRESENT (E.G. VALUES V1 AND V2 C MNEMONIC EQUIVALENCE IV12). C C THE VALUES IN THE IGTBL CONTAIN THE GCB POINTER IN BITS 0-7 C AND THE LENGTH OF THE DATUM IN BITS 8-15. C C EQUIVALENCE (IGTBL,IGCBL),(IGTBL(2),LUN),(IGTBL(3),ID) EQUIVALENCE (IGTBL(4),IOBUF),(IGTBL(5),ISTAT),(IGTBL(6),MUMM) EQUIVALENCE (IGTBL(7),ICSZE),(IGTBL(8),IG12) EQUIVALENCE (IGTBL(9),IV12),(IGTBL(10),IS12),(IGTBL(11),IADP) EQUIVALENCE (IGTBL(12),IAD),(IGTBL(13),IGDU),(IGTBL(14),IPORG) EQUIVALENCE (IGTBL(15), LORG),(IGTBL(16),IGICB) EQUIVALENCE (IGTBL(17),IPRG), (IGTBL(18),ICLIP) EQUIVALENCE (IGTBL(19), IPDIR),(IGTBL(20),IPSCL) EQUIVALENCE (IGTBL(21),LRG),(IGTBL(22),LDIR) EQUIVALENCE(IGTBL(23),LINE) ,(IGTBL(24),PNPOS) EQUIVALENCE (IGTBL(25),LNTH),(IGTBL(26),N),(IGTBL(27),IUXY) EQUIVALENCE (IGTBL(28),ERRLU),(IGTBL(29),ERMSK),(IGTBL(30),ERRCD) EQUIVALENCE (IGTBL(31),LNTYP),(IGTBL(32),IOSAV) C************************************************************* C 5-26-79 THREE NEW LOGICAL PTRS ADDED INTO IGTBL. C 1) ICHAR POINTS TO THE SOFTWARE WIDTH, AND HEIGHT. C 2) ICSLN POINTS TO THE SOFTWARE SLANT. C 3) ICDIR POINTS TO THE SOFTWARE LDIR. C C THE VALUES ARE STORED EXACTLY AS THE USER REQUESTED IN THE CSIZE CALL. C EQUIVALENCE (IGTBL(33),ICHAR),(IGTBL(34),ICSLN) EQUIVALENCE (IGTBL(35),ICDIR) C C C THIS IS THE GRAPHICS CONTROL BLOCK INTERFACE MODULE C THAT IS RESPONSIBLE FOR INTERFACING BETWEEN THE GCB C AND OTHER MODULES ON THE GRAPHICS PACKAGE. C C CALLING SEQUENCE: CALL GCBIM(ICODE,ICDL,IRW,IBUFR) C WHERE : ICODE = ARRAY OF CODES WHICH CORRESPOND TO C TO THE VARIABLE(S) OF INTEREST IN THE GCB. C ICODE >0 BUT NOT 99 -RETRIEVE OR STORE DATA INTO GCB. C ICODE = 0 - SAVE GCB ADDRESS AND SET 99 INTO FW OF GCB. C ICODE = -99 - CLEAR FIRST WORD OF GCB (PLOTR(0)) C ICODE = 99 - AGL COMMAND OTHER THAN PLOTR(1 OR 4). C CHECK FOR EXISTENCE OF 99 IN FIRST WORD AND C SAVE ADDRESS LOCALLY. ERROR IF 99 NOT IF FIRST C WORD. C C ICDL = LENGTH OF ICODE C IRW = 1(READ),2(WRITE),3(TRANSFER) C IBUFR= BUFFER TO BE FILLED OR EMPTIED C IBUFL= 0 IF LENGTH ASSOCIATED WITH GCB POINTER IS C TO BE USED. C NE.0 - IF LENGTH IN IBUFL IS TO BE USED. C NONZERO IBUFL IS USED FOR SUCH THINGS AS C IOBUF, GICB AND DEVICE SUBROUTINE SCRATCH AREA. C C C DATA LNTH /2001B/ DATA N/517B/ DATA IUXY/2120B/ DATA IGCBL/ 401B/ DATA LUN/ 403B/ DATA ID/ 404B/ DATA IOBUF/1006B/ DATA IOSAV/544B/ DATA ISTAT/ 410B/ DATA LNTYP/1511B/ DATA MUMM/ 2011B/ DATA ERRLU/405B/ DATA ERMSK/534B/ DATA ERRCD/402B/ DATA ICSZE/2015B/ DATA IG12/4021B/ DATA IV12/4031B/ DATA IS12/4041B/ DATA IADP/4051B/ DATA PNPOS/2117B/ DATA IAD/ 4061B/ DATA LINE/3111B/ DATA IGDU/2071B/ DATA IPORG/4101B/ DATA LORG/1514B/ DATA IGICB/ 530B/ DATA ICLIP/ 2075B/ DATA IPRG/2101B/ DATA IPDIR/2105B/ DATA IPSCL/1103B/ DATA LRG/514B/ DATA LDIR/1115B/ C*************************************************************** C 3 NEW PTRS ADDED 5-26-79 BY STEVE YOUNG. C ICHAR IS 4 WORDS LONG (SOFTWARE CHAR WIDTH AND HEIGHT), POINTS TO C WORD 185 IN THE GCB. C ICSLN IS 2 WORDS LONG (SOFTWARE CHARACTER SLANT), POINTS TO C WORD 189 IN THE GCB. C ICDIR IS 2 WORDS LONG (SOFTWARE CHAR DIRECTION) AND POINTS TO C WORD 191 IN THE GCB. C DATA ICHAR/2271B/ DATA ICSLN/1275B/ DATA ICDIR/1277B/ IND = 0 C C C IF(ICODE.EQ.0)GO TO 5 IF(ICODE.EQ.99)CALL ABSAD(ICODE,0,IBUFR) ISTS = 0 CALL PLTER(-98,ISTS) IF(ISTS.EQ.0)GO TO 5 C C CALL ABSAD(8,1,ISTS ,1,IND) C IF(IND.LT.0)GO TO 4 C IND = IAND(ISTS , 40000B) C IF(IND.EQ.0)GO TO 5 C IF(IND.EQ.40000B)CALL PLTER(13) C IBUFL = 1 C RETURN C SEE IF A PLOTR(0) CALL OR PLOTR(1) C IF(ICODE.EQ.99)IBUFL = 1 RETURN C C 5 IF(ICODE.EQ.99)RETURN IF(ICODE)100,150,50 C C TRANSMIT DATA TO/FROM GCB C 50 J = 1 IF(IRW.EQ.3)GO TO 210 DO 200 I=1,ICDL ICD = ICODE(I) IPTR = IAND(IGTBL( ICD),377B) LNGTH = IBUFL IF(IBUFL)52,52,55 52 LNGTH = (IAND(IGTBL(ICD),177400B))/400B 55 CALL ABSAD(IPTR,IRW,IBUFR(J),LNGTH,IND) IF(IND)800,60,800 60 J = J + LNGTH 200 CONTINUE RETURN C C THIS PORTION OF CODE IS RESPONSIBLE FOR TRANSFERRING DATA C FROM ONE SECTION OF THE GCB TO ANOTHER. C 210 IPTR = IAND(IGTBL(ICODE),377B) CALL ABSAD(IPTR,1,IGCBF,10,IND) DO 220 I = 1,IBUFL ICD = IBUFR(I) IPTR = IAND(IGTBL(ICD),377B) LNGTH = (IAND(IGTBL(ICD),177400B))/400B CALL ABSAD(IPTR,2,IGCBF(J),LNGTH,IND) J= J +LNGTH 220 CONTINUE RETURN C C SAVE GCB ADDRESS C 150 CALL ABSAD(ICODE,IRW,IBUFR,LNGTH,IND) RETURN C C RE-INIT GCB C 100 CALL ABSAD(ICODE,0,IBUFR) RETURN C C ERROR GCB DOES NOT EXIST- C 800 RETURN END C C C CC*********************************************************** C SUBROUTINE PLTER(IERCD,IRTN), 92840-16002 REV. 1913 790130 INTEGER PRMER(8),PRM1,PRM2,PRM3,PRM4,PRM5,PRM6,PRM7,PRM8 EM1901 INTEGER HDMSK(7),HDERR(7) EM1901 DIMENSION IBUFR(5),ICODE(2),MSG(14) DIMENSION MEQT(4) DIMENSION IERR(4) EM1913 EQUIVALENCE (IBUFR,LUER),(MSG(4),MSG4),(MSG(5),MSG5) EQUIVALENCE (IBUFR(2),IB2),(MSG(6),MSG6),(MSG(7),MSG7) EM1901 EQUIVALENCE (MSG(8),MSG8),(PRMER,PRM1),(PRMER(2),PRM2) EM1901 EQUIVALENCE (PRMER(3),PRM3),(PRMER(4),PRM4),(PRMER(5),PRM5) EM1901 EQUIVALENCE (PRMER(6),PRM6),(PRMER(7),PRM7),(PRMER(8),PRM8) EM1901 C C THIS ROUTINE IS RESPONSIBLE FOR LETTING THE USER KNOW C WHEN THERES BEEN A MESS UP. C DATA MSFLG/0/ EM1901 DATA MSG/2H ,2HGP,2HS ,2H ,2H ,2H ,2H ,2H ,2H ,2H ,2H , EM1913 1 2H ,2H ,2H / EM1913 DATA MEQT/2400B,3400B,17400B,5000B/ DATA PRMER/2H99,2H ,2H6 ,2H ,2H37,2H ,2HFM,2HP / EM1901 DATA IEFMT/37/ EM1901 DATA ICODE/28,27/ DATA HDERR/1,2,5,3/ DATA HDMSK/0,0,0,0,0,0,0/ DATA IERR/-97,40,199,4/ EM1913 C C C HANDLE SPECIAL CODES NOT REQUIRING MESSAGE OUTPUT. AN ATTEMPT EM1913 C IS BEING MADE HERE TO OPTIMIZE CODE FOR CALL PLTER(-98) BECAUSE EM1913 C IT IS CALLED SO OFTEN. THEREFORE, CODE MAY NOT BE IDEALLY EM1913 C STRUCTURED AND A SMALL AMOUNT OF EXTRA CORE MAY BE SACRIFICED. EM1913 C IF (IERCD.EQ.-98) GO TO 900 EM1913 IF (IERCD.EQ.-99) GO TO 900 EM1913 IF (IERCD.EQ.6) GO TO 820 EM1913 C C FROM NOW ON, OUTPUT OF ERROR MESAGES IS INVOLVED. THE MESSAGE EM1913 C BUFFER IS REFRESHED AFTER EACH USE SO IT'S ALREADY SET UP. EM1913 C EM1913 C SET THE DEFAULT UNIT FOR LOGGING HARD ERRORS TO THE CURRENT CONSOLE, EM1840 C THE VALUE RETURNED BY THE SYSTEM FUNCTION LOGLU EM1840 C LUER = LOGLU(DUMMY) EM1840 C C IENAM = IERCD C C CHECK ON HARD ERRORS 4 & 40 AND SPECIAL CALLS -97 & 199 EM1913 C 2 DO 7 K =1,4 IF(IERCD.EQ.IERR(K))GO TO (1000,800,840,99),K 7 CONTINUE C C MORE CHECKS C C C C GET LU# AND ERROR MASKS C IF(MSFLG.EQ.1.AND.IERCD.GT.39)GO TO 800 15 CALL ABSAD( 5,1,IBUFR,1,ICHR) C C IF LU FOR ERROR LOGGING STILL INITIALIZED AT -1, SET DEFAULT EM1840 C TO CURRENT CONSOLE BY CALLING SYSTEM FUNCTION LOGLU. EM1840 IF(LUER.EQ.-1)LUER = LOGLU(DUMMY) EM1840 C CALL ABSAD(80,1,IB2,4,ICHR) MSFLG = 0 C C ERR CODES 40-94 INDICATE PARAMETER ERRORS IN SUBROUTINE EM1901 IF(IERCD.GT.39)GO TO 800 C C IF IERCD IS LESS THAN -300, WE KNOW THAT WE HAVE AN FMP ERROR CODE EM1913 IF (IERCD.LT.-300) GO TO 400 EM1913 C IMPY = MOD(IERCD,16) INDX = IERCD/16 + 2 IF(IMPY.NE.0) GO TO 60 EM1913 50 INDX = INDX - 1 IMSK = 100000B GO TO 65 60 IMSK = 2 **(IMPY -1) C C SEE WHAT TYPE OF ERROR HARD,SOFT OR FIRM C C FIRM?? C 65 ITST = IAND(IBUFR(INDX) ,IMSK) IF(ITST.EQ.0)GO TO 300 C C FIRM OR HARD ERROR THAT MUST BE REPORTED. C FIRST CONVERT ERROR CODE TO ASCII THEN OUTPUT TO ERROR C LOGGING DEVICE. C C 99 ICHR = 0 CALL CONVT(IENAM,MSG4,ICHR,1) ICHR = ICHR + 6 J = ICHR/2 + 1 C C C C SECTION 160 IS THE END PROCESSING FOR NORMAL, GPS 99, AND FMP ERRORS EM1901 160 CALL REIO(2,LUER,MSG,J) EM1913 C C C REFRESH THE MESSAGE BUFFER, CLEANING IT OUT AFTER USE FOT NEXT TIME EM1913 DO 5 K=4,14 EM1913 MSG(K) = 20040B EM1913 5 CONTINUE EM1913 C EM1913 C EM1913 C FIRM ERROR OR SOFT UPDATE ERROR WORD IN GCB C IF MSGFLG = 1 OR IERCD = 40 DO NOT UPDATE GCB SINCE WE DON'T C HAVE ONE YET. IERCD = 40 IS FROM PLOTR PARAMETER ERROR C AND MSGFLG = 1 INDICATES A MISSING GCB FROM ONE OF THE C OTHER AGL COMMANDS. C 300 IF(MSFLG.EQ.1.OR.IENAM.EQ.40.OR.IENAM.EQ.4)GO TO 305 CALL ABSAD(2 ,2,IENAM,1,ICHR) 305 MSFLG = 0 RETURN C C WE HAVE AN FMP ERROR, SIGNALED BY THE NEGATIVE FMP ERROR CODE. EM1913 C PLTER IS PASSED (FMP ERROR CODE - 300) SO A -99 FMP ERROR WON'T EM1913 C BE CONFUSED WITH A -99 SPECIAL REQUEST CODE. THIS EM1913 C TYPE OF ERROR WILL ALWAYS BE FIRM AND WILL BE LOGGED IN THE GCB AS EM1901 C ERROR 37. THE ERROR MESSAGE WILL LOOK LIKE GPS 37 FMP -XX. EM1901 400 MSG4=PRM5 EM1901 MSG5=PRM6 EM1901 MSG6=PRM7 EM1901 MSG7=PRM8 EM1901 ICHR=0 EM1901 IENAM=IENAM + 300 EM1913 CALL CONVT(IENAM,MSG8,ICHR,1) EM1913 ICHR=ICHR+14 EM1901 J=ICHR/2+1 EM1901 IENAM=IEFMT EM1901 GO TO 160 EM1901 C C PLOTR PARAMETER ERROR C 800 MSG4 = PRM1 MSG5 = PRM2 IF(MSFLG.EQ.0)GO TO 805 C C SET ERROR MESSAGE = GPS 99 C 802 MSG4 = PRM3 MSG5 = PRM4 805 J = 6 CALL GTNAM(IENAM,MSG6,J) GO TO 160 C C MISSING GCB C C C ERROR 6 C 820 MSFLG = 1 RETURN C C ERROR 199 FROM ABSAD PLOTR 0,2,3 MISSING GCB C 840 IENAM = 40 GO TO 802 C C IERCD = -98 OR -99. -98 INDICATES TO RETRIEVE RECENT ERROR C CODE AND REPORT A HARD ERROR. A -99 INDICATES TO REPORT C A HARD ERROR AND CLEAR ERROR CODE. C 900 CALL ABSAD(2,1,IRTN,1,ICHR) C C WE WANT TO RETURN IF IRTN = 1,2,3,5. EM1913 C ELSE CONTINUE. THESE THREE TESTS EM1913 C REPLACE THE COMMENTED OUT DO-LOOP EM1913 C IN AN ATTEMPT TO OPTIMIZE EXECUTION EM1913 IF (IRTN.LE.0) GO TO 951 EM1913 IF (IRTN.GT.5) GO TO 951 EM1913 IF (IRTN.EQ.4) GO TO 951 EM1913 RETURN EM1913 C C DO 950 I=1,4 C IF(IRTN.EQ.HDERR(I))RETURN C950 CONTINUE C 951 MSFLG = 0 EM1913 IRTN = 0 IF(IERCD.EQ.-98)RETURN C C CLEAR ERROR WORD IN GCB C CALL ABSAD(2,2,IRTN,1,ICHR) RETURN C C 1000 IF(IRTN.GT.63.OR.IRTN.LT.0)GO TO 10010 EM1913 CALL EXEC(100015B,IRTN,IEQ5,IEQ4) GO TO 10010 C C MASK OUT DRIVER ID C 625 IEQ5 = IAND(IEQ5,37400B) DO 600 L=1,4 IF(IEQ5.EQ.MEQT(L))RETURN 600 CONTINUE C GO TO 10010 EM1913 C C REPORT ERROR 5 - ILLEGAL LU EM1913 C 10010 IENAM = 5 GO TO 99 END C CC*********************************************************** C SUBROUTINE CONVT(INTX,IABUF,ICHR,N), 92840-16002 REV. 1819 780515 DIMENSION IABUF(2),INTX(2),ICNV(4) DATA MINUS/55B/ DATA ICOMA/54B/ C C THIS ROUTINE CONVERTS N INTEGER VALUES IN "INTX" TO ASCII C AND PLACES IT IN "IABUF". THE FORMAT OF IABUF IF N=2 WHEN C FINISHED LOOKS LIKE: C WORD 1 D1X D2X C " 2 D3X D4X C " 3 D5X , C " 4 D1Y D2Y C " 5 D3Y D4Y C " 6 D5Y C C WHERE D(I) = ASCII DIGIT C C C IF A NEGATIVE NUMBER IS ENTERRED D1 BECOMES A MINUS SIGN C AND THE OTHER DIGITS ARE MOVED DOWN ONE. SOME OF THESE WORDS C MAY NOT BE FILLED UPON RETURN THEREFORE PARAMETER "ICHR" TELLS C THE ACTUAL NUMBER OF CHARACTERS IN IABUF. C C INITIALIZE PARAMETERS C DO 100 K = 1,N IX = INTX(K) IF(INTX(K))5,7,7 5 IX = -IX C C CONVERT INT TO ASCII C 7 CALL CNUMD(IX,ICNV) IF(INTX(K))10,20,20 C C SEE IF A MINUS AND IF SO INSERT MINUS SIGN INTO IABUF(I) C 10 I = ICHR/2 + 1 CALL BYTE(ICHR ,MINUS,IABUF(I)) ICHR = ICHR+1 20 DO 50 J =1,3 C C PLACE EACH BYTE INTO IABUF C I= ICHR/2 + 1 IX = (IAND(ICNV(J) ,177400B))/400B IF(IX.EQ.40B)GO TO 40 CALL BYTE(ICHR ,IX,IABUF(I)) ICHR = ICHR + 1 I = ICHR/2 + 1 40 IX = IAND(ICNV(J) ,377B) IF(IX.EQ.40B)GO TO 50 CALL BYTE(ICHR ,IX,IABUF(I)) ICHR = ICHR + 1 50 CONTINUE I = ICHR/2 + 1 IF(K.EQ.N)RETURN CALL BYTE(ICHR,ICOMA,IABUF(I)) ICHR = ICHR + 1 I = ICHR/2 + 1 100 CONTINUE RETURN END C C CC*********************************************************** C SUBROUTINE BYTE(LR,IBYTE,IWRD), 92840-16002 REV. 1819 780515 DIMENSION MASK(2),MPY(2) DATA MASK/377B,177400B/ DATA MPY/400B,1/ C C C THIS ROUTINE IS RESPONSIBLE FOR PLACING A BYTE EITHER C IN THE LEFT OR RIGHT SIDE OF THE PARAMETER "IWRD". C THE PARAMETER LR INDICATES WHETHER IT IS THE RIGHT OR C LEFT SIDE. C LR = 1 LEFT SIDE C LR = 2 RIGHT SIDE C C THE PARAMETER LR IS INCREMENTED EACH TIME BY THE CALLING C PROGRAM. C L = IAND(LR,1) + 1 IB = IBYTE * MPY(L) IWRD = IOR(IAND(IWRD,MASK(L)),IB) RETURN END SUBROUTINE OUTPT(ICMND,IBUFR,IRW), 92840-16002 REV.1913 781218 INTEGER STPLB DIMENSION IBUFR(2) DATA IGICB/16/ DATA STPLB/24000B/ DATA IECHK/77400B/ C C THIS LITTLE ROUTINE IS RESPONSIBLE FOR SENDING C OUTPUT DATA TO THE GCB AND THEN INVOKING THE C DEVICE SUBROUTINE VIA GSWCH. EM1913 C C MAKE DEVICE SUBROUTINE CHECKS IF NECESSARY C ISTAT = 0 CALL PLTER(-98,ISTAT) IF(ISTAT.NE.0)RETURN CALL GRSTS(1,2000B,ISTAT) IF(ISTAT.NE.0)GO TO 5 CALL GCBIM(IGICB,1,IECHK,1,2) CALL GSWCH(0) EM1913 CALL GCBIM(IGICB,1,ISTAT,1,1) IF(ISTAT.NE.0)GO TO 150 CALL GRSTS(2,0,2000B) C CHECK ON LABEL MODE SITUATION. C ISTAT = 0 5 CALL GRSTS(1,100B,ISTAT) IF(ISTAT.EQ.0)GO TO 10 CALL GCBIM(IGICB,1,STPLB,1,2) CALL GSWCH(0) EM1913 CALL PLTER(35) C C RESET BIT C CALL GRSTS(2,77677B,0) 10 INDX = 1 DO 100 I = 1,ICMND L = IAND(IBUFR(INDX),377B) + 1 IF(IRW.EQ.1)L=1 CALL GCBIM(IGICB,1,IBUFR(INDX),L,2) CALL GSWCH(0) EM1913 INDX = INDX + L 100 CONTINUE RETURN 150 CALL PLTER(ISTAT) RETURN END C C CC*********************************************************** C SUBROUTINE GRSTS(ISET,MASK,NMASK), 92840-16002 REV.1819 780515 C C THIS ROUTINE IS RESPONSIBLE FOR SETTING AND UNSETTING C BITS IN THE GCB STATUS WORD, AND ALSO FOR SENDING C MASKED OUT PORTIONS OF THE STATUS WORD BACK TO THE C CALLER. C C THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING C MEANING: C ISET = 1 RETRIEVE DATA FROM STATUS WORD C = 2 SET BIT(S) IS STATUS WORD. C MASK IS THE PATTERN TO BE ANDED WITH THE STATUS WORD C NMASK- FOR ISET = 1 THIS WORD WILL CONTAIN THE RESULTANT C STATUS WORD ANDED WITH MASK. C FOR ISET = 2 THIS IS THE BIT PATTERN TO BE INCLUSIVE ORED C WITH THE RESULT OF (MASK.AND.STATUS). C ISTAT = 0 CALL PLTER(-98,ISTAT) IF(ISTAT.NE.0)RETURN CALL ABSAD(8,1,ISTAT,1,IND) IST = IAND(ISTAT,MASK) GO TO(10,20),ISET 10 NMASK = IST RETURN C 20 ISTAT = IOR(IST,NMASK) CALL ABSAD(8,2,ISTAT,1,IND) RETURN END INTEGER FUNCTION IADCD(D), 92840-16002 REV.1819 780515 C THIS FUNCTION DETERMINES WHAT FLAVOR OF TRANSFORMATION C CONSTANTS TO USE: A' - D' = 11 MU/GDU C A - D = 12 MU/UDU C ISTAT = 0 IADCD =11 CALL GRSTS(1,1,ISTAT) IF(ISTAT.NE.0)IADCD = 12 RETURN END INTEGER FUNCTION IS1V1(D), 92840-16002 REV.1819 780515 C C THIS FUNTION DETERMINES WHETHER TO USE SOFT CLIP LIMITS C S1 - S2 OR HARD CLIP LIMITS G1-G2 C ISTAT = 0 IS1V1 = 8 CALL GRSTS(1,4,ISTAT) IF(ISTAT.NE.0)IS1V1 = 10 RETURN END SUBROUTINE PKBIN(INBUF,IOBUF,ICHR,NUM, 1N), 92840-16002 REV.1819 780515 DIMENSION INBUF(2),IOBUF(2) DIMENSION IMSK(3),ISHFT(3) DATA IMSK/70000B,1740B,37B/ DATA ISHFT/10000B,40B,1/ C C C THIS SUBROUTINE IS RESPONSIBLE FOR TAKING INTEGER VALUES C IN INBUF AND CONVERTING THEM TO INTO PACKED BINARY FORMAT C AND RETURNING THE VALUES IN IOBUF. C THE DIFFERENT FORMATS THAT ARE RETURNED IN IOBUF ARE IN C THE FOLLOWING FORMATS: C C INBUF IOBUF NUM C X,Y (0-1023) WD 1 BYT1\BYT2 1=ABSOLUTE C (HI-X,LO-X) C WD 2 BYT3\BYT4 C (HI-Y,LO-Y) C X,Y(-16-+15) WD 1 BYT1=X\BYT2=Y 2=SHORT INCREMENTAL C C X,Y(-16384 TO 16383) WD 1 BYT1\BYT2 3=LONG INCREMENTAL C (HI-DX,MID-DX) C WD 2 BYT3\BYT4 C (LO-DX,HI-DY) C WD 3 BYT5\BYT6 C (MID-DY,LO-DY) C C N = NUMBER OF PAIRS TO CONVERT K = 1 C C BRANCH TO APPROPRIATE PARSER C C GO TO (10,20,30),NUM C C ABSOLUTE C 10 DO 100 J=1,N IBYTE =(IOR(IAND(INBUF(J),1740B), 2000B))/40B CALL BYTE(ICHR,IBYTE,IOBUF(K)) K = IAND(ICHR,1) + K ICHR = ICHR+1 IBYTE = IOR(IAND(INBUF(J),37B),40B) CALL BYTE(ICHR,IBYTE,IOBUF(K)) K = IAND(ICHR,1) + K ICHR = ICHR+1 100 CONTINUE RETURN C C SHORT INCREMENTAL C C0 LOOP = N/2 C JJ = 0 C DO 200 J=1,LOOP C DO 198 KK =1,2 C JJ = JJ+1 C IBYTE = IOR(IAND(INBUF(JJ),37B),40B) C CALL BYTE(ICHR,IBYTE,IOBUF(K)) C K = IAND(ICHR,1) + K C ICHR = ICHR + 1 C98 CONTINUE C00 CONTINUE C RETURN C C LONG INCREMENTAL C C0 DO 300 J=1,N C DO 400 I=1,3 C INB = INBUF(J) C IBYTE = IOR((IAND(IMSK(I),INB)/ISHFT(I)),40B) C IF(INB.LT.0.AND.I.EQ.1)IBYTE = IOR(IBYTE,30B) C CALL BYTE(ICHR,IBYTE,IOBUF(K)) C K = IAND(ICHR,1) + K C ICHR = ICHR + 1 C00 CONTINUE C00 CONTINUE C RETURN END C NAME: CLIPPING ALGORITHM C C C CC*********************************************************** C SUBROUTINE CLPNG(POINT,CLPTS,ENDPT, 1IFLG), 92840-16002 REV.1819 780515 INTEGER OC1,OC2,OCODE DIMENSION POINT(4),CLPTS(4) C C THIS IS THE CLIPPING ALGORITHM FOR THE C AGL GRAPHICS PACKAGE. THE PARAMETERS IN THE CALLING C SEQUENCE HAVE THE FOLLOWING MEANINGS: C C POINT - 4 WORD ARRAY WITH VECTOR ENDPOINT X(B),X(A) C CLPTS - 4 WORD ARRAY WHICH WILL CONTAIN THE RESULTS OF THE C COMPUTATIONS CONTAINED WITHIN. C ENDPT - DIAGONAL END POINTS FOR WINDOW OR VIEWPORT C IFLG - = 0 IF X(A) IS INSIDE BOUNDARY C = 1 " " " OUTSIDE C C DELTA = .5 IF(IFLG.LT.0)DELTA = 0. IND = IFLG IFLG = 0 C C C C MAKE TRIVIAL TEST TO SEE IF LINE IS INVISIBLE C C OC1 = OCODE(POINT,ENDPT,DELTA) OC2 = OCODE(POINT(3),ENDPT,DELTA) IF(IAND(OC1,OC2).EQ.0)GO TO 90 50 IFLG = 1 IF(IND.LT.0)RETURN GO TO 200 C C LINE IS PARTIALLY VISIBLE OR COMPLETELY VISIBLE, THE C LINES OF CODE DETERMINE THIS. C 90 DO 95 I=1,4 CLPTS(I) = POINT(I) 95 CONTINUE IF(OC1.EQ.0)GO TO 100 CALL CLIPO(OC1,CLPTS(1),CLPTS(2),CLPTS(3),CLPTS(4),ENDPT) C C CLPTS 1 AND 2 NOW CONTAIN CLIPPED POINTS, NOW DEAL WITH C OTHER END-POINT. C 100 IF(OC2.EQ.0)GO TO 200 CALL CLIPO(OC2,CLPTS(3),CLPTS(4),CLPTS,CLPTS(2),ENDPT) IF(OC1.NE.0.OR .OC2.NE.0)GO TO 50 C C NOW SEE IF SOFT CLIPPING IS ON AND IF SO CUT OUT. IF HARD C CLIPPING IS IN FORCE ASCERTAIN WHETHER OR NOT THE HARD CLIP C LIMITS HAVE BEEN REDEFINED AND WHETHER OR NOT THE DEVICE CAN C HANDLE IT. IF THE DEVICE CAN DO ITS ON CLIPPING FOR REDEFINED C HARD CLIP LIMITS LET IT. C 200 ISTAT = 0 CALL GRSTS(1,4,ISTAT) IF(ISTAT.NE.0)RETURN CALL GRSTS(1,10B,ISTAT) IF(ISTAT.NE.0)RETURN C C LET DEVICE DO IT. C DO 250 I=1,4 CLPTS(I) = POINT(I) 250 CONTINUE IF(IFLG.EQ.1)CALL PLTER(20) IFLG= 0 RETURN END SUBROUTINE CLIPO(IOC,X1,Y1,X2,Y2, 1ENDPT), 92840-16002 REV.1819 780515 INTEGER OCODE DIMENSION ENDPT(4),XI(2),ENDXY(4) EQUIVALENCE (ENDXY,END1),(ENDXY(2),END2),(ENDXY(3),END3) EQUIVALENCE (ENDXY(4),END4) C C THIS ROUTINE PUSHES THE ENDPOINT X1,Y1 TOWARD THE C THE CLIPPING BOUNDARY IT IS HANGING OFF. C INDX = IOC DELTA = .5 C WRITE(6,500)(ENDPT(K),K=1,4) C00 FORMAT(2X,"ENDPOINTS =",4(X,F7.3)) C WRITE(6,1000)IOC,X1,Y1,X2,Y2 C000 FORMAT(2X,"OC,X1-Y2",2X,K6,4(X,F8.3)) C LOOP = 0 5 DX = X2 - X1 DY = Y2 - Y1 K = 1 SLOPE = DY/DX DO 7 L=1,4 7 ENDXY(L) = ENDPT(L) IF(INDX.GT.2)INDX = (INDX/4) + 2 GO TO(10,20,30,40),INDX C C PUSH TOWARD LEFT SIDE C 10 Y1 = Y1 + SLOPE * (ENDPT - X1) X1 = END1 GO TO 50 C C PUSH TOWARD RIGHT SIDE C 20 XR = END3 Y1 = Y1 + SLOPE * (XR - X1) X1 = XR GO TO 50 C C PUSH TOWARD BOTTOM C 30 YB = END2 X1 = X1 + (1/SLOPE) * (YB - Y1) Y1 = YB K = 2 GO TO 50 C C PUSH DOWN ON TOP C 40 YT = END4 X1 = X1 + (1/SLOPE) * (YT - Y1) Y1 = YT C K = 2 C TEST FOR INNESS C 50 XI = X1 XI(2) = Y1 C WRITE(6,2000)X1,Y1 C000 FORMAT(2X,"CLIPPED POINTS X1,Y1",2(X,F7.3)) INDX = OCODE(XI,ENDPT,DELTA) IOC = INDX C WRITE(6,3000)INDX C000 FORMAT(2X,"ITST = ",K6) C LOOP = LOOP + 1 IF(LOOP.GT.10)RETURN IF(INDX.NE.0)GO TO 5 IOC = 0 RETURN C C TAKE CARE OF CORNER CASE C C00 IF(ABS(OVSLP - ABS(SLOPE)).GE.EPSI)RETURN C IOC = 0 C GO TO(610,620),K C10 Y1 = YEND C WRITE(6,2)Y1 C FORMAT(2X, "Y1 =",F7.2) C RETURN C20 X1 = XEND C WRITE(6,3)X1 C FORMAT(2X,"X1=",F7.2) C RETURN END INTEGER FUNCTION OCODE(POINT,ENDPT, 1DELTA), 92840-16002 REV.1819 780515 INTEGER GRIFX DIMENSION POINT(2),ENDPT(4) C C THIS LITTLE FUNTION IS RESPONSIBLE FOR COMPUTING C THE OUT CODES FOR THE CLIPPING ALGORITHM. C ICD1 = 0 ICD2 = 0 OCODE = 0 C C C WRITE(6,1200)IPT1,IPT2,POINT(1),POINT(2) C200 FORMAT(2X,2(X,I4),2X,2(X,F7.2)) C WRITE(6,1000)IEND1,IEND2,IEND3,IEND4 C000 FORMAT(2X,"IEND ",4(X,I3)) C C LOWER LEFT C IF(POINT(1).LT.(ENDPT(1) - DELTA)) ICD1 = 1 IF(POINT(2).LT.(ENDPT(2) - DELTA))ICD2 = 4 C C UPPER RIGHT C IF(POINT(1).GT.(ENDPT(3) + DELTA))ICD1 = 2 IF(POINT(2).GT.(ENDPT(4) + DELTA))ICD2 = 8 OCODE = ICD1 + ICD2 RETURN END END$