FTN4 PROGRAM TGPI3(5), 92903-16379 REV.1913 790117 0950 C C SOURCE 92903-18379 C C C C ************************************************************** 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. * C ************************************************************** C C C C PRGMR : JEAN CHARLES MIARD (HPG) C C C********************************************************************* C* * C* THIS IS A SEGMENT OF THE TGP PROGRAM USED TO * C* PRINT THE TRANSACTION SPECIFICATIONS ON THE LIST DEVICE . * C* THE 3070 LABEL ATTACHED TO THE TRANSACTION DEFINED IS ALSO * C* PRINTED . * C* * C* IF INDIC = -1 : RETURN FROM TGP11 THE IMAGE OPERATIONS * C* HAVE BEEN LISTED . * C* IF INDIC = 4278 : REQUEST TO LIST A TRANSACTION SPEC COMING * C* FROM TGP1 * C* * C********************************************************************* C C C DECLARATIONS COMMON VARIABLES ************* C COMMON ILU,ISCRN,IQST,ISKIP,INDIC COMMON IFORM(766) COMMON JFORM(1400) COMMON MFORM(16) COMMON LFORM(39) COMMON ITT COMMON IKEY(26,3) COMMON IUMAX,IMMAX COMMON IMODB COMMON ILITE(15) COMMON IMAI(45,5) COMMON IMFLG,IMAS,IMDT,IMKY COMMON KFORM(2704) COMMON ILIBR(61) COMMON NIMAG C C LOCAL VARIABLES **************** C DIMENSION IBUF(40),IBUF2(40),JLIT(6,3),NLAB(3,4),NCOL(4) DIMENSION IK1(6),ITERM(4),IALPHA(26),IDATE(15) DIMENSION INAM(3),KTERM(14,4),ITIME(5),IPRES(27) DIMENSION LABL(3),LABH(3),LABO(3) DIMENSION IAS66(34),IAS79(40) C LOGICAL ISSPA,ISBIT C LOGICAL LPRINT,LALPHK,LALPHD,LTYPE3,LTYPE5 LOGICAL L3075A,L3075N,L3070B,L3070A LOGICAL LTERM(4) EQUIVALENCE (LTERM(1),L3075A) EQUIVALENCE (LTERM(2),L3075N) EQUIVALENCE (LTERM(3),L3070B) EQUIVALENCE (LTERM(4),L3070A) C C C C DATA VALUES ************* C DATA JLIT /2HER,2HRO,2HR ,2HLI,2HGH,2HT , * 2HCO,2HMP,2HL.,2HTR,2HAN,2HS., * 2HSE,2HLE,2HCT,2H T,2H.S,2H. / DATA IK1/2H ,2H R,2HES,2HET,2H ,2H / DATA INAM/2HTG,2HPI,2H4 / DATA IPRES/15530B,15555B,15446B,65460B, C41040B, 15542B,6412B,6412B,15446B,62112B,2HPr,2Hes,2Hs ,15446B, C62113B,2HNE,2HXT,2H S,2HCR,2HEE,2HN ,15446B,62112B,2Hke,74433B, C23144B,40040B/ DATA KTERM/2HHP,2H30,2H75,2H/6,2H (,2HAL,2HPH,2HA ,2HKE,2HYB, * 2HOA,2HRD,2H) ,2H , * 2HHP,2H30,2H75,2H/6,2H (,2HNU,2HME,2HRI,2HC ,2HKE, * 2HYB,2HOA,2HRD,2H) , * 2HHP,2H30,2H70,2HB ,2H ,2H ,2H ,2H ,2H ,2H , * 2H ,2H ,2H ,2H , * 2HHP,2H30,2H70,2HA ,2H ,2H ,2H ,2H ,2H ,2H , * 2H ,2H ,2H ,2H / DATA ITERM/0,0,0,-1/ DATA IALPHA/2HA>,2HB>,2HC>,2HD>,2HE>,2HF>,2HG>,2HH>,2HI>, * 2HJ>,2HK>,2HL>,2HM>,2HN>,2HO>,2HP>,2HQ>,2HR>, * 2HS>,2HT>,2HU>,2HV>,2HW>,2HX>,2HY>,2HZ>/ DATA NLAB/5,5,4,5,5,4,4,4,4,4,4,4/ DATA NCOL/5,5,4,4/ DATA LABL/11,16,22/ DATA LABH/15,21,26/ DATA LABO/13,0,0/ DATA IAS66/34*25052B/ DATA IAS79/40*25052B/ IAS66(1)=2H * IAS66(34)=2H* IAS79(1)=2H * C C*********************************************************************** C C GET LIST LU AND IF INDIC = -1 GO TO FINISH LISTING C C************************************************************************ C LU=ISKIP C-----IF LIST LU IS NOT DEFAULT TERMINAL, LOCK IT. IF(LU.EQ.ILU) GO TO 49 C-----1ST UNLOCK ALL LOCKED LU'S CALL LURQ(100000B,LU,1) C-----NOW LOCK THE LIST LU CALL LURQ(1,LU,1) 49 CONTINUE ICNWD=LU C C********************************************************************* C C DETERMINE WHICH SPECIAL FEATURES ARE ENABLED FOR THE TERMINALS C C********************************************************************* C C INITIALISE ALL FEATURES TO "NOT USED" C LPRINT=.FALSE. LALPHK=.FALSE. LALPHD=.FALSE. LTYPE3=.FALSE. LTYPE5=.FALSE. MAXKEY=0 MAXLIT=0 C C CHECK EACH FEATURE C C-----HIGHEST KEY NO. USED BY TRANSACTION DO 10 I=26,1,-1 IF((IKEY(I,1).NE.0).OR.(IKEY(I,3).NE.0))GO TO 11 10 CONTINUE 11 MAXKEY=I C C-----HIGHEST LIGHT NO. USED BY TRANSACTION DO 15 I=14,1,-1 IF(ILITE(I).NE.0)GO TO 16 15 CONTINUE 16 MAXLIT=I C C-----ALPHA KEYBOARD (QUES 2, SCR 41) IF((IGET1(IFORM,1516).EQ.1HX).OR.(MAXKEY.GT.10))LALPHK=.TRUE. C C-----ALPHA DISPLAY (QUES 3, SCR 41) IF(IGET1(IFORM,1517).EQ.1HX)LALPHD=.TRUE. C C........ALPHA PRINTER (CHECK ANSWERS IN SCREEN 41) IF(IGET1(IFORM,1515).EQ.1HX)LPRINT=.TRUE. C C........CARD/TYPE III BADGE READER (CHECK ANSWERS IN SCREEN 41) IF(IGET1(IFORM,1518).EQ.1HX)LTYPE3=.TRUE. C C........TYPE V BADGE READER (CHECK ANSWERS IN SCREEN 41) IF(IGET1(IFORM,1519).EQ.1HX)LTYPE5=.TRUE. C C*********************************************************************** C C DETERMINE WHICH TERMINALS CAN BE USED BY THIS TRANSACTION C C*********************************************************************** C C-----3075 WITH ALPHA KEYBOARD CAN ALWAYS BE USED L3075A=.TRUE. C C-----3075 WITH NUMERIC KEYBOARD IS USED ONLY WHEN THE ALPHA KEYBOARD C-----IS NOT SPECIFIED, AND WHEN THE HIGHEST KEY DEFINED IS .LE. 10 L3075N=((.NOT.LALPHK).AND.(MAXKEY.LE.10)) C C-----3070B IS USED ONLY WHEN THE ALPHA KEYBOARD, ALPHA DISPLAY, AND C-----TYPE V BADGE READER ARE NOT SPECIFIED, WHEN THE HIGHEST KEY C-----DEFINED IS .LE. 10, AND WHEN THE HIGHEST LIGHT DEFINED IS .LE. 12 L3070B=((.NOT.(LALPHK.OR.LALPHD.OR.LTYPE5)).AND.(MAXKEY.LE.10) * .AND.(MAXLIT.LE.12)) C C-----3070A IS USED ONLY WHEN THE NONE OF THE SPECIAL FEATURES ARE C-----SPECIFIED, WHEN THE HIGHEST KEY DEFINED IS .LE. 9, AND WHEN C-----THE HIGHEST LIGHT DEFINED IS .LE. 12 L3070A=((.NOT.(LPRINT.OR.LALPHK.OR.LALPHD.OR.LTYPE3.OR.LTYPE5)) * .AND.(MAXKEY.LE.9).AND.(MAXLIT.LE.12)) C C********************************************************************* C C WRITE LABEL PLATES FOR ALL TERMINALS THAT CAN BE USED BY THIS C TRANSACTION C C********************************************************************** C C LABEL HEADER C CALL EXEC(3,1100B+LU,-1) C-----GO TO 55 IF THE LIST REQUEST IS FROM TGP1. IPAGE=1 CALL FTIME(IDATE) DO 50 II=1,4 IF(.NOT.LTERM(II))GO TO 50 CALL PHEAD(LU,IPAGE,IDATE) IF(INDIC.EQ.4278) GO TO 55 WRITE(LU,1005) * (IFORM(K),K=29,31),(IFORM(K),K=32,33), * (LFORM(K),K=16,21) WRITE(LU,1006) (KTERM(K,II),K=1,14) GO TO 60 C-----------GET FILE NAME & CR# FROM IFORM(14) INSTEAD OF LFORM(16). 55 WRITE(LU,1005) * (IFORM(K),K=29,31),(IFORM(K),K=32,33), * (IFORM(K),K=14,19) WRITE(LU,1006) (KTERM(K,II),K=1,14) C C WRITE LIGHT LABEL C 60 CONTINUE DO 100 I=1,3 IF(II.GT.2)GO TO 102 IF(II.EQ.2)GO TO 101 C 3075/6 ALPHA KEYBOARD CALL EXEC(2,ICNWD,IAS79,40) IX=1 IF(I.EQ.3)IX=0 CALL FSTAR(IBUF,IX) CALL FSTAR(IBUF2,IX) GO TO 103 101 CONTINUE C 3075/6 NUMERIC KEYBOARD CALL EXEC(2,ICNWD,IAS79,40) IF(I.EQ.3)GO TO 97 IX=1 WRITE(LU,1502) GO TO 98 97 CONTINUE IX=0 WRITE(LU,1002) 98 CONTINUE CALL FSTAR(IBUF,IX) CALL FSTAR(IBUF2,IX) CALL EXEC(2,ICNWD,IBUF,40) GO TO 103 102 CONTINUE C 3070B, 3070A CALL EXEC(2,ICNWD,IAS66,34) IX=0 CALL FSTAR(IBUF,0) CALL FSTAR(IBUF2,0) CALL EXEC(2,ICNWD,IBUF,34) WRITE(LU,1002) 103 CONTINUE C C INSERT LIGHT LABELS C K IS LIGHT # , N IS POSITION (CHAR) OF LABEL IN IBUF C DO 105 J=1,NLAB(I,II) K=(I-1)*(NCOL(II))+J N=3+(J-1)*13 IF(ILITE(K).EQ.0)GO TO 105 ILT=IABS(ILITE(K))-1 C MOVE QUESTION CALL MOVCA(IFORM,1275+ILT*12,IBUF,N,12) C MOVE DISPLAY VALUE CALL MOVCA(JFORM,106+ILT*140,IBUF2,N,12) 105 CONTINUE N=3+NLAB(I,II)*13 CALL MOVCA(JLIT(1,I),1,IBUF,N,12) CALL EXEC(2,ICNWD,IBUF2,40) CALL EXEC(2,ICNWD,IBUF,40) CALL FSTAR(IBUF,IX) CALL FSTAR(IBUF2,IX) C C IF 3075, THEN INSERT SFK LABELS AND VALUES C IF(II.NE.1)GO TO 118 DO 115 K=LABL(I),LABH(I) N=3+(K-LABL(I))*13+LABO(I) IF(IKEY(K,1).EQ.0)GO TO 115 C INSERT LABELS OR VALUES CALL FILK(K,N,1,0,IBUF,IFORM,12) 115 CONTINUE CALL EXEC(2,ICNWD,IBUF2,40) CALL EXEC(2,ICNWD,IBUF,40) D PAUSE 100 IF(I.EQ.1)WRITE(LU,1512)(IALPHA(KK),KK=1,5) IF(I.EQ.2)WRITE(LU,1511)(IALPHA(KK),KK=6,11) IF(I.EQ.3)WRITE(LU,1510)(IALPHA(KK),KK=12,16) D PAUSE 200 GO TO 100 118 CONTINUE CALL EXEC(2,ICNWD,IBUF,40) 100 CONTINUE C C WRITE SFK LABELS AND USER TEXT C D PAUSE 300 CALL EXEC(2,ICNWD,IAS66,34) D PAUSE 400 DO 120 I=1,2 CALL EXEC(2,ICNWD,IAS66,34) CALL FSTAR(IBUF,0) CALL EXEC(2,ICNWD,IBUF,34) C C INSERT PREFIXED LABELS AND VALUES C DO 130 J=1,5 K=(I-1)*5+J+ITERM(II) IF(II.EQ.4 .AND. K.EQ.0)GO TO 130 N=3+(J-1)*13 IF(IKEY(K,3).EQ.0) GO TO 130 C INSERT LABEL CALL FILK(K,N,1,1,IBUF,IFORM,12) 130 CONTINUE CALL EXEC(2,ICNWD,IBUF,40) CALL FSTAR(IBUF,0) CALL EXEC(2,ICNWD,IBUF,34) C C INSERT NORMAL KEYS LABELS C DO 140 J=1,5 K=(I-1)*5+J+ITERM(II) N=3+(J-1)*13 IF(II.NE.4 .OR. K.NE.0)GO TO 133 CALL MOVCA(IK1,1,IBUF,N,12) GO TO 140 133 CONTINUE IF(IKEY(K,1).EQ.0)GO TO 140 C INSERT LABELS OR VALUES CALL FILK(K,N,1,0,IBUF,IFORM,12) 140 CONTINUE CALL EXEC(2,ICNWD,IBUF,40) C CALL EXEC(2,ICNWD,IBUF2,40) IF(II.NE.1)GO TO 142 D PAUSE 500 IF(I.EQ.1)WRITE(LU,1510)(IALPHA(KK),KK=17,21) IF(I.EQ.2)WRITE(LU,1510)(IALPHA(KK),KK=22,26) D PAUSE 600 GO TO 120 142 CONTINUE CALL FSTAR(IBUF,0) CALL EXEC(2,ICNWD,IBUF,34) 120 CONTINUE D PAUSE 700 C C END OF LABEL PRINTOUT C CALL EXEC(2,ICNWD,IAS66,34) 50 CONTINUE C-----PRINT MESSAGE THAT SAYS 3070B IS MANDATORY & 3070A CANNOT BE USED. C 150 CONTINUE IF(L3075A.AND.L3075N.AND.L3070B.AND.L3070A)GO TO 200 CALL PHEAD(LU,IPAGE,IDATE) WRITE(LU,1008) IF(LPRINT)WRITE(LU,1010) IF(LALPHK)WRITE(LU,1013) IF(LALPHD)WRITE(LU,1015) IF(LTYPE3)WRITE(LU,1009) IF(LTYPE5)WRITE(LU,1014) IF((MAXKEY.EQ.10).AND.(.NOT.LALPHK))WRITE(LU,1011) IF(MAXLIT.GT.12)WRITE(LU,1016)MAXLIT WRITE(LU,1017) DO 65 I=1,4 IF(LTERM(I))WRITE(LU,1018)(KTERM(J,I),J=1,14) 65 CONTINUE WRITE(LU,1012) DO 68 I=1,4 IF(.NOT.LTERM(I))WRITE(LU,1018)(KTERM(J,I),J=1,14) 68 CONTINUE C FORMATS C 1002 FORMAT(" ",5("*",5X,"[]",5X),"*") 1004 FORMAT("1") 1005 FORMAT(21X,"TRANSACTION", C" SPECIFICATION : ",3A2," / ",2A2,// C9X"FROM TRANSACTION SPECIFICATION LIBRARY : " C,3A2" (CR =",3A2")"//) 1006 FORMAT(" ",14A2/) 1008 FORMAT(4X,"THIS TRANSACTION REQUIRES :") 1009 FORMAT(10X,"MULTIFUNCTION CARD/TYPE III BADGE READER") 1010 FORMAT(10X,"ALPHA-NUMERIC PRINTER") 1011 FORMAT(10X,"10 SPECIAL FUNCTION KEYS") 1012 FORMAT(//,4X,"THEREFORE NO LABELS ARE PROVIDED FOR :") 1013 FORMAT(10X,"ALPHA KEYBOARD") 1014 FORMAT(10X,"TYPE V BADGE READER") 1015 FORMAT(10X,"ALPHA-NUMERIC DISPLAY") 1016 FORMAT(10X,I2,"PROMPTING LIGHTS") 1017 FORMAT(//,4X,"WHICH ARE AVAILABLE ONLY ON :") 1018 FORMAT(10X,14A2) 1502 FORMAT(" ",6("*",5X,"[]",5X),"*") 1510 FORMAT(" ",5("*",4X,"<",A2,5X),"*") 1511 FORMAT(" ",6("*",4X,"<",A2,5X),"*") 1512 FORMAT(" ","* SHIFT ",5("*",4X,"<",A2,5X),"*") C C********************************************************************* C C NOW WRITE SPECIFICATIONS C C********************************************************************* C C NAME ,#, SC,DATA BASE NAME C 200 CONTINUE CALL PHEAD(LU,IPAGE,IDATE) C-----GET SYSTEM DATE & PRINT IT. C CALL EXEC(11,ITIME,IYEAR) C IF(JULIB(ITIME(5),IYEAR,IDAY,IMNTH)) GO TO 202 C WRITE(LU,20241) IMNTH,IDAY,IYEAR C C-----GO TO 203 IF THE LIST REQUEST IS FROM TGP1. 202 IF(INDIC.EQ.4278) GO TO 203 WRITE(LU,2010)(LFORM(I),I=16,21) GO TO 204 C-----GET FILE NAME & CR# FROM IFORM(14) INSTEAD OF LFORM(16) 203 WRITE(LU,2010) (IFORM(I),I=14,19) 204 WRITE(LU,2001) (IFORM(I),I=29,31) WRITE(LU,2002) (IFORM(I),I=32,33) WRITE(LU,2003) (IFORM(I),I=34,36) C-----LOGGING? IF (IGET1(IFORM,74).EQ.1HX) WRITE(LU,2004) IF(IAND(ITT,3B).GT.1) WRITE(LU,2042) (IFORM(I),I=38,40) C C*********************************************************************** C C WRITE SFK ASSIGNEMENTS C C********************************************************************** C WRITE(LU,2005) WRITE(LU,2006) WRITE(LU,2007) DO 210 I=1,MAXKEY DO 215 J=1,38 215 IBUF(J)=2H C C KEY # C CALL MOVCA(IASC(I),1,IBUF,6,2) C C NORMAL KEYS ASSIGNEMENT : IF FUNCTION PRINT LABEL C IF STRING PRINT VALUE C 220 IF(IKEY(I,1).EQ.0) GO TO 230 IF(IKEY(I,1).LT.0) GO TO 225 CALL FILK(I,17,1,0,IBUF,IFORM,12) GO TO 230 225 CALL PUTCA(IBUF,1H",14) CALL PUTCA(IBUF,1H",31) CALL FILK(I,-15,1,0,IBUF,IFORM,16) C C PREFIXED KEYS ASSIGNEMENT C 230 IF(IKEY(I,3).EQ.0) GO TO 238 IF(IKEY(I,3).LT.0) GO TO 235 CALL FILK(I,44,1,1,IBUF,IFORM,12) GO TO 238 235 CALL PUTCA(IBUF,1H",41) CALL PUTCA(IBUF,1H",58) CALL FILK(I,-42,1,1,IBUF,IFORM,16) C C TERMINATOR ? C 238 IF(IKEY(I,2).EQ.0) GO TO 239 IBUF(35)=2H Y IBUF(36)=2HES GO TO 240 239 CONTINUE IBUF(35)=2H N IBUF(36)=2HO C 240 CALL EXEC(2,ICNWD,IBUF,40) C 210 CONTINUE C C FORMATS C 20241 FORMAT(4X,"SYSTEM DATE : ",I2,"-",I2,"-",I4) 2010 FORMAT(4X,"FROM LIBRARY : ",3A2" (CR ="3A2")") 2001 FORMAT(4X,"NAME",10X," : ",3A2) 2002 FORMAT(4X,"NUMBER",8X," : ",2A2) 2003 FORMAT(4X,"SECURITY CODE : ",3A2) 2004 FORMAT(4X,"LOGGING REQD : YES") 2005 FORMAT(//,4X,"SPECIAL FUNCTION KEYS ASSIGNMENT :") 2006 FORMAT(4X,34("*"),/) 2007 FORMAT(4X,"KEY#",4X,"NORMAL VALUE/FUNCTION",5X, C"PREFIXED VALUE/FUNCTION",4X,"TERMINATOR ?",/) 2042 FORMAT(4X,"IMAGE DATA BASE : ",3A2) C C********************************************************************* C C IF LIST LU =TERMINAL LU ASK USER TO CONTINUE AND TERMINATE TGP C C********************************************************************* C 470 CONTINUE C IF(LU.NE.ILU)GO TO 480 C CALL EXEC(2,ILU,IPRES,27) C CALL REIO(1,ILU,IANS,-1) C GO TO 485 480 CONTINUE C CALL EXEC(3,1100B+LU,-1) 485 CONTINUE IMODB=IPAGE C INDIC=99 CALL EXEC(8,INAM) C C C CALL TGP END C C C************************************************************************ C************************************************************************ C SUBROUTINE PHEAD(LU,IPAGE,IDATE), 92903-16379 REV.1913 790203 C C C C************************************************************************ C* * C* THIS SUBROUTINE OUTPUTS PAGE HEADERS FOR THE TRANSACTION * C* GENERATION LISTINGS: * C* * C* LU - LOGICAL UNIT NO. OF THE OUTPUT DEVICE * C* IPAGE - CURRENT PAGE NO., THIS PARAMETER IS AUTOMATICALLY * C* INCREMENTED TO THE NEXT PAGE UPON RETURN TO THE * C* CALLING PROGRAM * C* IDATE - CURRENT DATE * C* * C************************************************************************ C C C DIMENSION IHEAD(24),IDATE(15) DATA IHEAD/2H P,2HAG,2HE ,2H00,2H01,2H ,2H D,2HAT,2HAC * ,2HAP,2H/1,2H00,2H0 ,2H- ,2HHP,2H92,2H90,2H3A * ,2H R,2HEV,2H 1,2H91,2H3 ,2H / C WRITE(LU,1004) CALL JASC(IPAGE,IHEAD,-7,4) WRITE(LU,1007)IHEAD,IDATE WRITE(LU,2000) WRITE(LU,2024) IPAGE=IPAGE+1 1004 FORMAT("1") 1007 FORMAT(" ",24A2,15A2) 2000 FORMAT(/,20X,"TRANSACTION SPECIFICATION GENERATOR LIST") 2024 FORMAT(19X,42"*",//) RETURN END END$