FTN4
      PROGRAM TGPI0(5), 92080-1X373 REV.2026  800514
C 
C     SOURCE 92080-18373
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*            THIS  IS A SEGMENT OF THE TGP PROGRAM USED TO READ OR  *
C*  WRITE TRANSACTION SPECS. IT IS ALSO USED TO MANIPULATE LIBRARIES *
C*  OF TRANSACTION SPECS (ADD,DELETE AND PRINT DIRECTORIES) .        *
C*                                                                   *
C*            ACCORDING TO THE VALUE OF INDIC AND ISCRN DIFFERENT    *
C*  PORTIONS OF CODE ARE EXECUTED :                                  *
C*                                                                   *
C*    IF :  INDIC = 1 : REQUEST TO WRITE A TRANSACTION SPEC ON A     *
C*                      LIBRARY (OLD OR NEW) . COMING FROM SCREEN    *
C*                      # 18 AND TGP8 .                              *
C*          INDIC = 2 : REQUEST TO BUILD TRANSACTION SPEC LIBRARY    *
C*                      ADD. DELETE OR PRINT DIRECTORY . COMING FROM *
C*                      SCREENS 19 OR 20 AND TGP8 .                  *
C*          ISCRN = 3 : REQUEST TO READ A TRANSACTION SPEC ON A      *
C*                      LIBRARY TO MODIFY IT OR PRINT IT .           *
C*                      COMING FROM SCREEN # 3 AND TGP1 .            *
C*                                                                   *
C*********************************************************************
C 
C 
C 
C   DECLARATIONS COMMON VARIABLES **************
C 
      COMMON ILU,ISCRN,IQST,ISKIP,INDIC 
      COMMON IFORM(780) 
      COMMON JFORM(1700)
      COMMON MFORM(28)
      COMMON LFORM(42)
      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(2844)
      COMMON ILIBR(67)
      COMMON NIMAG
      COMMON IBASE(10),IMODE
C 
C LOCAL VARIABLES ***************** 
C 
      DIMENSION ITGP1(3),ITGP4(3),ITGP13(3),IBUF(52),ITGP3(3),JOUT(3) 
      DIMENSION MEDIS(5),NFORM(5),IDCB(288),IHD(15) 
      DIMENSION MEDID(5),IDEN(125),IPRES(22)
      DIMENSION INIT(9),IWR(4),IRD(4),ITR(17),IBON(3) 
      DIMENSION IBD(11),ISC(8),IDT(8),ILH(9),IOK(14),ILF1(4)
      DIMENSION IDI(13),INA(2),INM(3),ISCO(7),ICOP(33)
      DIMENSION IDSAVE(5),MEDSAV(5),ICR(3)
C 
      DIMENSION I128(128) 
C 
      LOGICAL TSRD,TSWR,ISSPA,INUM,CMPW,JPAR,ISBTW,GETBK,OKABT,NAMCK
C 
C  DATA VALUES ***************
C 
      DATA ITGP1/2HTG,2HP1,2H  /
      DATA ITGP4/2HTG,2HP4,2H  /
      DATA ITGP13/2HTG,2HPI,2H3 / 
      DATA ITGP3/2HTG,2HP3,2H  /
      DATA ICR/2H  ,2H  ,2H  /
C 
C   INIT IS FORMAT OFF,BLOCK MODE OFF,ENABLE KEYBD,HOME UP,CLEAR
C   DISPLAY,INVERSE VIDEO ON
C 
      DATA INIT/15530B,15446B,65460B,41040B,15542B,15510B,
     C15512B,15446B,62102B/ 
      DATA IWR/2HWR,2HIT,2HIN,2HG / 
      DATA IRD/2HRE,2HAD,2HIN,2HG / 
      DATA ITR/2HTR,2HAN,2HSA,2HCT,2HIO,2HN ,2HSP,2HEC,2HIF,2HIC, 
     C2HAT,2HIO,2HNS,15446B,62100B,6412B,5012B/ 
      DATA IBON/15446B,65461B,41040B/ 
      DATA IBD/2HBU,2HIL,2HDI,2HNG,2H L,2HIB,2HRA,2HRI,2HES,2H O,2HF /
      DATA ISC/5012B,15B,2H  ,2H  ,2H S,2HOU,2HRC,2HE / 
      DATA IDT/5012B,15B,2HDE,2HST,2HIN,2HAT,2HIO,2HN / 
      DATA IOK/15446B,62102B,2H O,2HK ,2H? ,2H(Y,2H/N,2H) ,2H  ,
     C15446B,62100B,15504B,15504B,137B/ 
      DATA ILF1/15501B,15501B,15501B,15512B/
      DATA IDI/2H  ,2HDI,2HRE,2HCT,2HOR,2HY ,2HOF,2H L,2HIB,2HRA,2HRY,
     C2H :,2H  /
      DATA INA/2HNA,2HME/ 
      DATA INM/2HNU,2HMB,2HER/
      DATA ISCO/2HSE,2HCU,2HRI,2HTY,2H C,2HOD,2HE / 
      DATA ILH/2HLI,2HBR,2HAR,2HY ,2HHE,2HAD,2HER,2H :,2H  /
      DATA IPRES/15542B,6412B,6412B,
     .15446B,62112B,2HPr,2Hes,2Hs ,15446B,62113B,2HNE,2HXT,2H S,2HCR, 
     .2HEE,2HN ,15446B,62112B,2Hke,74433B,23144B,40040B/
      DATA ICOP/5012B,15B,2HTR,2HAN,2HSA,2HCT,2HIO,2HN ,2HSP,2HEC,2HIF, 
     C2HIC,2HAT,2HIO,2HNS,2H C,2HOP,2HIE,2HD ,2HON,2H T,2HHE,2H D,
     C2HES,2HTI,2HNA,2HTI,2HON,2H L,2HIB,2HRA,2HRY,5012B/ 
      DATA ILFX/15B/
C 
C***********************************************************************
C 
C   GO TO THE REQUIRED PORTION OF TGP10 . 
C 
C***********************************************************************
C 
C  --- PUT IN LIBRARY SECURITY CODE OF 35 
C 
      MEDIS(5)=35 
      MEDID(5)=35 
      MEDSAV(5)=35
C 
      IF(ISCRN.EQ.3) GO TO 500
      IF(INDIC.EQ.1) GO TO 200
      IF(INDIC.EQ.2) GO TO 1000 
C 
C********************************************************************** 
C 
C  INDIC = 1 WRITE TRANSACTION SPEC ON LIBRARY .
C 
C***********************************************************************
C 
C   OUTPUT MESSAGE
C 
200   CALL MOVEW(INIT,IBUF,9) 
      CALL MOVEW(IWR,IBUF(10),4)
      CALL MOVEW(ITR,IBUF(14),17) 
      CALL EXEC(2,ILU,IBUF,30)
C 
C  DEFINE MEDIA ON WHICH TRANSACTION SPEC IS TO BE WRITTEN
C  FILE NAME / CR # . 
C 
      CALL MOVEW(LFORM(16),MEDID,3) 
C     -CR# ASCII? 
      IF(.NOT.INUM(LFORM,37,6,MEDID(4))) GO TO 205
C     -YES. 
      MEDID(4)=LFORM(19)
C-----SAVE "MEDID"
205   CALL MOVEW(MEDID,MEDSAV,5)
      NFORM=100000B 
      NFORM(4)=100000B
      NFORM(5)=100000B
C 
C  IF LIBRARY IS NOT CREATED BUT ALREADY EXITS READ LIBRARY FIRST 
C  OTHERWISE CREATE LIBRARY . 
C 
      IF(.NOT.ISSPA(LFORM,43,30)) GO TO 1040
      CALL MOVEW(LFORM(22),IHD,15)
      GO TO 1120
C 
C********************************************************************** 
C 
C  INDIC = 2  BUILD LIBRARY OF TRANSACTION SPECS .
C 
C*********************************************************************
C 
C 
C  PUT CONSOLE IN CHAR. MODE ,SEND MESSAGE
C 
1000  CALL MOVEW(INIT,IBUF,9) 
      CALL MOVEW(IBD,IBUF(10),11) 
      CALL MOVEW(ITR,IBUF(21),17) 
      CALL EXEC(2,ILU,IBUF,37)
      IF(IANS.EQ.-1) GO TO 1135 
C 
C  DEFINE SOURCE LIBRARY MEDIA (FILE NAME AND CR #) 
C  SET NFORM TO READ FIRST SEQUENTIAL TRANSCACTION SPEC NO SEC. CODE
C 
      CALL MOVEW(ILIBR(2),MEDIS,3)
C     -CR# ASCII? 
      IF(.NOT.INUM(ILIBR,9,6,MEDIS(4))) GO TO 1002
C     -YES. 
      MEDIS(4)=ILIBR(5) 
1002  NFORM=100000B 
      NFORM(4)=100000B
      NFORM(5)=100000B
C 
C  OPEN AND READ SOURCE LIBRARY HEADER
C 
      IF(TSRD(MEDIS,0,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD,IMODE))
     .  GO TO 8000
C-----IF CR WAS NOT SPECIFIED, GET IT NOW FROM IDCB 
      IF(MEDIS(4).NE.0) GO TO 1005
      ICR=ICRLU(-IAND(IDCB,77B))
C     -IGNORE CR # IF TYPE 0. 
      IF(IDCB(3).EQ.0) GO TO 1005 
      CALL JASC(ICR,ILIBR,9,6)
C     -DO THIS IF CRN IS ASCII. 
      IF(.NOT.NAMCK(ICR)) CALL MOVEW(ICR,ILIBR(5),3)
C 
C  IF MODE OF OPERATION IS NOT "L" PRINT SOURCE LIBRARY HEADER
C  AND ASK IF OK ?
C 
1005  IF(ILIBR.EQ.2H L) GO TO 1075
      CALL MOVEW(ISC,IBUF,8)
      CALL MOVEW(ILH,IBUF(9),9) 
      CALL MOVEW(IHD,IBUF(18),15) 
      CALL MOVEW(IOK,IBUF(33),14) 
1010  CALL EXEC(2,ILU,IBUF,46)
C 
C  ASK THE USER IF THIS IS THE GOOD LIBRARY ? 
C 
      IF(IMODE.EQ.1) GO TO 1030 
      CALL REIO(1,500B+ILU,IANS,-1) 
      IF(IGET1(IANS,1).EQ.1HY) GO TO 1030 
      IF(IGET1(IANS,1).EQ.1HN) GO TO 1020 
C 
C  ANSWER IS NOT "Y" OR "N" ASK QUESTION AGAIN
C 
      CALL EXEC(2,ILU,ILF1,4) 
      GO TO 1010
C 
C  ANSWER IS "N" PRINT SCREEN 19 ,CLOSE SOURCE LIBRARY,SET BLOCK MODE 
C 
1020  CALL EXEC(2,ILU,IBON,3) 
      ISCRN=20
      INDIC=0 
1025  IF(TSRD(MEDIS,3,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD,IMODE))
     .  GO TO 8000
      CALL EXEC(8,ITGP3)
C 
C  ANSWER IS "Y" DEFINE DESTINATION LIBRARY (FILE NAME AND CR #)
C  SET NFORM TO READ FIRST SEQUENTIAL TRANSACTION SPEC NO SEC. CODE 
C 
1030  CALL EXEC(2,ILU,ILFX,1) 
      CALL MOVEW(ILIBR(41),MEDID,3) 
C-----SAVE "MEDID"
      CALL MOVEW(MEDID,MEDSAV,5)
C     -CR# ASCII? 
      IF(.NOT.INUM(ILIBR,87,6,MEDID(4))) GO TO 1032 
C     -YES. 
      MEDID(4)=ILIBR(44)
1032  NFORM=100000B 
      NFORM(4)=100000B
      NFORM(5)=100000B
C 
C  DESTINATION LIBRARY MUST BE CREATED ?
C 
      IF(ISSPA(ILIBR,93,30)) GO TO 1110 
C 
C************************************************************************ 
C 
C  DESTINATION LIBRARY ALREADY EXIST READ IT
C 
C***********************************************************************
C 
C 
C  OPEN DESTINATION LIBRARY AND READ HEADER 
C 
1040  IF(TSRD(MEDID,0,ISTAT,NFORM,IBUF,IFORM,IDCB(145),IHD,IMODE))
     .   GO TO 1042 
C-----IF CR WAS NOT SPECIFIED, GET IT NOW FROM IDCB 
      IF(MEDID(4).NE.0) GO TO 1045
      ICR=ICRLU(-IAND(IDCB(145),77B)) 
C     -IGNORE CR # IF TYPE 0 FILE.
      IF(IDCB(147).EQ.0) GO TO 1045 
      IF(INDIC.EQ.1) GO TO 1041 
      CALL JASC(ICR,ILIBR,87,6) 
C     -DO THIS IF CRN IS ASCII. 
      IF(.NOT.NAMCK(ICR)) CALL MOVEW(ICR,ILIBR(44),3) 
      GO TO 1045
1041  CALL JASC(ICR,LFORM,37,6) 
C     -DO THIS IF CRN IS ASCII. 
      IF(.NOT.NAMCK(ICR)) CALL MOVEW(ICR,LFORM(19),3) 
      GO TO 1045
1042  ISKIP=ISTAT 
C-----IF ERR=-6: "LIBRARY COULD NOT BE FOUND" 
      IF(ISKIP.EQ.-6) ISKIP=66
      GO TO 8005
C 
C  IF MODE OF OPERATION IS NOT "L" OUTPUT DEST. LIBRARY HEADER
C 
1045  IF(ILIBR.EQ.2H L) GO TO 1075
      CALL MOVEW(IDT,IBUF,8)
      CALL MOVEW(ILH,IBUF(9),9) 
      CALL MOVEW(IHD,IBUF(18),15) 
      CALL MOVEW(IOK,IBUF(33),14) 
1050  CALL EXEC(2,ILU,IBUF,46)
C 
C  ASK USER IF DEST. LIBR. IS GOOD ?
C 
      IF(IMODE.EQ.1) GO TO 1080 
      CALL REIO(1,500B+ILU,IANS,-1) 
      IF(IGET1(IANS,1).EQ.1HY) GO TO 1080 
      IF(IGET1(IANS,1).EQ.1HN) GO TO 1060 
C 
C  ANSWER IS NOT "Y" OR "N" ASK QUESTION AGAIN
C 
      CALL EXEC(2,ILU,ILF1,4) 
      GO TO 1050
C 
C  ANSWER IS "N", SET BLOCK MODE PRINT RIGHT SCREEN,CLOSE DEST. LIBR
C 
1060  INDIC=0 
      CALL EXEC(2,ILU,IBON,3) 
      IF(TSRD(MEDID,3,ISTAT,NFORM,IBUF,IFORM,IDCB(145),IHD,IMODE))
     .   GO TO 9000 
      IF(ISCRN.EQ.19) CALL EXEC(8,ITGP4)
      ISCRN=21
      GO TO 1025
C 
C  FOR PRINT DIRECTORY  USE SOURCE LIBRARY TO BE READ 
C 
1075  M=1 
      DO 1076 I=1,5 
1076  MEDID(I)=MEDIS(I) 
      GO TO 1082
C 
C************************************************************************ 
C 
C  READ LIBRARY AN SAVE ID'S
C 
C*************************************************************************
C 
1080  CALL EXEC(2,ILU,ILFX,1) 
      M=145 
1082  IFX=0 
      MEDID=-MEDID
1090  IF(TSRD(MEDID,1,ISTAT,NFORM,IBUF,IBUF(11),IDCB(M),IHD,IMODE)) 
     .   GO TO 1100 
      IFX=IFX+1 
      CALL MOVEW(IBUF(2),IDEN(1+(IFX-1)*5),5) 
C-----SAVE LAST READ TS IN CASE CR FILLS UP WHEN
C     WRITING 1ST TS TO THIS LIBRARY. 
      CALL MOVEW(IBUF(2),IDSAVE,5)
      GO TO 1090
1100  IF(ISTAT.EQ.2) GO TO 1105 
      IF(M.EQ.1) GO TO 8000 
      GO TO 9000
1105  IF(ILIBR.EQ.2H L) GO TO 7000
      IFIRST=1
      IF(IFX.EQ.25) GO TO 6000
      GO TO 1130
C 
C***********************************************************************
C 
C  DESTINATION LIBRARY MUST BE CREATED  ,WRITE HEADER 
C 
C***********************************************************************
C 
C 
1110  CALL MOVEW(ILIBR(47),IHD,15)
1120  IF(TSWR(MEDID,4,ISTAT,KFORM,IFORM,IDCB(145),IHD)) GO TO 9005
C-----IF CR WAS NOT SPECIFIED, GET IT NOW FROM IDCB 
      IF(MEDID(4).NE.0) GO TO 1122
      ICR=ICRLU(-IAND(IDCB(145),77B)) 
      IF(INDIC.EQ.1) GO TO 1121 
      CALL JASC(ICR,ILIBR,87,6) 
C     -DO THIS IF CRN IS ASCII. 
      IF(.NOT.NAMCK(ICR)) CALL MOVEW(ICR,ILIBR(44),3) 
      GO TO 1122
C     -FILE TYPE 0?  (IF SO, DON'T STORE CR #). 
1121  IF(IDCB(147).EQ.0) GO TO 1122 
C     -NO.  SAVE CR #.
      CALL JASC(ICR,LFORM,37,6) 
C     -DO THIS IF CRN IS ASCII. 
      IF(.NOT.NAMCK(ICR)) CALL MOVEW(ICR,LFORM(19),3) 
1122  IFX=0 
      MEDID=-MEDID
C 
C********************************************************************** 
C 
C  READ FROM SOURCE LIBRARY 
C 
C*********************************************************************
C 
1130  IF(INDIC.EQ.1) GO TO 1150 
      MEDIS=-MEDIS
      CALL EXEC(2,ILU,ICOP,33)
      IANS=-1 
      GO TO 7009
1131  IANS=0
1132  IF(TSRD(MEDIS,2,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD,IMODE))
     .   GO TO 1210 
C 
C 
C  IF BUILDING LIBRARY CHECK IF FORM IS TO COPY OR EXCLUDE
C 
1150  IF(INDIC.EQ.1) GO TO 1135 
      DO 1160 I=1,10
C     IF(.NOT.ISSPA(ILIBR,21+(I-1)*6,6)) GO TO 1185 
      IF(INUM(ILIBR,21+(I-1)*6,6,IANS)) GO TO 1170
      IF(IANS.EQ.KFORM(5)) GO TO 1180 
      GO TO 1160
1170  IF(CMPW(KFORM(2),ILIBR(11+(I-1)*3),3)) GO TO 1180 
1160  CONTINUE
      IF(ILIBR.EQ.2H C) GO TO 1132
      GO TO 1135
1180  IF(ILIBR.EQ.2H E) GO TO 1132
      GO TO 1135
1185  IF(ILIBR.EQ.2H E) GO TO 1135
      GO TO 1132
C 
C  CHECK FOR DUPLICATE ID 
C 
1135  IANS=0
      IF(IFX.EQ.0) GO TO 1190 
      DO 1140 I=1,IFX 
      IF(CMPW(KFORM(2),IDEN(1+(I-1)*5),3)) GO TO 4000 
      IF(KFORM(5).EQ.IDEN(4+(I-1)*5)) GO TO 4000
1140  CONTINUE
C 
C  CHECK NO MORE THAN 25 SPECS IN A LIBRARY 
C 
1190  IF(IFX.EQ.25) GO TO 6000
      IFX=IFX+1 
C 
C*********************************************************************
C 
C  WRITE SPECS ON DEST. LIBRARY 
C 
C******************************************************************** 
C 
1200  IANS=1
      IF(IFIRST.EQ.1) IANS=2
      IF(INDIC.EQ.1) GO TO 1208 
      DO 1201 I=1,23
1201  IBUF(I)=2H
      CALL MOVEW(KFORM(2),IBUF(4),3)
      CALL CNUMD(KFORM(5),IBUF(11)) 
      CALL JASC(KFORM(6),IBUF,37,6) 
1208  IF(TSWR(MEDID,IANS,ISTAT,KFORM,IFORM,IDCB(145),IHD)) GO TO 1209 
      IF(INDIC.EQ.1) GO TO 1215 
C-----PRINT THE TS JUST WRITTEN ONTO THE INTERACTIVE TERMINAL 
      CALL EXEC(2,ILU,IBUF,23)
      IFIRST=0
      CALL MOVEW(KFORM(2),IDEN(1+(IFX-1)*5),5)
C-----SAVE LAST WRITTEN TS NAME, NO., & SECURITY CODE IN CASE OF WRITE ERROR. 
      CALL MOVEW(KFORM(2),IDSAVE,5) 
      GO TO 1132
C-----IF CR FILLED UP, TAKE CORRECTIVE ACTION.
C1209  IF(ISTAT.NE.-6 .AND. ISTAT.NE.7) GO TO 9000
1209  IF(ISTAT.NE.-33 .AND. ISTAT.NE.7) GO TO 9000
C-----CR FILLED UP. 
      CALL MOVEW(MEDSAV,MEDID,5)
      ISTATX=ISTAT
C-----THE FOLLOWING LOOP STARTS AT THE BEGINNING OF THE DEST. LIB. &
C     READS FORWARD UNTIL FINDING THE LAST KNOWN GOOD TS, THEN WRITES 
C     AN EOF. 
      NFORM=100000B 
      NFORM(4)=100000B
      NFORM(5)=100000B
C-----OPEN & READ HEADER. 
      IF(TSRD(MEDID,0,ISTAT,NFORM,KFORM,IFORM,IDCB(145),IHD,IMODE)) 
     .   GO TO 9000 
      MEDID=-MEDID
C-----READ FORWARD UNTIL FINDING DESIRED TS.
12090 IF(TSRD(MEDID,1,ISTAT,NFORM,KFORM,IFORM,IDCB(145),IHD,IMODE)) 
     .   GO TO 9000 
      IF(.NOT.CMPW(KFORM(2),IDSAVE,5)) GO TO 12090
C-----FOUND IT. 
      IF(TSWR(MEDID,3,ISTAT,KFORM,IFORM,IDCB(145),IHD)) GO TO 9000
      ISTAT=ISTATX
      GO TO 9010
C 
C  NO MORE SPECS ON SOURCE LIBRARY
C 
1210  IF(ISTAT.NE.2) GO TO 8000 
C 
C*********************************************************************
C 
C  CLOSE SOURCE AND DESTINATION LIBRARIES 
C 
C*********************************************************************
C 
      CALL EXEC(2,ILU,IPRES,22) 
      CALL REIO(1,ILU,IANS,-1)
1214  IF(TSRD(MEDIS,3,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD,IMODE))
     .   GO TO 8000 
1215  IF(TSWR(MEDID,3,ISTAT,KFORM,IFORM,IDCB(145),IHD)) GO TO 9000
      IF(INDIC.EQ.99) CALL EXEC(8,ITGP1)
      IF(INDIC.EQ.1) CALL EXEC(8,ITGP13)
      INDIC=0 
      ILIBR=2H
      CALL EXEC(2,ILU,IBON,3) 
      ISCRN=20
      CALL EXEC(8,ITGP3)
C 
C************************************************************************ 
C 
C   PRINT DIRECTORY 
C 
C***********************************************************************
C 
C 
C   FORMAT MEDIA ,PRINT HEADER
C 
7000  CALL EXEC(3,1100B+ISKIP,-1) 
      CALL EXEC(3,1100B+ISKIP,2)
      CALL BLANC(IBUF,6)
      CALL MOVEW(IDI,IBUF(7),13)
      CALL MOVEW(ILIBR(2),IBUF(20),3) 
      CALL MOVEW(6H (CR =,IBUF(23),3) 
      CALL MOVEW(ILIBR(5),IBUF(26),3) 
      IBUF(29)=2H)
      CALL EXEC(2,ISKIP,IBUF,29)
      CALL EXEC(3,1100B+ISKIP,1)
      CALL BLANC(IBUF,10) 
      CALL MOVEW(IHD,IBUF(11),15) 
      CALL EXEC(2,ISKIP,IBUF,25)
      CALL EXEC(3,1100B+ISKIP,2)
C 
C   PRINT TITLES " NAME, #, SEC. CODE " 
C 
7009  DO 7010 I=1,25
7010  IBUF(I)=2H
      CALL MOVEW(INA,IBUF(4),2) 
      CALL MOVEW(INM,IBUF(11),3)
      CALL MOVEW(ISCO,IBUF(19),7) 
      CALL EXEC(2,ISKIP,IBUF,25)
      CALL EXEC(3,1100B+ISKIP,2)
      IF(IANS.EQ.-1) GO TO 1131 
C 
C 
C  PRINT DIRECTORY LINE PER LINE
C 
      DO 7050 I=1,IFX 
      DO 7015 J=1,23
7015  IBUF(J)=2H
      CALL MOVEW(IDEN(1+(I-1)*5),IBUF(4),3) 
      CALL CNUMD(IDEN(4+(I-1)*5),IBUF(11))
      CALL JASC(IDEN(5+(I-1)*5),IBUF,37,6)
C     -BLANK IT OUT IF NO TRANSACTION NAME. 
      IF(IDEN(1+(I-1)*5).EQ.0) CALL BLANC(IBUF,23)
      CALL EXEC(2,ISKIP,IBUF,23)
7050  CONTINUE
      IF(ISKIP.NE.ILU) GO TO 1020 
      CALL EXEC(2,ILU,IPRES,22) 
      CALL REIO(1,ILU,IANS,-1)
      GO TO 1020
C 
C*********************************************************************
C 
C    ERROR SECTION
C 
C 
C*********************************************************************
C 
5000  STOP 5000 
C 
C     ERROR MORE 25 SPECS  TO BE STORED 
C 
6000  ISKIP=10
      ISCRN=21
      IF(INDIC.EQ.1) ISCRN=19 
      GO TO 8003
C 
C  FMGR ERRORS FROM SOURCE LIBRARY
C 
8000  ISCRN=20
8002  ISKIP=ISTAT 
8003  IF(INDIC.EQ.1) GO TO 8004 
      IF(TSRD(MEDIS,3,IANS,NFORM,KFORM,IFORM,IDCB,IHD,IMODE)) 
     .   GO TO 5000 
8004  IF(ILIBR.EQ.2H L) GO TO 8005
      IF(TSWR(MEDID,3,IANS,KFORM,IFORM,IDCB(145),IHD)) GO TO 5000 
8005  INDIC=2 
      CALL EXEC(2,ILU,IBON,3) 
      IF(ISCRN.EQ.19) CALL EXEC(8,ITGP4)
      CALL EXEC(8,ITGP3)
C 
C  FMGR DEST. LIBRARY ERROR 
C 
9000  ISCRN=21
      IF(INDIC.EQ.1)ISCRN=19
      GO TO 8002
C-----ERROR OCCURRED WHEN ATTEMPTING TO CREATE A NEW LIBRARY. 
9005  ISCRN=21
      IF(INDIC.EQ.1) ISCRN=19 
      ISKIP=ISTAT 
C-----IF ERR=-2 (DUPLICATE FILE NAME) CLOSE THE FILE. 
      IF(ISTAT.NE.-2) GO TO 9007
      IF(TSRD(MEDID,3,ISTAT,KFORM,IBUF,IFORM,IDCB(145),IHD,IMODE))
     .   GO TO 8005 
      GO TO 8005
C-----IF ERR=-6: CR IS FULL, CLOSE SOURCE LIBRARY BEFORE EXITING
C9007  IF(ISTAT.NE.-6 .AND. ISTAT.NE.7) GO TO 8005
9007  IF(ISTAT.NE.-33 .AND. ISTAT.NE.7) GO TO 8005
      IF(TSRD(MEDIS,3,IANS,NFORM,KFORM,IFORM,IDCB,IHD,IMODE)) 
     .   GO TO 8005 
      GO TO 8005
C-----CR FILLED UP WHILE WRITING A TS TO A LIBRARY
9010  IF(INDIC.EQ.2) GO TO 9015 
C-----INDIC=1 MEANS CR FILLED UP WHILE WRITING TS ONTO A
C     LIBRARY (OLD OR NEW) FROM SCR 18
      ISCRN=19
      ISKIP=77
      IF(ISTAT.EQ.7) ISKIP=88 
      GO TO 8005
C-----INDIC=2 MEANS CR FILLED UP WHILE WRITING FROM 1 LIB TO ANOTHER, 
C     CLOSE SOURCE LIBRARY BEFORE EXITING 
9015  IF(TSRD(MEDIS,3,IANS,NFORM,KFORM,IFORM,IDCB,IHD,IMODE)) 
     .   GO TO 8005 
      ISCRN=21
      ISKIP=99
      IF(ISTAT.EQ.7) ISKIP=88 
      GO TO 8005
C 
C********************************************************************** 
C 
C A DUPLICATE ID HAS BEEN FOUND 
C 
C********************************************************************** 
C 
C  PREPARE BUFFER TO BE PASSED TO DUPL SUBROUTINE 
C 
4000  CALL MOVEW(IDEN(1+(I-1)*5),IBUF,3)
      CALL MOVEW(KFORM(2),IBUF(9),3)
      CALL CNUMD(IDEN(4+(I-1)*5),IBUF(40))
      CALL MOVEW(IBUF(41),IBUF(4),2)
      CALL CNUMD(KFORM(5),IBUF(40)) 
      CALL MOVEW(IBUF(41),IBUF(12),2) 
      CALL JASC(IDEN(5+(I-1)*5),IBUF,11,6)
      CALL JASC(KFORM(6),IBUF,27,6) 
C 
C  NOW PRINT SCREEN TO ASK NEW ID 
C 
      CALL DUPL(IBUF,IMODE) 
C 
C  GET ANSWER 
C 
4010  IF(GETBK(ILU,IBUF,18,IMODE)) GO TO 4000 
C 
C ANALYSE SCREEN * NEW NAME 
C 
      NOF=1 
      IF(JPAR(IBUF,18,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF(ISBTW(IGET1(JOUT,1),1HA,1HZ)) GO TO 4100 
      CALL MOVEW(JOUT,KFORM(2),3) 
      CALL MOVEW(JOUT,IFORM(29),3)
C 
C  NEW NUMBER 
C 
      NOF=NOF+1 
      IF(JPAR(IBUF,18,NOF,JOUT,4,IFLG,JVAL)) GO TO 3000 
      IF(IFLG.EQ.0) GO TO 4110
      IF(IFLG.NE.1) GO TO 4110
      IF((JVAL.LT.1).OR.(JVAL.GT.9999)) GO TO 4110
      IF(JVAL.LT.0) GO TO 4110
      CALL MOVEW(JOUT,IFORM(32),2)
      KFORM(5)=JVAL 
C 
C  NEW SECURITY CODE
C 
      NOF=NOF+1 
      JVAL=0
      IF(JPAR(IBUF,18,NOF,JOUT,6,IFLG,JVAL)) GO TO 3000 
      IF(IFLG.GT.1) GO TO 4120
      CALL MOVEW(JOUT,IFORM(34),3)
      KFORM(6)=JVAL 
C 
      IANS=-1 
      GO TO 1000
C 
C ERROR SECTION 
C 
3000  IF(IFLG.NE.9) GO TO 4130
      IF(.NOT.OKABT(ILU)) GO TO 4000
      IF(INDIC.EQ.2) GO TO 3002 
      INDIC=99
      GO TO 1215
3002  INDIC=99
      GO TO 1214
C 
4100  CALL MES10(1,NOF) 
      GO TO 4010
4110  CALL MES10(2,NOF) 
      GO TO 4010
4120  CALL MES10(3,NOF) 
      GO TO 4010
4130  CALL MES10(4,NOF) 
      GO TO 4010
C --- SHOULD NEVER GET HERE, BUT IF SO CAUSED BY BAD LIBRARY SECURITY 
C         CODE. 
4140  CALL MES10(5,NOF) 
      PAUSE 4140
C 
C 
C********************************************************************** 
C 
C 
C   READ TRANSACTION SPEC . 
C 
C********************************************************************** 
C 
C 
C   OUTPUT MESSAGE
C 
500   CALL MOVEW(INIT,IBUF,9) 
      CALL MOVEW(IRD,IBUF(10),4)
      CALL MOVEW(ITR,IBUF(14),17) 
      CALL EXEC(2,ILU,IBUF,30)
C 
C  DEFINE MEDIA    (FILE NAME AND CR #) 
C 
C 
      CALL MOVEW(IFORM(14),MEDIS,3) 
C     -CR# ASCII? 
      IF(.NOT.INUM(IFORM,33,6,MEDIS(4))) GO TO 530
C     -YES. 
      MEDIS(4)=IFORM(17)
C 
C  DEFINE TRANSACTION SPEC. NAME AND SECURITY CODE
C 
C     -IS THERE A TS NAME?
530   IF(INUM(IFORM,15,6,NFORM(4))) GO TO 532 
C     -NO.  IT IS A TS #.  SET NFORM(1) TO NO NAME. 
      NFORM=100000B 
      GO TO 534 
532   CALL MOVEW(IFORM(8),NFORM,3)
C     -SET NO NUMBER BIT. 
      NFORM(4)=100000B
C     -IS THERE A SECURITY CODE?
534   IF(.NOT.INUM(IFORM,21,6,NFORM(5))) GO TO 536
C     -NO.  SET NO NUMBER BIT.
      NFORM(5)=100000B
C 
C READ NOW
C 
536   IF(TSRD(MEDIS,2,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD,IMODE))
     .   GO TO 540
C 
C READ IS GOOD CLOSE MEDIA
C 
      IF(TSRD(MEDIS,3,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD,IMODE))
     .   GO TO 540
      INDIC=3 
C-----IF CR NOT GIVEN, GET IT FROM IDCB, BUT NOT IF IT IS A TYPE 0 FILE.
      IF(IDCB(3).EQ.0) GO TO 550
      IF(MEDIS(4).NE.0) GO TO 550 
      ICR=ICRLU(-IAND(IDCB,77B))
      CALL JASC(ICR,IFORM,33,6) 
C     -DO THIS IF CRN IS ASCII. 
      IF(.NOT.NAMCK(ICR)) CALL MOVEW(ICR,IFORM(17),3) 
      GO TO 550 
C 
C  READ IS BAD ISKIP=STATUS 
C 
540   INDIC=1 
      ISKIP=ISTAT 
C 
C  RETURN TO TGP1 BEFORE TURN BLOCK MODE ON 
C 
550   CALL EXEC(2,ILU,IBON,3) 
      CALL EXEC(8,ITGP1)
C 
C 
C 
C  END OF SEGMENT 
C 
      END 
      END$