FTN4
      PROGRAM TGPI0(5), 92903-16373 REV.1913  790110 0900 
C 
C     SOURCE 92903-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(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 ITGP1(3),ITGP4(3),ITGP13(3),IBUF(46),ITGP3(3),JOUT(3) 
      DIMENSION MEDIS(4),NFORM(5),IDCB(288),IHD(15) 
      DIMENSION MEDID(4),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(4) 
C 
      LOGICAL TSRD,TSWR,ISSPA,INUM,CMPW,JPAR,ISBTW,GETBK,OKABT
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  /
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 
      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) 
      IF(INUM(LFORM,37,6,MEDID(4))) GO TO 5000
C-----SAVE "MEDID"
      CALL MOVEW(MEDID,MEDSAV,4)
      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)
      IF(INUM(ILIBR,9,6,MEDIS(4))) GO TO 5000 
      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)) 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))
      CALL JASC(ICR,ILIBR,9,6)
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 
      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)) 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,4)
      IF(INUM(ILIBR,87,6,MEDID(4))) GO TO 5000
      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)) 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)) 
      IF(INDIC.EQ.1) GO TO 1041 
      CALL JASC(ICR,ILIBR,87,6) 
      GO TO 1045
1041  CALL JASC(ICR,LFORM,37,6) 
      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 
      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)) GOTO 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,4 
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)) 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) 
      GO TO 1122
1121  CALL JASC(ICR,LFORM,37,6) 
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)) 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.
1209  IF(ISTAT.NE.-6) GO TO 9000
C-----CR FILLED UP. 
      CALL MOVEW(MEDSAV,MEDID,4)
      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)) GO TO 9000
      MEDID=-MEDID
C-----READ FORWARD UNTIL FINDING DESIRED TS.
12090 IF(TSRD(MEDID,1,ISTAT,NFORM,KFORM,IFORM,IDCB(145),IHD)) 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)) 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)
      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)) 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)) GO TO 8005 
      GO TO 8005
C-----IF ERR=-6: CR IS FULL, CLOSE SOURCE LIBRARY BEFORE EXITING
9007  IF(ISTAT.NE.-6) GO TO 8005
      IF(TSRD(MEDIS,3,IANS,NFORM,KFORM,IFORM,IDCB,IHD)) 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
      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)) GO TO 8005
      ISCRN=21
      ISKIP=99
      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) 
C 
C  GET ANSWER 
C 
4010  IF(GETBK(ILU,IBUF,18)) 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 
      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 
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) 
      IF(INUM(IFORM,33,6,MEDIS(4))) GO TO 5000
C 
C  DEFINE TRANSACTION SPEC. NAME AND SECURITY CODE
C 
530   IF(INUM(IFORM,15,6,NFORM(4))) GO TO 532 
      NFORM=100000B 
      GO TO 534 
532   CALL MOVEW(IFORM(8),NFORM,3)
      NFORM(4)=100000B
534   IF(INUM(IFORM,21,6,NFORM(5))) GO TO 5000
C 
C READ NOW
C 
      IF(TSRD(MEDIS,2,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 540
C 
C READ IS GOOD CLOSE MEDIA
C 
      IF(TSRD(MEDIS,3,ISTAT,NFORM,KFORM,IFORM,IDCB,IHD)) GO TO 540
      INDIC=3 
C-----IF CR NOT GIVEN, GET IT FROM IDCB 
      IF(MEDIS(4).NE.0) GO TO 550 
      ICR=ICRLU(-IAND(IDCB,77B))
      CALL JASC(ICR,IFORM,33,6) 
      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 
      CALL TGP
C 
C 
      END 
      END$