IDENTIFICATION DIVISION. TEST01 PROGRAM-ID. TEST01. TEST01 *AUTHOR. Test 01. TEST01 *DATE-COMPILED. 16/09/15. TEST01 ENVIRONMENT DIVISION. TEST01 CONFIGURATION SECTION. TEST01 SOURCE-COMPUTER. IBM-370. TEST01 OBJECT-COMPUTER. IBM-370. TEST01 DATA DIVISION. TEST01 WORKING-STORAGE SECTION. TEST01 01 DEBUT-WSS. TEST01 05 FILLER PICTURE X(7) VALUE 'WORKING'. TEST01 05 IK PICTURE X. TEST01 01 CONSTANTES-PAC. TEST01 05 FILLER PICTURE X(87) VALUE TEST01 '9999 SPB16/09/15TEST01ADMIN 19:50:21TEST01 BVAPTEST01 - '16/09/20153.5 V0419/02/201425/02/2014'. TEST01 01 PAC-CONSTANTES REDEFINES CONSTANTES-PAC. TEST01 05 NUGNA PICTURE X(5). TEST01 05 APPLI PICTURE X(3). TEST01 05 DATGN PICTURE X(8). TEST01 05 PROGR PICTURE X(6). TEST01 05 CODUTI PICTURE X(8). TEST01 05 TIMGN PICTURE X(8). TEST01 05 PROGE PICTURE X(8). TEST01 05 COBASE PICTURE X(4). TEST01 05 DATGNC PICTURE X(10). TEST01 05 RELEAS PICTURE X(7). TEST01 05 DATGE PICTURE X(10). TEST01 05 DATSQ PICTURE X(10). TEST01 01 DATCE. TEST01 05 CENTUR PICTURE XX VALUE '20'. TEST01 05 DATOR. TEST01 10 DATOA PICTURE XX. TEST01 10 DATOM PICTURE XX. TEST01 10 DATOJ PICTURE XX. TEST01 01 DAT6. TEST01 10 DAT61. TEST01 15 DAT619 PICTURE 99. TEST01 10 DAT62. TEST01 15 DAT629 PICTURE 99. TEST01 10 DAT63 PICTURE XX. TEST01 01 DAT8. TEST01 10 DAT81 PICTURE XX. TEST01 10 DAT8S1 PICTURE X. TEST01 10 DAT82 PICTURE XX. TEST01 10 DAT8S2 PICTURE X. TEST01 10 DAT83 PICTURE XX. TEST01 01 DAT8E REDEFINES DAT8. TEST01 10 DAT81E PICTURE X(4). TEST01 10 DAT82E PICTURE XX. TEST01 10 DAT83E PICTURE XX. TEST01 01 DAT6C. TEST01 10 DAT61C PICTURE XX. TEST01 10 DAT62C PICTURE XX. TEST01 10 DAT63C. TEST01 15 DAT63CC PICTURE XX. TEST01 15 DAT64C PICTURE XX. TEST01 01 DAT8C. TEST01 10 DAT81C PICTURE XX. TEST01 10 DAT8S1C PICTURE X VALUE '/'. TEST01 10 DAT82C PICTURE XX. TEST01 10 DAT8S2C PICTURE X VALUE '/'. TEST01 10 DAT83C. TEST01 15 DAT83CC PICTURE XX. TEST01 15 DAT84C PICTURE XX. TEST01 01 TIMCO. TEST01 05 TIMCOH PICTURE XX. TEST01 05 TIMCOM PICTURE XX. TEST01 05 TIMCOS PICTURE XX. TEST01 05 TIMOC. TEST01 10 TIMCOC PICTURE XX. TEST01 01 TIMDAY. TEST01 05 TIMHOU PICTURE XX. TEST01 05 TIMS1 PICTURE X VALUE ':'. TEST01 05 TIMMIN PICTURE XX. TEST01 05 TIMS2 PICTURE X VALUE ':'. TEST01 05 TIMSEC PICTURE XX. TEST01 01 DAT7. TEST01 10 DAT71 PICTURE XX. TEST01 10 DAT72 PICTURE XX. TEST01 10 DAT73 PICTURE XX. TEST01 01 DATSEP PICTURE X VALUE '/'. TEST01 01 DATSET PICTURE X VALUE '-'. TEST01 01 DATSEW PICTURE X. TEST01 01 DAT-TRANS. TEST01 05 DAT-CTYD PICTURE XX VALUE '61'. TEST01 05 DAT-CTYT PICTURE XX VALUE '61'. TEST01 05 DAT-CTY PICTURE XX VALUE '19'. TEST01 05 DAT-ADO PICTURE X VALUE SPACE. TEST01 01 DATCTY. TEST01 05 DATCTY9 PICTURE 99. TEST01 01 DAT7C. TEST01 10 DAT71C PICTURE XX. TEST01 10 DAT72C PICTURE XX. TEST01 10 DAT73C PICTURE XX. TEST01 10 DAT74C PICTURE XX. TEST01 01 DAT8G. TEST01 10 DAT81G PICTURE XX. TEST01 10 DAT82G PICTURE XX. TEST01 10 DAT8S1G PICTURE X VALUE '-'. TEST01 10 DAT83G PICTURE XX. TEST01 10 DAT8S2G PICTURE X VALUE '-'. TEST01 10 DAT84G PICTURE XX. TEST01 01 TT-DAT. TEST01 05 T-DAT PICTURE X OCCURS 5. TEST01 01 LEAP-YEAR. TEST01 05 LEAP-FLAG PICTURE X. TEST01 05 LEAP-REM PICTURE 99. TEST01 01 VARIABLES-CONDITIONNELLES. TEST01 05 FT PICTURE X VALUE '0'. TEST01 01 INDICES COMPUTATIONAL SYNC. TEST01 05 TALLI PICTURE S9(4) VALUE ZERO. TEST01 01 VARIABLES-CONTROLE. TEST01 05 EN-PRE PICTURE X. TEST01 01 ZONES-UTILISATEUR PICTURE X. TEST01 PROCEDURE DIVISION. *N01. NOTE *************************************. TEST01 * * * TEST01 * *INITIALISATIONS * TEST01 * * * TEST01 * *************************************. TEST01 F01. EXIT. F01-FN. EXIT. * NOTE * DEBUT ITERATION DU PROGRAMME *. TEST01 F05. EXIT. *N20. NOTE *************************************. TEST01 * * * TEST01 * *FIN DE TRAITEMENT * TEST01 * * * TEST01 * *************************************. TEST01 F20. IF FT = ALL '1' NEXT SENTENCE ELSE GO TO F20-FN. TEST01 F2099. GOBACK. F2099-FN. EXIT. F20-FN. EXIT. *N60. NOTE *************************************. * * * * *Traitement * * * * * *************************************. F60. lv05 * *N60BB. NOTE *BLOCK *. F60BB. lv10 * *!AD "SM DATCE ZZZZ" id=1 MOVE CENTUR TO DAT-CTY MOVE SPACE TO DAT-ADO 000001 MOVE DATCE 000001 TO DAT6C MOVE DATSEP TO DATSEW 000001 PERFORM F9520-S THRU F9520-Z 000001 MOVE DAT8C TO ZZZZ. 000001 F60BB-FN. EXIT. *N60CC. NOTE *test *. F60CC. *!DVF "S DATCE" lv10 * id=2 MOVE '0' TO DAT-ADO 000002 MOVE DATCE 000002 TO DAT6C 000002 PERFORM F9520-S THRU F9520-FN 000002 IF EN-PRE = '1' 000002 NEXT SENTENCE ELSE GO TO F60CC-FN. TEST01 * F60CC-FN. EXIT. *N60DD. NOTE *Tout en -P *. F60DD. lv10 * * Opérateurs généraux * =================== *!* " Commentaire" id=32 *Commentaire 000032 *!M "A B" id=3 MOVE A TO B 000003 *!MA "A B" id=4 MOVE ALL A TO B 000004 *!P "F60BB" id=5 PERFORM F60BB THRU F60BB-FN 000005 *!C "A = B + C" *!A "A B" id=6 ADD A TO B 000006 *!S "A B" id=7 SUBTRACT A FROM B 000007 *!MP "A B" *!DV "A B" id=8 DIVIDE A INTO B 000008 *!MES "'Hello World !'" id=9 DISPLAY 'Hello World !' 000009 *!ACC "DATOR FROM DATE" id=10 ACCEPT DATOR FROM DATE 000010 *!STR "'Hello' ' ' 'World' delimited by size into B" id=11 STRING 'Hello' ' ' 'World' delimited by size into B 000011 *!UNS "A delimited by space into B" *!CAL "'MYPROG' using A" id=12 CALL 'MYPROG' using A 000012 *!GFT id=36 MOVE ALL '1' TO FT GO TO F20. 000036 *!GDI id=33 GO TO F05. 000033 *!GB "10" id=35 GO TO F60DD-900. 000035 *!EXA "A tallying A for all characters before space" *!INS "A tallying A for all characters before space" *!EXC "RETURN" id=13 EXEC CICS RETURN END-EXEC. 000013 *!EXP "INIT" id=14 EXEC PAF INIT END-EXEC. 000014 *!COB "MOVE A TO B" id=15 MOVE A TO B. 000015 *!COA "F60DD-MINE." id=16 F60DD-MINE. COA *!SCH "A B" *!SCB "A B" *!ADT id=17 MOVE FUNCTION CURRENT-DATE TO DATCE 000017 *!ADC id=18 MOVE FUNCTION CURRENT-DATE TO DATCE 000018 *!AD "SM A B" id=19 MOVE CENTUR TO DAT-CTY MOVE SPACE TO DAT-ADO 000019 MOVE A 000019 TO DAT6C MOVE DATSEP TO DATSEW 000019 PERFORM F9520-S THRU F9520-Z 000019 MOVE DAT8C TO B 000019 *!AD0 "A B" id=20 MOVE '0' TO DAT-ADO 000020 MOVE A 000020 TO DAT1 MOVE DATSEP TO DATSEW 000020 PERFORM F9520- THRU F9520-Z 000020 MOVE DAT2 TO B 000020 *!AD1 "A B" id=21 MOVE '1' TO DAT-ADO 000021 MOVE A 000021 TO DAT1 MOVE DATSEP TO DATSEW 000021 PERFORM F9520- THRU F9520-Z 000021 MOVE DAT2 TO B 000021 *!AD2 "A B" id=22 MOVE '2' TO DAT-ADO 000022 MOVE A 000022 TO DAT1 MOVE DATSEP TO DATSEW 000022 PERFORM F9520- THRU F9520-Z 000022 MOVE DAT2 TO B 000022 *!ADI "A B" id=23 MOVE A 000023 TO DAT6 DAT8 000023 MOVE DAT63 TO DAT61 MOVE DAT81 TO DAT63 000023 MOVE DAT6 TO B 000023 *!ADE "A B" id=24 MOVE A 000024 TO DAT6 DAT8 000024 MOVE DAT62 TO DAT82 MOVE DAT63 TO DAT83 000024 MOVE DATSEP TO DAT8S1 DAT8S2 000024 MOVE DAT8 TO B 000024 *!TIM "A" id=25 ACCEPT TIMCO FROM TIME 000025 MOVE TIMCO TO A 000025 *!TIF "A B" id=26 MOVE A 000026 TO DAT8E DAT6C 000026 MOVE DAT61C TO TIMHOU MOVE DAT62C TO TIMMIN 000026 MOVE DAT82E TO TIMSEC MOVE ':' TO TIMS1 TIMS2 000026 MOVE TIMDAY TO B 000026 * * Opérateurs SQL * ============== *!EXQ "COMMIT" id=37 EXEC SQL COMMIT END-EXEC. 000037 *!SCC *!SDC *!SCO *!SRO *!SWH "SQLERROR CONTINUE" * !SQL "PG01 SD01 S S0" * * Opérateurs Cobol II * =================== *!CON *!EVA "A" id=27 EVALUATE A 000027 *!EVT *!EVF *!EEV id=28 END-EVALUATE 000028 *!EIF id=29 END-IF 000029 *!EPE *!ESE *!INI "A" id=30 INITIALIZE A 000030 *!SEA "A" *!SCH "A" *!GOB id=31 GOBACK 000031 * * Opérateurs BATCH * ================ *!OPE "DD" id=38 OPEN DD-FICHIER 000038 *!CLO "DD" id=39 CLOSE DD-FICHIER 000039 *!R "DD" id=40 MOVE 0 TO IK 000040 READ DD-FICHIER 000040 AT END MOVE 1 TO IK 000040 *!W "DD01" id=41 MOVE 0 TO IK 000041 WRITE DD01 000041 *!RW "DD01" id=42 MOVE 0 TO IK 000042 REWRITE DD01 000042 INVALID KEY MOVE 1 TO IK 000042 *!RN "DD" id=43 MOVE 0 TO IK 000043 READ DD-FICHIER NEXT 000043 AT END MOVE 1 TO IK 000043 *!STA "DD CLE" id=44 MOVE 0 TO IK 000044 START DD-FICHIER 000044 KEY CLE 000044 INVALID KEY MOVE 1 TO IK 000044 *!DEL "DD01" id=45 MOVE 0 TO IK 000045 DELETE DD01-FICHIER 000045 INVALID KEY MOVE 1 TO IK 000045 *!TRI "DD" *!ADM "A B" id=46 MOVE A 000046 TO DAT8E DAT6C 000046 MOVE DAT61C TO DAT81C MOVE DAT62C TO DAT82C 000046 MOVE DAT63C TO DAT83C MOVE DATSEP TO DAT8S1C DAT8S2C 000046 MOVE DAT8C TO B 000046 *!ADS "A B" id=47 MOVE A 000047 TO DAT8E DAT6C 000047 MOVE DAT83E TO DAT61C MOVE DAT81E TO DAT63C 000047 MOVE DAT82E TO DAT62C 000047 MOVE DAT6C TO B. 000047 F60DD-FN. EXIT. F60-FN. EXIT. F9099-ITER-FN. GO TO F05. *N9520. NOTE * DATES *. TEST01 F9520. EXIT. F9520-C. MOVE DAT73C TO DATCTY. MOVE DAT71C TO DAT71. TEST01 MOVE DAT72C TO DAT72. TEST01 MOVE DAT74C TO DAT73. TEST01 MOVE '00111' TO TT-DAT GO TO F9520-T. TEST01 F9520-D. MOVE DAT-CTY TO DATCTY DAT73C. IF DAT-ADO < '1' GO TO F9520-DT. TEST01 IF DAT-ADO = '2' GO TO F9520-D2. TEST01 IF DAT73 < DAT-CTYT MOVE '19' TO DATCTY DAT73C TEST01 ELSE MOVE '20' TO DATCTY DAT73C. TEST01 GO TO F9520-DT. TEST01 F9520-D2. IF DAT73 < DAT-CTYT MOVE '20' TO DATCTY DAT73C TEST01 ELSE MOVE '19' TO DATCTY DAT73C. TEST01 F9520-DT. MOVE DAT71 TO DAT71C. MOVE DAT72 TO DAT72C. TEST01 MOVE DAT73 TO DAT74C. TEST01 MOVE '00111' TO TT-DAT GO TO F9520-T. TEST01 F9520-E. MOVE DAT-CTY TO DATCTY DAT83CC. IF DAT-ADO < '1' GO TO F9520-ET. TEST01 IF DAT-ADO = '2' GO TO F9520-E2. TEST01 IF DAT83 < DAT-CTYT MOVE '19' TO DATCTY DAT83CC TEST01 ELSE MOVE '20' TO DATCTY DAT83CC. TEST01 GO TO F9520-ET. TEST01 F9520-E2. IF DAT83 < DAT-CTYT MOVE '20' TO DATCTY DAT83CC TEST01 ELSE MOVE '19' TO DATCTY DAT83CC. TEST01 F9520-ET. MOVE DAT81 TO DAT81C. MOVE DAT82 TO DAT82C. TEST01 MOVE DAT83 TO DAT84C. TEST01 MOVE DATSEW TO DAT8S1C DAT8S2C. TEST01 MOVE '01011' TO TT-DAT GO TO F9520-T. TEST01 F9520-G. MOVE DAT81G TO DATCTY. MOVE DAT82G TO DAT61. TEST01 MOVE DAT83G TO DAT62. TEST01 MOVE DAT84G TO DAT63. TEST01 MOVE '10110' TO TT-DAT GO TO F9520-T. TEST01 F9520-I. MOVE DAT-CTY TO DATCTY DAT61C. IF DAT-ADO < '1' GO TO F9520-IT. TEST01 IF DAT-ADO = '2' GO TO F9520-I2. TEST01 IF DAT61 < DAT-CTYT MOVE '19' TO DATCTY DAT61C TEST01 ELSE MOVE '20' TO DATCTY DAT61C. TEST01 GO TO F9520-IT. TEST01 F9520-I2. IF DAT61 < DAT-CTYT MOVE '20' TO DATCTY DAT61C TEST01 ELSE MOVE '19' TO DATCTY DAT61C. TEST01 F9520-IT. MOVE DAT61 TO DAT62C. MOVE DAT62 TO DAT63CC. TEST01 MOVE DAT63 TO DAT64C. TEST01 MOVE '10101' TO TT-DAT GO TO F9520-T. TEST01 F9520-M. MOVE DAT83CC TO DATCTY. MOVE DAT81C TO DAT81. TEST01 MOVE DAT82C TO DAT82. TEST01 MOVE DAT84C TO DAT83. TEST01 MOVE DATSEW TO DAT8S1 DAT8S2. TEST01 MOVE '01011' TO TT-DAT GO TO F9520-T. TEST01 F9520-S. MOVE DAT61C TO DATCTY. MOVE DAT62C TO DAT61. TEST01 MOVE DAT63CC TO DAT62. TEST01 MOVE DAT64C TO DAT63. TEST01 MOVE '10101' TO TT-DAT. TEST01 F9520-T. IF T-DAT (1) = '1' MOVE DAT61 TO DAT73 DAT74C TEST01 MOVE DAT62 TO DAT72 DAT72C TEST01 MOVE DAT63 TO DAT71 DAT71C TEST01 MOVE DATCTY TO DAT73C. TEST01 IF T-DAT (2) = '1' TEST01 MOVE DAT81 TO DAT71 DAT71C TEST01 MOVE DAT82 TO DAT72 DAT72C TEST01 MOVE DAT83 TO DAT73 DAT74C TEST01 MOVE DATCTY TO DAT73C. TEST01 IF T-DAT (3) = '1' TEST01 MOVE DAT71 TO DAT81 DAT81C TEST01 MOVE DAT72 TO DAT82 DAT82C TEST01 MOVE DAT73 TO DAT83 DAT84C TEST01 MOVE DATSEW TO DAT8S1 DAT8S2 TEST01 DAT8S1C DAT8S2C TEST01 MOVE DATCTY TO DAT83CC. TEST01 IF T-DAT (4) = '1' TEST01 MOVE DAT71 TO DAT63 DAT64C TEST01 MOVE DAT72 TO DAT62 DAT63CC TEST01 MOVE DAT73 TO DAT61 DAT62C TEST01 MOVE DATCTY TO DAT61C. TEST01 IF T-DAT (5) = '1' TEST01 MOVE DAT61 TO DAT82G TEST01 MOVE DAT62 TO DAT83G TEST01 MOVE DAT63 TO DAT84G TEST01 MOVE DATSEW TO DAT8S1G DAT8S2G TEST01 MOVE DATCTY TO DAT81G. TEST01 F9520-Z. EXIT. F9520-ER. MOVE '1' TO EN-PRE. IF DAT6 NOT NUMERIC GO TO F9520-KO. TEST01 IF DATCTY NOT NUMERIC GO TO F9520-KO. TEST01 IF DAT62 > '12' OR DAT62 = '00' OR TEST01 DAT63 > '31' OR DAT63 = '00' TEST01 GO TO F9520-KO. TEST01 IF DAT63 > '30' AND TEST01 (DAT62 = '04' OR DAT62 = '06' OR TEST01 DAT62 = '09' OR DAT62 = '11') TEST01 GO TO F9520-KO. TEST01 IF DAT62 NOT = '02' GO TO F9520-FN. TEST01 IF DAT63 > '29' GO TO F9520-KO. TEST01 IF DAT619 = ZERO TEST01 DIVIDE DATCTY9 BY 4 GIVING LEAP-REM TEST01 COMPUTE LEAP-REM = DATCTY9 - 4 * LEAP-REM TEST01 ELSE DIVIDE DAT619 BY 4 GIVING LEAP-REM TEST01 COMPUTE LEAP-REM = DAT619 - 4 * LEAP-REM. TEST01 IF DAT63 < '29' OR LEAP-REM = ZERO TEST01 GO TO F9520-FN. TEST01 F9520-KO. MOVE '5' TO EN-PRE. F9520-FN. EXIT.