JDoodle - Online COBOL Compiler IDE ... ( Ctrl+C, open this link in new panel, Ctrl+V, Submit )
identification division.
program-id. ED-A. *> Elementary Data Items - pic X, 9, Z
data division.
working-storage section.
77 A pic x(7) value "Hi".
77 B pic 9(7) value 17.
77 C pic z(7) value 256.
77 D pic z(6)9 value 8234.
77 E pic zzz,zz9 value 1283.
procedure division.
display "A=" A " ... X - non numeric, from the LEFT"
display "B=" B " ... 9 - numeric, from the RIGHT, if = 0 then all zeros"
display "C=" C " ... Z - numeric edited, if = 0 then all spaces"
display "D=" D " ... numeric edited, if D = 0 then one zero"
display "E=" E " ... numeric edited, fix comma for thousands"
display " "
display "......v......v......v......v......v"
display A B C D E
initialize A B C D E
display A B C D E
stop run.
Note:
INITIALIZE statement was new in ANSI-85
before that it was necessary:
move space to A
move 0 to B C D E
Output:
A=Hi ... X - non numeric, from the LEFT
B=0000017 ... 9 - numeric, from the RIGHT, if = 0 then all zeros
C= 256 ... Z - numeric edited, if = 0 then all spaces
D= 8234 ... numeric edited, if D = 0 then one zero
E= 1,283 ... numeric edited, fix comma for thousands
......v......v......v......v......v
Hi 0000017 256 8234 1,283
0000000 0 0
ČeV - 6.5.2020
xxx
JDoodle - Online COBOL Compiler IDE ...
( Ctrl+C, open this link in new panel, Ctrl+V, Submit )
identification division.
program-id. DATA-F.
*> STDIN - file - screen
*> *** the last line in STDIN must contain only *end
environment division.
input-output section.
file-control.
select FIL assign "LS-FILE" line sequential.
data division.
file section.
fd FIL.
1 REC-F pic x(80).
working-storage section.
77 F pic 9.
88 INP-F value 0.
88 END-F value 1.
procedure division.
call "READ-STDIN"
open input FIL
set INP-F to true
perform until END-F
read FIL
end set END-F to true
not end display REC-F
end-read end-perform
close FIL
stop run.
program-id. READ-STDIN.
environment division.
input-output section.
file-control.
select FIL assign "LS-FILE" line sequential.
data division.
file section.
fd FIL.
1 REC-F pic x(80).
working-storage section.
77 NUM-S pic 999.
77 REC-S pic x(80).
88 INP-S value space.
88 END-S value "*end".
procedure division.
initialize NUM-S REC-S.
open output FIL
perform until END-S
accept REC-S
if not END-S
write REC-F from REC-S
add 1 to NUM-S
end-if end-perform
close FIL
*> display "NUM-S=" NUM-S
exit program.
end program READ-STDIN.
end program DATA-F.
JDoodle - Online COBOL Compiler IDE ...
( Ctrl+C, open this link in new panel, Ctrl+V, Submit )
program-id. READ-STDIN.
environment division.
input-output section.
file-control.
select FIL assign "LS-FILE" line sequential.
data division.
file section.
fd FIL.
1 REC-F pic x(80).
working-storage section.
77 NUM-S pic 999.
77 REC-S pic x(80).
88 INP-S value space.
88 END-S value "*end".
procedure division.
initialize NUM-S REC-S.
open output FIL
perform until END-S
accept REC-S
if not END-S
write REC-F from REC-S
add 1 to NUM-S
end-if end-perform
close FIL
*> display "NUM-S=" NUM-S
exit program.
end program READ-STDIN.
JDoodle - Online COBOL Compiler IDE ... ( Ctrl+C, open this link in new panel, Ctrl+V, Submit )
identification division.
program-id. LS-FILE. *> STDIN - file - screen
*> *** the last line in STDIN must contain only *end
environment division.
input-output section.
file-control.
select FIL assign "LS-FILE" line sequential.
data division.
file section.
fd FIL.
1 REC-F pic x(80).
working-storage section.
77 REC-I pic x(80) value " ".
77 F pic 9.
88 INP-F value 0.
88 END-F value 1.
procedure division.
perform INP-PROC
perform OUT-PROC
stop run.
INP-REC.
write REC-F from REC-I.
OUT-REC.
move REC-F to REC-I
display REC-I.
INP-PROC.
open output FIL
perform until REC-I = "*end"
accept REC-I
perform INP-REC end-perform
close FIL.
OUT-PROC.
open input FIL
set INP-F to true
perform until END-F
read FIL
end set END-F to true
not end perform OUT-REC end-read end-perform
close FIL.
xxx
identification division.
program-id. CALL-N.
procedure division.
display "main-prog"
call "N1"
display "return ok"
stop run.
program-id. N1.
procedure division.
display "N1"
exit program.
end program N1.
end program CALL-N.
* 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.
xxx xxx xxx ...xxx
1960
JDoodle - Online COBOL Compiler IDE ...
(Ctrl+C, open link in new panel, Ctrl+V, Submit)
identification division.
program-id. TYPEWRITER. *> from STDIN to screen directly
*> with GO statements - NON Interactive mode ***
data division.
working-storage section.
1 TW-MEMORY.
2 INP-LINE pic x(80) occurs 5.
77 I pic 9 value 1.
procedure division.
MAIN-PROC.
move space to TW-MEMORY
perform INP-PROC thru WORK-PROC.
END-PROC.
display " the work is finished ***"
stop run.
INP-PROC.
if I > 5
display " limit 5 exceeded"
go END-PROC.
WORK-PROC.
accept INP-LINE(I)
if INP-LINE(I) = "e"
go END-PROC
else
display I ". " INP-LINE(I)
add 1 to I
go INP-PROC.
I = STDIN:
aaaaaaa bbbbbbb ccccccc e
O = screen:
1. aaaaaaa 2. bbbbbb 3. ccccccc work is terminated ***
ANS X3.23-1968
JDoodle - Online COBOL Compiler IDE ...
(Ctrl+C, open link in new panel, Ctrl+V, Submit)
identification division.
program-id. TYPEWRITER. *> keyboard - memory - screen
*> structured code without scope-delimiters
*> *** execute in Interactive mode ***
data division.
working-storage section.
1 TW-MEMORY.
2 INP-LINE pic x(80) occurs 5.
77 I pic 9.
procedure division.
move space to TW-MEMORY
display "write text max 5 times, at end write e:" display " "
perform INP-PROC varying I from 1 by 1 until I > 5
display " entry is complete" display " "
perform OUT-PROC varying I from 1 by 1 until INP-LINE(I) = "e" or I > 5
display " the work is finished ***"
stop run.
INP-PROC.
accept INP-LINE(I)
if INP-LINE(I) = "e"
move 6 to I.
OUT-PROC.
display I ". " INP-LINE(I).
I = keyboard, W = memory, O = screen:
write text max 5 times, at end write e: aaaaaaa bbbbbbb ccccccc e entry is complete 1. aaaaaaa 2. bbbbbbb 3. ccccccc the work is finished ***
ANSI '85
JDoodle - Online COBOL Compiler IDE ...
(Ctrl+C, open link in new panel, Ctrl+V, Submit)
identification division.
program-id. TYPEWRITER. *> keyboard - memory - screen
*> structured code with scope-delimiters
*> *** execute in Interactive mode ***
data division.
working-storage section.
1 TW-MEMORY.
2 INP-LINE pic x(80) occurs 5.
77 I pic 9.
77 MEM pic 9.
88 MEM-BEG value 0.
88 MEM-END value 1.
procedure division.
initialize TW-MEMORY
set MEM-BEG to true
display "write text max 5 times, at end write e:" display " "
perform varying I from 1 by 1 until I > 5 or MEM-END
accept INP-LINE(I)
if INP-LINE(I) = "e"
set MEM-END to true
end-if end-perform
display " entry is complete" display " "
perform varying I from 1 by 1 until INP-LINE(I) = "e" or I > 5
display I ". " INP-LINE(I)
end-perform
display " the work is finished ***"
stop run.
I = keyboard, W = memory, O = screen:
write text max 5 times, at end write e: aaaaaaaa bbbbbbbb cccccccc e entry is complete 1. aaaaaaaa 2. bbbbbbbb 3. cccccccc
the work is finished
Čevela - 8.5.2020