IDENTIFICATION DIVISION.
 
       PROGRAM-ID. CBLI08.
 
       ENVIRONMENT DIVISION.
 
       CONFIGURATION SECTION.
       SOURCE-COMPUTER. IBM-AS400.
       OBJECT-COMPUTER. IBM-AS400.
       SPECIAL-NAMES. DECIMAL-POINT IS COMMA.
 
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT ECRAN ASSIGN TO WORKSTATION-DSPI08-SI
           ORGANIZATION TRANSACTION ACCESS DYNAMIC
           RELATIVE KEY IS RANG FILE STATUS IS ETAT.
 
           SELECT FICH1L1 ASSIGN TO DATABASE-FICH1L1
           ORGANIZATION INDEXED ACCESS DYNAMIC
           RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
           WITH DUPLICATES.
 
           SELECT FICH2P1 ASSIGN TO DATABASE-FICH2P1
           ORGANIZATION INDEXED ACCESS RANDOM
           RECORD KEY IS EXTERNALLY-DESCRIBED-KEY
           WITH DUPLICATES.
 
       DATA DIVISION.
 
       FILE SECTION.
       FD  ECRAN.
       01  BUFFER PIC X(37).
       FD  FICH1L1.
       01  enreg1.
           COPY DDS-FICH1F1 OF FICH1L1.
       FD  FICH2P1.
       01  enreg2.
           COPY DDS-FICH2F1 OF FICH2P1.
 
       WORKING-STORAGE SECTION.
 
       01  TINDIC.
           05 IND OCCURS 99 PIC 1 INDICATOR 01.
       01  F1I.

           COPY DDS-F1-I OF DSPI08.
       01  SFLIO.
           COPY DDS-SFL  OF DSPI08.
       01  CTLO.
           COPY DDS-CTL-O OF DSPI08.
       77  ERREUR PIC XXX VALUE "NON".
       77  RANG PIC 9999.
       77  FLAGEOF PIC X.
               88 EOF value "O".
       77  ETAT PIC XX.
       77  NOMBRE PIC 99.
      *===========================================
       PROCEDURE DIVISION.
      *===========================================
 
           OPEN INPUT FICH2P1 FICH1L1 I-O ECRAN.
           WRITE BUFFER FORMAT "TITRE".
           WRITE BUFFER FORMAT "F1".
           READ ECRAN INTO F1-I FORMAT "F1" INDIC TINDIC.
           PERFORM UNTIL IND(03) = B"1"
                   PERFORM TRAITEMENT
                   WRITE BUFFER FORMAT "F1" INDIC TINDIC
                   READ ECRAN INTO F1-I FORMAT "F1" INDIC TINDIC
           END-PERFORM.
           CLOSE FICH1L1 FICH2P1 ECRAN.
           STOP RUN.
 
       TRAITEMENT.
           MOVE CODE OF F1-I TO CODE OF FICH2F1.
           READ FICH2P1
           INVALID KEY
              MOVE B"1" TO IND(50)
           NOT INVALID KEY
             MOVE CODE OF F1-I TO CODE OF FICH1F1
             START FICH1L1 KEY IS EQUAL TO CODE OF FICH1F1
                          INVALID KEY
                           MOVE B"1" TO IND(50)
                          NOT INVALID KEY
                           PERFORM SOUSFICHIER
             END-START
           END-READ.
       SOUSFICHIER.
           PERFORM RAZ.
           READ FICH1L1 NEXT AT END SET EOF TO TRUE

                                    MOVE B"1" TO IND(32).
           MOVE CORR FICH2F1 TO CTL-O.
           WRITE BUFFER FORMAT "PIED".
           PERFORM UNEPAGE.
           PERFORM WITH TEST AFTER UNTIL IND(12) = B"1"
              WRITE BUFFER FROM CTL-O FORMAT "CTL" INDIC TINDIC
              READ ECRAN FORMAT "CTL" INDIC TINDIC
              IF IND(60) = B"1" PERFORM UNEPAGE END-IF
           END-PERFORM.
       RAZ.
           MOVE "N" TO FLAGEOF.
           MOVE ZERO TO RANG.
           MOVE B"0" TO IND(30) IND(31).
           WRITE BUFFER FROM CTL-O FORMAT "CTL" INDIC TINDIC.
           MOVE B"1" TO IND(31).
       ECRSOUSFICHIER.
             MOVE CORR FICH1F1 TO SFL.
             ADD 1 TO RANG NOMBRE.
             MOVE B"1" TO IND(30).
             WRITE SUBFILE BUFFER FROM SFL FORMAT "SFL".
       UNEPAGE.
             MOVE 0 TO NOMBRE.
             PERFORM UNTIL EOF OR
                         CODE OF FICH1F1 NOT = CODE OF F1-I
                         OR NOMBRE = 15
                         PERFORM ECRSOUSFICHIER
               READ FICH1L1 NEXT AT END SET EOF TO TRUE
                                        MOVE B"1" TO IND(32) END-READ
             END-PERFORM.
             MOVE RANG TO LIGNE.