extext

目前,国内运用COBOL语言的公司很少,导致目前国内懂cobol的程序员甚少.我这里提供几个由简入深的例子,希望对大家能够有用

      * SQLCA        : SQLCA MESSAGE DDMMUNICATION AREA OF SQL DDMMAND *
      * DBCTBL01     : DCLGEN FOR DBTABL01                            *
      * DBCTBL02     : DCLGEN FOR DBTABL02                            *
      * DBCTBL03     : DCLGEN FOR DBTABL03                            *
      *-----------------------------------------------------------------
           EXEC SQL
                INCLUDE SQLCA
           END-EXEC.
      *
           EXEC SQL
                INCLUDE DBCTBL01
           END-EXEC.
      *
           EXEC SQL
                INCLUDE DBCTBL02
           END-EXEC.
      *
           EXEC SQL
                INCLUDE DBCTBL03
           END-EXEC.
      *
      *
      ***********************************
      *    DB2 RESPONSE CODE            *
      ***********************************
      *
            COPY DB2RTCD.
            COPY MISERR01 IN LIBRYMIS.
      *
      ***********************************
      *    DB2 CURSOR DECLARE           *
      ***********************************
           EXEC SQL
                DECLARE CSR-DBTABL01 CURSOR FOR
                SELECT * FROM DBTABL01
                WHERE condition
           END-EXEC.
      *
           EXEC SQL
                DECLARE CSR-DBTABL02 CURSOR FOR
                SELECT * FROM DBTABL02
                WHERE condition
           END-EXEC.
      *
           EXEC SQL
                DECLARE CSR-DBTABL03 CURSOR FOR
                SELECT * FROM DBTABL03
                WHERE condition
           END-EXEC.
      *
      ********************************
       LINKAGE SECTION.
      ********************************
      *
       01  LINK-PARM.
           03 LINK-PARM-LEN       PIC 9(04) COMP.
           03 LINK-PARM-MSG       PIC X(60).
      **************************************
       PROCEDURE DIVISION USING LINK-PARM.
      **************************************
      *
       DECLARATIVES.
           COPY FILEDCL REPLACING == :FILENAME: == BY == FILNAM1  ==
                                  ==':FILENAME:'== BY =='FILNAM1 '==.
           COPY FILEDCL REPLACING == :FILENAME: == BY == FILNAM2  ==
                                  ==':FILENAME:'== BY =='FILNAM2 '==.
           COPY FILEDCL REPLACING == :FILENAME: == BY == FNAME1   ==
                                  ==':FILENAME:'== BY =='FNAME1  '==.
           COPY FILEDCL REPLACING == :FILENAME: == BY == NAMEFF   ==
                                  ==':FILENAME:'== BY =='NAMEFF  '==.
       END DECLARATIVES.
      *
       A000-MAIN-PROC.
      *
           PERFORM     A000-INITIALIZE
           PERFORM     B000-MAIN-PROCESS
           PERFORM     Z099-PGM-END
      *
           GOBACK.
      *
      *****************************************************************
      *    INITIAL PROCESS ROUTINE                                    *
      *****************************************************************
      *
       A000-INITIALIZE.
      *
           INITIALIZE                            WS-FILE-STS-AREA
                                                 WS-MESSAGE-AREA
                                                 WS-WORKING-VAR
                                                 FILCNAM1
                                                 FILCNAM2
                                                 F1CPYBK
                                                 COF2CPYBK
           MOVE        K-PGM-ID               TO WS-PGM-ID
           SET         WS-PGM-START           TO TRUE
           DISPLAY     WS-PGM-HEAD               WS-PGM-MSG
      *
           SET         STUS-ACTION-OPEN       TO TRUE
           OPEN        INPUT                     FILNAM1
                                                 FILNAM2
                       OUTPUT                    FNAME1
                                                 NAMEFF
           .
           EXIT.
      *
      *****************************************************************
      *    MAIN PROCESS ROUTINE                                       *
      *****************************************************************
      *
       B000-MAIN-PROCESS.

           .
           EXIT.
      *
      *****************************************************************
      *    READ FILE FILNAM1  ROUTINE                                 *
      *****************************************************************
      *
       S000-READ-FILNAM1.
      *
           SET         STUS-ACTION-READ       TO TRUE
           READ                                  FILNAM1
           ADD 1                              TO WS-FILNAM1-READ-CNT
           .
           EXIT.
      *
      *****************************************************************
      *    READ FILE FILNAM2  ROUTINE                                 *
      *****************************************************************
      *
       S000-READ-FILNAM2.
      *
           SET         STUS-ACTION-READ       TO TRUE
           READ                                  FILNAM2
           ADD 1                              TO WS-FILNAM2-READ-CNT
           .
           EXIT.
      *
      *****************************************************************
      *    WRITE FILE FNAME1   ROUTIE                                 *
      *****************************************************************
      *
       S000-WRITE-FNAME1.
      *
           SET         STUS-ACTION-WRITE      TO TRUE
           WRITE                              F1CPYBK
           ADD 1                              TO WS-FNAME1SUCC-CNT
           .
           EXIT.
      *
      *****************************************************************
      *    WRITE FILE NAMEFF   ROUTIE                                 *
      *****************************************************************
      *
       S000-WRITE-NAMEFF.
      *
           SET         STUS-ACTION-WRITE      TO TRUE
           WRITE                              COF2CPYBK
           ADD 1                              TO WS-NAMEFFSUCC-CNT
           .
           EXIT.
      *
      *****************************************************************
      *    OPEN CURSOR CSR-DBTABL01 ROUTINE                           *
      *****************************************************************
      *
       T100-OPEN-DBTABL01.
      *
           EXEC SQL
                OPEN  CSR-DBTABL01
           END-EXEC.
      *
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   OTHER
                 DISPLAY 'FAILED OPEN OF       CSR-DBTABL01'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
      *
           EXIT.
      *
      *****************************************************************
      *    FETCH CURSOR CSR-DBTABL01 ROUTINE                          *
      *****************************************************************
      *
       T100-FETCH-DBTABL01.
      *
           EXEC SQL
                FETCH CSR-DBTABL01 INTO :DBCTBL01
           END-EXEC.
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   DB2-NOTFND
                 SET WS-DBTABL01-EOF          TO TRUE
              WHEN   OTHER
                 DISPLAY 'FAILED FETCH OF     CSR-DBTABL01'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
           EXIT.
      *
      *****************************************************************
      *    CLOSE CURSOR CSR-DBTABL01 ROUTINE                          *
      *****************************************************************
       T199-CLOSE-CSR-DBTABL01.
      *
           EXEC SQL
                CLOSE CSR-DBTABL01
           END-EXEC.
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   OTHER
                 DISPLAY 'FAILED CLOSE OF     CSR-DBTABL01'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
           EXIT.
      *
      *****************************************************************
      *    OPEN CURSOR CSR-DBTABL02 ROUTINE                           *
      *****************************************************************