* formalni upravy pro GnuCOBOL - 01/07/2017:
* - zmeny zdrojoveho textu dle komentaru *> ...
* a) LOOP ... Tesla 200 ridila tiskarnu datovou smyckou
* b) # ... Tesla 200 znala namisto "not ="
* c) ID, TEST ... nyni jsou rezervovana slova
* d) COMPUTATIONAL-1 ... GnuCOBOL pouziva FLOAT-SHORT
* e) ACCEPT .. FROM DATE ... systemove datum je nyni jinak
* - zmena ulozeni DAT-PL a dalsich datumu z "pic 9" na "pic x"
* - odsazeni deklaraci datovych polozek urovne 02 a 03
IDENTIFICATION DIVISION.
PROGRAM-ID. P90003.
AUTHOR. ING CEVELA.
INSTALLATION.
TESLA 200
- POCETNICKA SLUZBA BRNO.
DATE-WRITTEN. MAY 70.
DATE-COMPILED. 3 JUN 1970.
REMARKS.
VYPIS TISKOVE BANKY DO STANDARDNICH SESTAV - VERSE 1.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
*>LOOP 6 IS L/nic.
input-output section.
FILE-CONTROL.
SELECT T-B ASSIGN "tape" line sequential.
*>TAPE CODE ".3"/"tape" line sequential
SELECT TISKARNA ASSIGN "printer" line sequential.
*>PRINTER CODE "*3"/"printer" line sequential
DATA DIVISION.
FILE SECTION.
FD T-B
LABEL RECORD STANDARD
VALUE OF ID "TISKOVA BANKA"
DATA RECORD ZAZNAM.
01 ZAZNAM.
02 ID1 PIC X.
02 ID2 PIC 9.
02 RADEK PIC X(136).
FD TISKARNA
LABEL RECORD OMITTED
DATA RECORD TISK.
01 TISK PIC X(136).
WORKING-STORAGE SECTION.
77 W0 PIC 9 VALUE 0.
77 W1 PIC 9 VALUE 0.
77 W2 PIC 9 VALUE 0.
77 W3 PIC 9 VALUE 0.
77 W4 PIC 9 VALUE 0.
01 POM.
02 ROP PIC 99. *>COMPUTATIONAL-1/nic
02 OPOM PIC 99. *>COMPUTATIONAL-1/nic
02 TEST-X PIC 9. *>TEST/TEST-X
02 PCR PIC 99 VALUE 0.
01 SEST.
02 ID-X. *>ID/ID-X
03 1-1 PIC X.
03 1-2 PIC 9.
02 RL PIC 9.
02 RM PIC 9.
02 RO PIC 99. *>COMPUTATIONAL-1/nic
02 CISLO PIC X(6).
02 DAT-PL PIC X(8). *>9(8)/X(8)
02 DAT-PRED PIC X(8).
02 NAZEV-1 PIC X(39).
02 NAZEV-2 PIC X(39).
01 ID2G1 PIC 9.
01 LEG-1 PIC X(136).
01 ID2G2 PIC 9.
01 LEG-2 PIC X(136).
01 ID2G3 PIC 9.
01 LEG-3 PIC X(136).
01 Z1.
02 FILLER PIC X(114).
02 TE PIC X(10) VALUE "STRANKA : ".
02 STR PIC 999.
02 FILLER PIC X(9) value " ".
01 Z2.
02 FILLER PIC X(9).
02 T-1 PIC X(23) VALUE "INGSTAV BRNO - SESTAVA ".
02 C-S PIC X(6).
02 FILLER PIC X.
02 N-1 PIC X(39).
02 FILLER PIC X(6).
02 T-2 PIC X(18) VALUE "DATUM PLATNOSTI : ".
02 D-1 PIC X(8). *>9(8)/X(8)
02 FILLER PIC X(4).
02 T-3 PIC X(10) VALUE "PREDANO : ".
02 D-2 PIC X(8). *>9(8)/X(8)
02 FILLER PIC X(4).
01 Z3.
02 FILLER PIC X(39).
02 N-2 PIC X(39).
01 Z-0.
02 C0 PIC X(6) VALUE ZERO.
02 N10 PIC X(39) VALUE ZERO.
02 N20 PIC X(39) VALUE ZERO.
02 STR-S0 PIC 999 VALUE 0.
01 Z-1.
02 C1 PIC X(6).
02 N11 PIC X(39).
02 N21 PIC X(39).
02 STR-S1 PIC 999 VALUE 0.
01 Z-2.
02 C2 PIC X(6).
02 N12 PIC X(39).
02 N22 PIC X(39).
02 STR-S2 PIC 999 VALUE 0.
01 Z-3.
02 C3 PIC X(6).
02 N13 PIC X(39).
02 N23 PIC X(39).
02 STR-S3 PIC 999 VALUE 0.
01 TEXT PIC X(25) VALUE "VYTISTENA SESTAVA CISLO ".
01 TEXT1 PIC X(9) VALUE "OBSAHUJE ".
01 TEXT2 PIC X(8) VALUE " STRAN .".
01 ST PIC X(25) VALUE "ON PRESENTE TISK STANDARD".
01 SC.
02 FILLER PIC X.
02 STR-C PIC 9999 VALUE 0.
02 TC PIC X(23) VALUE " STRAN. CA Y EST TOUT !".
01 INF0 PIC X(12) VALUE "ID1 NEZNAM :".
01 INF1 PIC X(32) VALUE "POZADOVANY POCET SESTAV V SOBE :".
01 INF2 PIC X(32) VALUE "POZADOVANY POCET RADKU LEGENDY :".
01 INF3 PIC X(28) VALUE "RADEK LEGENDY NAVIC (CTVRTY)".
01 INF4 PIC X(27) VALUE "POSLEDNI SESTAVA NEMA RADKY".
01 DOTAZ PIC X(21) VALUE "JE MOZNO POKRACOVAT ?".
01 ODP PIC X.
PROCEDURE DIVISION.
BEGIN. OPEN INPUT T-B OUTPUT TISKARNA.
ONE. READ T-B
AT END GO TO T-NINE.
if ID1 not = "R" go to THREE *>#/not =
MOVE 0 TO ROP.
NINE. IF W0 not = 0 GO TO FIVE. *>#/not =
IF ID1 = "L" GO TO FIVE.
ADD ID2 TO PCR
IF PCR > 67 GO TO FIVE.
SUBTRACT ROP FROM 67 GIVING OPOM
IF PCR > OPOM GO TO T-THREE.
TWELVE.
WRITE TISK FROM RADEK AFTER ID2 LINES
GO TO ONE.
T-NINE.
MOVE 1 TO W4
IF W0 not = 0 GO TO THIRTY. *>#/not =
TWO. DISPLAY TEXT, C0
DISPLAY N10
DISPLAY N20
DISPLAY TEXT1, STR-S0, TEXT2
IF STR-S1 = 0 GO TO SIX.
DISPLAY TEXT, C1
DISPLAY N11
DISPLAY N21
DISPLAY TEXT1, STR-S1, TEXT2
IF STR-S2 = 0 GO TO SIX.
DISPLAY TEXT, C2
DISPLAY N12
DISPLAY N22
DISPLAY TEXT1, STR-S2, TEXT2
IF STR-S3 = 0 GO TO SIX.
DISPLAY TEXT, C3
DISPLAY N13
DISPLAY N23
DISPLAY TEXT1, STR-S3, TEXT2.
SIX.
MOVE ZEROS TO STR-S0, STR-S1, STR-S2, STR-S3
IF W4 not = 1 GO TO SEVEN. *>#/not =
ACCEPT DAT-PL FROM DATE YYYYMMDD. *>new
DISPLAY DAT-PL, SC. *>new
*>old: DISPLAY DATE-Y, DATE-M, DATE-DM, SC.
FIN. CLOSE T-B, TISKARNA.
STOP RUN.
THIRTY.
DISPLAY INF4
DISPLAY SEST
GO TO TWO.
THREE. IF ID1 not = "O" GO TO T-TWO. *>#/not =
MOVE RO TO ROP
GO TO NINE.
T-TWO. IF ID1 not = "L" GO TO EIGHT. *>#/not =
GO TO NINE.
EIGHT.
IF ID1 not = "S" GO TO E-TEEN. *>#/not =
MOVE ID2 TO TEST-X *>TEST/TEST-X
MOVE ZAZNAM TO SEST
MOVE 0 TO W1, W2, W3.
TWENTY. MOVE 1 TO W0
GO TO ONE.
E-TEEN. IF ID1 not = "G" GO TO T-FIVE. *>#/not =
IF W1 = 1 GO TO N-TEEN.
MOVE ID2 TO ID2G1
MOVE RADEK TO LEG-1
MOVE 1 TO W1
GO TO TWENTY.
T-FIVE.
DISPLAY INF0, ID1
DISPLAY CISLO
GO TO SI-TEEN.
N-TEEN. IF W2 = 1 GO TO T-ONE.
MOVE ID2 TO ID2G2
MOVE RADEK TO LEG-2
MOVE 1 TO W3.
GO TO TWENTY.
T-ONE. IF W3 = 1 GO TO T-SIX.
MOVE ID2 TO ID2G2
MOVE RADEK TO LEG-3
MOVE 1 TO W3
GO TO TWENTY.
T-SIX.
DISPLAY INF3
DISPLAY CISLO
GO TO SI-TEEN.
FIVE. IF TEST-X not = 0 GO TO TEN. *>TEST/TEST-X,#/not =
IF C0 = ZERO GO TO T-FOR.
IF CISLO not = C0 GO TO TWO. *>#/not =
SEVEN.
ADD STR-S0, 1 GIVING STR, STR-S0
MOVE CISLO TO C0, C-S
MOVE NAZEV-1 TO N10, N-1
MOVE NAZEV-2 TO N20, N-2.
FO-TEEN. MOVE DAT-PL TO D-1
MOVE DAT-PRED TO D-2.
MOVE SPACES TO TISK
WRITE TISK *>AFTER L/nic
WRITE TISK FROM Z1 *>AFTER 4 LINES/nic
WRITE TISK FROM Z2
WRITE TISK FROM Z3.
MOVE 6 TO PCR
IF RL < 1 GO TO SE-TEEN.
ELEVEN. WRITE TISK FROM LEG-1 AFTER ID2G1 LINES
ADD ID2G1 TO PCR
IF RL < 2 GO TO SE-TEEN.
WRITE TISK FROM LEG-2 AFTER ADVANCING ID2G2 LINES
ADD ID2G2 TO PCR
IF RL < 3 GO TO SE-TEEN.
WRITE TISK FROM LEG-3 AFTER ADVANCING ID2G3 LINES
ADD ID2G3 TO PCR
IF RL < 4 GO TO SE-TEEN.
DISPLAY INF2, RL
DISPLAY SEST.
T-EIGHT.
DISPLAY DOTAZ
ACCEPT ODP
IF ODP not = "A" GO TO FIN. *>#/not =
GO TO ONE.
TEN. IF TEST-X not = 1 GO TO T-TEEN. *>TEST/TEST-X,#/not =,
ADD STR-S1, 1 GIVING STR, STR-S1
MOVE CISLO TO C1, C-S
MOVE NAZEV-1 TO N11, N-1
MOVE NAZEV-2 TO N21, N-2
GO TO FO-TEEN.
T-TEEN. IF TEST-X not = 2 GO TO T-SEVEN. *>TEST/TEST-X,#/not =
ADD STR-S2, 1 GIVING STR, STR-S2
MOVE CISLO TO C2, C-S
MOVE NAZEV-1 TO N12, N-1
MOVE NAZEV-2 TO N22, N-2
GO TO FO-TEEN.
FI-TEEN. IF TEST-X not = 3 GO TO T-SEVEN. *>TEST/TEST-X,#/not =
ADD STR-S3, 1 GIVING STR, STR-S3
MOVE CISLO TO C3, C-S
MOVE NAZEV-1 TO N13, N-1
MOVE NAZEV-2 TO N23, N-2
GO TO FO-TEEN.
T-SEVEN.
DISPLAY INF1, TEST-X *>TEST/TEST-X
DISPLAY CISLO.
SI-TEEN.
DISPLAY ZAZNAM
GO TO T-EIGHT.
T-FOR.
DISPLAY ST
GO TO SEVEN.
SE-TEEN.
ADD 1 TO STR-C.
MOVE SPACES TO TISK
WRITE TISK AFTER RM LINES
MOVE 0 TO W0
ADD RM TO PCR
ADD ID2 TO PCR
GO TO TWELVE.
T-THREE.
MOVE 0 TO ROP
GO TO FIVE.