FTN4
      PROGRAM R2026(3),92080-16582    REV.2026   800205 
C 
C     NAME:   R2026 
C     SOURCE: &R2026    92080-18582 
C     RELOC:  %R2026    92080-16582 
C 
C *************************************************************************** 
C *                                                                         * 
C * THIS PROGRAM TAKES A 1936 VERSION DATACAP TRANSACTION AND REFORMATS THE * 
C * BUFFERS INTO A 2026 FORMAT.  THE BINARY SECTION IS ONLY REFORMATTED TO  * 
C * LOOK LIKE A 2026 TRANSACTION, BUT IN FACT SHOULD NOT BE EXECUTED. THE   * 
C * TRANSACTIONS COMING OUT OF THIS PROGRAM SHOULD BE PASSED THROUGH 2026   * 
C * TGP IN MODIFY MODE TO RECREATE LEGITIMATE BINARIES.  IT MAY BE NECESSARY* 
C * TO ADD INFORMATION DURING THE MODIFY, AS IS THE CASE WITH DATA BASE     * 
C * ITEMS. AT THE END OF THE MODIFY IT WILL BE NECESSARY TO SPECIFY A NEW   * 
C * LIBRARY OR TO CHANGE THE TRANSACTION NAME/NUMBER TO AVOID DUPLICATION.  * 
C *                                                                         * 
C * TO EXECUTE ENTER: 1) RU,R2026,P1,P2,P3                                  * 
C *                        P1: LOG LU                                       * 
C *                        P2: NAMR OF LIBRARY TO BE REVISED                * 
C *                        P3: NAMR OF NEW LIBRARY CREATED (VALID SOURCE)   * 
C *                                                                         * 
C *               OR: 2) RU,R2026                                           * 
C *                        IN THIS CASE THE LOG/INPUT DEVICE WILL BE THE    * 
C *                        TERMINAL RUN FROM. BOTH NAMRS WILL BE PROMPTED   * 
C *                        FOR INTERACTIVELY.                               * 
C *                                                                         * 
C *                      IN EITHER CASE, A LOG OF THE TRANSACTION NAMES OF  * 
C *                      REVISED TRANSACTIONS WILL BE GIVEN.                * 
C *                                                                         * 
C *************************************************************************** 
C 
C 
      DIMENSION IDCBO(144),IPARM(5),IDCBI(144), 
     .          IBUFI(127),IBUFO(127),ISIZE(2),IREG(2),INAME(3),
     .          IBUFF(24),IPBUF(10) 
      EQUIVALENCE (REG,IREG,IA),(IREG(2),IB)
      INTEGER PTR,PTR1
      DATA IBLAN/2H  /
      CALL RMPAR(IPARM) 
      LU=IPARM(1) 
      IF(LU.EQ.0) LU=1
      ILU=IOR(LU,400B)
      ITYP36=36 
      ISIZE(1)=128
      ISIZE(2)=127
C 
C  OLD LIBRARY NAME 
C 
      CALL BLAN(IBUFF,1,48) 
      CALL EXEC(14,1,IBUFF,-48) 
      IF(IGET1(IBUFF,12).EQ.1H .OR.IGET1(IBUFF,13).EQ.1H ) GO TO 200
      DO 98 I=10,12 
      ITMP=IGET1(IBUFF,I) 
      IF(ITMP.NE.1H,) GO TO 98
      ISTRT=I+1 
      GO TO 99
98    CONTINUE
99    DO 100 I=ISTRT,ISTRT+18 
      ITMP=IGET1(IBUFF,I) 
      IF(ITMP.NE.1H,) GO TO 100 
      LEN=I-1 
      GO TO 101 
100   CONTINUE
200   WRITE(LU,1) 
1     FORMAT(" ENTER NAMR OF LIBRARY TO BE REV'D UP") 
      REG=EXEC(1,ILU,IBUFF,-20) 
      CALL BLAN(IBUFF,IB+1,20-IB) 
      ISTRT=1 
      LEN=20
101   CALL NAMR(IPBUF,IBUFF,LEN,ISTRT)
C 
C  OPEN THE FILE
C 
      CALL OPEN(IDCBI,IERR,IPBUF,0,IPBUF(5),IPBUF(6)) 
      IF(IERR.GT.0) GO TO 3 
      WRITE(LU,2) IERR
2     FORMAT("ORIGINAL LIBRARY FILE COULD NOT BE OPENED IERR= ",I3) 
      GO TO 42
C 
C  NEW LIBRARY NAME 
C 
3     IF(IGET1(IBUFF,12).EQ.1H .OR.IGET1(IBUFF,13).EQ.1H ) GO TO 201
      ISTRT=LEN+2 
      DO 102 I=ISTRT,ISTRT+18 
      ITMP=IGET1(IBUFF,I) 
      IF(ITMP.NE.1H ) GO TO 102 
      LEN=I-1 
      GO TO 103 
102   CONTINUE
201   WRITE(LU,4) 
4     FORMAT(" ENTER NAMR OF LIBRARY TO BE CREATED")
      REG=EXEC(1,ILU,IBUFF,-20) 
      CALL BLAN(IBUFF,IB+1,20-IB) 
      ISTRT=1 
      LEN=20
103   CALL NAMR(IPBUF,IBUFF,LEN,ISTRT)
      CALL OPEN(IDCBO,IERR,IPBUF,0,35,IPBUF(6)) 
C 
C  TRY TO OPEN FILE 
C 
      IF(IERR.EQ.-6) GO TO 6
      WRITE(LU,5) IERR
5     FORMAT("NEW LIBRARY NAME ALREADY EXISTS  ABT ",I3)
      GO TO 40
6     CALL CREAT(IDCBO,IERR,IPBUF,ISIZE,ITYP36,35,IPBUF(6),IDCBSO)
      IF(IERR.GE.0) GO TO 7 
      WRITE(LU,55)IERR
55    FORMAT("UNABLE TO CREATE NEW LIBRARY - ABORT ",I3)
      GO TO 40
C 
C  READ THE LIBRARY HEADER
C 
7     CALL READF(IDCBI,IERR,IBUFI,127,LEN)
      IF(LEN.NE.15) GO TO 50
      IF(IERR.GE.0) GO TO 9 
50    WRITE(LU,8) IERR
8     FORMAT("ERROR IN READING HEADER RECORD ",I3)
      GO TO 38
C 
C  WRITE NEW LIB HEADER 
C 
9     CALL WRITF(IDCBO,IERR,IBUFI,15) 
      IF(IERR.GE.0) GO TO 11
      WRITE(LU,10)  IERR
10    FORMAT("UNABLE TO WRITE NEW LIB HEADER ",I3)
      GO TO 38
C 
C  READ THE BINARY SECTION
C 
11    CALL READF(IDCBI,IERR,IBUFI,127,LEN)
      IF(LEN.EQ.-1) GO TO 38
      IF(LEN.NE.12) GO TO 12
      IF(IERR.GE.0) GO TO 14
12    WRITE(LU,13) IERR 
13    FORMAT("UNABLE TO READ LEGITIMATE 1936 BINARY REC #1 IERR= ",I3)
      GO TO 38
14    COUNT=IBUFI(1)
      DO 15 I=1,12
      PTR=I+1 
15    IBUFO(I)=IBUFI(I) 
      COUNT=COUNT-12
23    IF(COUNT.GT.0) GO TO 16 
      COUNT=0 
      PTR=PTR-1 
      GO TO 19
16    CALL READF(IDCBI,IERR,IBUFI,127,LEN)
      IF(IERR.GE.0) GO TO 18
      WRITE(LU,17) IERR 
17    FORMAT("BAD BINARY READ ",I3) 
      GO TO 38
18    IBUFO(PTR)=IBUFI(1) 
19    CALL WRITF(IDCBO,IERR,IBUFO,PTR)
      IF(IERR.GE.O) GO TO 21
      WRITE(LU,20) IERR 
20    FORMAT("UNABLE TO WRITE BINARY REC ",I3)
21    IF(COUNT.EQ.0.OR.COUNT.EQ.1) GO TO 59 
      MAX=COUNT-1 
      IF(MAX.GT.126) MAX=126
      DO 22 I=1,MAX 
      PTR=I+1 
22    IBUFO(I)=IBUFI(PTR) 
      COUNT=COUNT-127 
      GO TO 23
C 
C  END OF BINARY MOVE SECTION 
C 
C  THIS SECTION REFORMATS IFORM. IN 1936 IFORM WAS 772 WORDS
C  LONG. THE 2026 PCO CALLS FOR IFORM TO BE 780 WORDS LONG. 
C  WITHIN THE ORIGINAL 772 WORDS NOTHING HAS CHANGED. WORDS 
C  773-780 ARE AS FOLLOWS...
C 
C   WORD #              LEFT BYTE            RIGHT BYTE 
C 
C    773         AUTO-COMPLETING? (X)    LIGHT # TO - 
C    774          -STAY LIT (0-14)       MAGSTRIPE NEEDED? (X)
C    775         BAR CODE NEEDED? (X)    CRT NEEDED? (X)
C  776-780       ------------------SPARE----------------------
C 
C  780/127=6+18/127. THIS MEANS THAT 6 RECORDS CAN READ/WRITTEN.
C  RECORD 7 OF 1936 CAN BE READ BUT THE ADDITION OF THE 8 WORDS 
C  MUST BE MADE TO THE 2026 VERSION. THIS ADDITION IS IN THE FORM 
C  OF WORDS 11-18 OF THE 7TH RECORD BEING WRITTEN OUT AS BLANKS.
C 
59    DO 26 I=1,6 
      CALL READF(IDCBI,IERR,IBUFI,127,LEN)
      IF(IERR.GE.0.AND.LEN.EQ.127) GO TO 24 
      WRITE(LU,60) IERR 
60    FORMAT("BAD READ ON IFORM ",I3) 
      GO TO 38
24    IF(I.NE.1) GO TO 4001 
      INAME(1)=IBUFI(29)
      INAME(2)=IBUFI(30)
      INAME(3)=IBUFI(31)
      DO 4000 I2=106,238,33 
4000  IF(IGET1(IBUFI,I2).EQ.1HA) CALL PUTCA(IBUFI,1HS,I2) 
4001  IF(I.NE.2) GO TO 4003 
      DO 4002 I2=17,248,33
4002  IF(IGET1(IBUFI,I2).EQ.IHA) CALL PUTCA(IBUFI,1HS,I2) 
4003  IF(I.NE.3) GO TO 4005 
      DO 4004 I2=11,242,33
4004  IF(IGET1(IBUFI,I2).EQ.1HA) CALL PUTCA(IBUFI,1HS,I2) 
4005  IF(I.NE.4) GO TO 4007 
      DO 4006 I2=21,153,33
4006  IF(IGET1(IBUFI,I2).EQ.1HA) CALL PUTCA(IBUFI,1HS,I2) 
4007  CALL WRITF(IDCBO,IERR,IBUFI,127)
      IF(IERR.GE.0) GO TO 26
      WRITE(LU,25) IERR 
25    FORMAT("BAD WRITE ON IFORM ",I3)
      GO TO 38
26    CONTINUE
      CALL READF(IDCBI,IERR,IBUFI,127,LEN)
C 
C  REC 10^
C 
      DO 27 I=1,10
27    IBUFO(I)=IBUFI(I) 
      DO 28 I=11,18 
28    IBUFO(I)=IBLAN
C 
C   THIS SECTION REFORMATS JFORM. IN 1936 JFORM WAS A 20 X 76 
C   BUFFER (TOTAL OF 1520). IN 2026 JFORM IS 20 X 85 (TOTAL OF
C   1700). THE FOLLOWING IS A TABLE OF THE CHANGES. 
C 
C   WORD #          1936 USE                 2026 USE 
C              LEFT BYTE/RIGHT BYTE     LEFT BYTE/RIGHT BYTE
C 
C     3    NON-KEY INPUT/ON-LINE DIS.   NON-KEY INPUT/ L/S CHAR.
C     4    SUMMARY DISP./ANS. LABEL     SCROLL/CLEAR / SPARE
C     5        LABEL FOR ANSWER         ON-LINE PRINT/SUMMARY PRINT 
C   6-13       LABEL FOR ANSWER  =>     LABEL ANSWER CHAR 1-16
C  14-16            SHIFTED IMAGE ITEM NAME 1 BYTE LEFT IN 2026 
C     17  IMAGE ITEM NAM/IMAGE OPER       IMAGE OPER / SPARE
C  77-85        DID NOT EXIST          USER WRITTEN DATA MODULE NAME
C    "                                     BAR CODE INFORMATION 
C    "                                     MAGSTRIPE INFORMATION
      PTR=11
      PTR1=19 
      DO 33 I=1,20
      DO 33 J=1,85
      IF(PTR1.LE.127) GO TO 62
      CALL WRITF(IDCBO,IERR,IBUFO,127)
      PTR1=1
62    IF(J.GT.76) GO TO 1200
      IF(PTR.LE.127) GO TO 29 
      CALL READF(IDCBI,IERR,IBUFI,127,LEN)
      PTR=1 
29    IF(J.EQ.3) GO TO 150
      IF(J.EQ.4) GO TO 175
      IF(J.EQ.5) GO TO 300
      IF(J.GE.6 .AND. J.LE.13) GO TO 400
      IF(J.EQ.14) GO TO 500 
      IF(J.GE.15 .AND. J.LE.17) GO TO 550 
      IF(J.EQ.52) GO TO 700 
      IF(J.EQ.53) GO TO 800 
      IF(J.GE.54 .AND. J.LE.61) GO TO 800 
      IF(J.EQ.62) GO TO 1000
      IF(J.EQ.63) GO TO 1100
      IBUFO(PTR1)=IBUFI(PTR)
      GO TO 32
C 
C  3RD WORD OF JFORM. CHECK FOR O/S ON RIGHT HAND BYTE
C  BLANK RIGHT HAND BYTE AFTER CHECKING IT. 
C 
150   IHOLD1=IGET1(IBUFI,PTR*2) 
      CALL PUTCA(IBUFI,1H ,PTR*2) 
      IBUFO(PTR1)=IBUFI(PTR)
      GO TO 32
C 
C  4TH WORD OF JFORM. CHECK FOR O/S ON LEFT HAND BYTE. HOLD 
C  RIGHT HAND BYTE AND PUT INTO WORD 5. BLANK WORD 4
C 
175   IHOLD2=IBUFI(PTR) 
      IBUFO(PTR1)=2H
      GO TO 32
C 
C  5TH WORD OF JFORM. CHAR 2 AND 3 OF ANSWER LABEL. SAVE
C  THESE AND REPLACE WITH PRINTER INFORMATION HELD IN IHOLD1
C  AND IHOLD2. THIS FREES IHOLD1 AND IHOLD2.
C 
300   IHOLD3=IBUFI(PTR) 
      IBUFO(PTR1)=2H
      IF(IHOLD1.EQ.1HO .OR. IGET1(IHOLD2,1).EQ.1HO) 
     .  CALL PUTCA(IBUFO,1HX,PTR1*2-1)
      IF(IHOLD1.EQ.1HS .OR. IHOLD2.EQ.1HS)
     .  CALL PUTCA(IBUFO,1HX,PTR1*2)
      GO TO 32
C 
C  6TH-13TH WORDS OF JFORM. SAVE LABEL CHAR FOR LATER USE 
C  AND PICK UP AND PLACE PREVIOUS ONES. 
C 
400   CALL PUTCA(IBUFO,IGET1(IHOLD2,2),PTR1*2-1)
      CALL PUTCA(IBUFO,IGET1(IHOLD3,1),PTR1*2)
      IHOLD2=IHOLD3 
      IHOLD3=IBUFI(PTR) 
      GO TO 32
C 
C  THIS SECTION MOVES IMAGE ITEM NAME UP 1 BYTE IN JFORM
C 
550   CALL PUTCA(IBUFO,IGET1(IBUFI,PTR*2-1),PTR1*2-2) 
500   CALL PUTCA(IBUFO,IGET1(IBUFI,PTR*2),PTR1*2-1) 
      IF(J.EQ.17) CALL BLAN(IBUFO,PTR1*2,1) 
      GO TO 32
C 
C  52ND WORD OF JFORM. RIGHT BYTE CONTAINS O/S DISPLAY INFO 
C  SAVE THIS AND BLANK THE WORD.
C 
700   IHOLD1=IGET1(IBUFI,PTR*2) 
      CALL PUTCA(IBUFI,1H ,PTR*2) 
      IBUFO(PTR1)=IBUFI(PTR)
      GO TO 32
C 
C  53RD WORD OF JFORM CONTAINS O/S INFO AND 1ST DISPLAY LABEL 
C  CHAR. 53RD WORD BECOMES PRINTER INFO WITH DISPLAY LABEL
C  MOVING DOWN 1 BYTE.
C 
800   IHOLD2=IGET1(IBUFI,PTR*2) 
      CALL PUTCA(IBUFO,IGET1(IBUFI,PTR*2-1),PTR1*2) 
      IF(J.NE.53) GO TO 810 
      IHOLD3=2H 
      IF(IHOLD1.EQ.1HO .OR. IGET1(IBUFI,PTR*2-1).EQ.1HO)
     .  CALL PUTCA(IHOLD3,1HX,1)
      IF(IHOLD1.EQ.1HS .OR. IGET1(IBUFI,PTR*2-1).EQ.1HS)
     .  CALL PUTCA(IHOLD3,1HX,2)
      IBUFO(PTR1)=IHOLD3
      IHOLD1=IHOLD2 
      GO TO 32
810   CALL PUTCA(IBUFO,IHOLD1,PTR1*2-1) 
      IHOLD1=IHOLD2 
      GO TO 32
C 
C  WORD 62 NEEDS TO BE BLANKED OUT. FORMERLY THE 18 19TH
C  CHARACTERS IN LABEL, BUT LABEL IS NOW 16 CHAR LONG.
C 
1000  IBUFO(PTR1)=2H
      GO TO 32
C 
C  LEFT BYTE IN WORD 63 GETS BLANKED. USED TO BE THE 20TH 
C  CHARACTER OF THE LABEL.
C 
1100  IBUFO(PTR1)=IBUFI(PTR)
      CALL PUTCA(IBUFO,1H ,PTR1*2-1)
      GO TO 32
C 
C  WORDS 77-85 OF JFORM ARE NEW. THEY NEED TO BE BLANK- 
C  FILLED AS PLACE HOLDERS ON REVISED TRANSACTIONS. 
C 
1200  IBUFO(PTR1)=2H
      GO TO 321 
C 
C 
32    PTR=PTR+1 
321   PTR1=PTR1+1 
33    CONTINUE
C 
C***********************************************************
C 
C  ALL OF JFORM HAS NOW BEEN REFORMATTED. THE REST OF THE 
C  BUFFERS NEED TO BE MOVED WORD FOR WORD WITH THE EXCEPTION
C  THAT LFORM HAS BEEN INCRESED BY 3 WORDS IN LENGTH, THUS
C  THE CHECK FOR I.GE.68 .AND. I.LE.70 .
C  THE REMAINING BUFFERS TO BE MOVED ARE AS FOLLOWS...
C 
C         MFORM(28) 
C         LFORM(42)  (UP FORM 39 IN 1936) 
C         ITT 
C         IKEY(26,3)
C         IUMAX,IMMAX,IMODB 
C         ILITE(15) 
C         IMAI(45,5)
C         IMFLG,IMAS,IMDT,IMKY
C 
C 
      DO 37 I=1,396 
      IF(PTR1.LE.127) GO TO 34
      CALL WRITF(IDCBO,IERR,IBUFO,127)
      PTR1=1
C 
C  CHECK FOR WHEN I IS 68,69 OR 70 TO ADD 3 BLANK WORDS 
C 
34    IF(I.GE.68.AND.I.LE.70) GO TO 36
      IF(PTR.LE.127) GO TO 35 
      CALL READF(IDCBI,IERR,IBUFI,127,LEN)
      PTR=1 
35    IBUFO(PTR1)=IBUFI(PTR)
      PTR1=PTR1+1 
      PTR=PTR+1 
      GO TO 37
36    IBUFO(PTR1)=2H
      PTR1=PTR1+1 
37    CONTINUE
      CALL WRITF(IDCBO,IERR,IBUFO,PTR1-1) 
      WRITE(LU,43) INAME
43    FORMAT(" TRANSACTION ",3A2," HAS BEEN SUCCESFULLY REFORMATTED") 
      GO TO 11
C 
C  LEGITIMATE STOP
C 
38    CALL CLOSE(IDCBO,IERR)
      IF(IERR.GE.0) GO TO 40
      WRITE(LU,39) IERR 
39    FORMAT("CLOSE ERROR ON NEW LIBRARY ",I3)
40    CALL CLOSE(IDCBI,IERR)
      IF(IERR.GE.0) GO TO 42
      WRITE(LU,41) IERR 
41    FORMAT("CLOSE ERROR ON LIB1 ",I3) 
42    CONTINUE
      END 
      END$
                                                            