Calcul itérations dans sources RPG 400






Commande de lancement et de saisie des paramètres (QCMDSRC)
       **************  Début des données  ****************************************
0001.00              CMD        PROMPT('Itérations dans source RPG')               
0002.00                                                                            
0003.00              PARM       KWD(FIC) TYPE(*CHAR) LEN(10) PROMPT('Fichier +     
0004.00                           concerné')                                       
0005.00                                                                            
0006.00                                                                            
0007.00              PARM       KWD(BIB) TYPE(*CHAR) LEN(10) +                     
0008.00                           PROMPT('Bibliothèque du fichier')                
0009.00                                                                            
0010.00              PARM       KWD(MBR) TYPE(*CHAR) LEN(10) PROMPT('Membre +      
0011.00                           source à modifier')                              
0012.00                                                                            
        ***************  Fin des données  *****************************************


CL de préparation du source à modifier (QCLSRC)

        ***************  Début des données **********************************
0001.00              PGM        PARM(&FIC &BIB &MBR)                          
0002.00                                                                       
0003.00                                                                       
0004.00              DCL        VAR(&FIC) TYPE(*CHAR) LEN(10)                 
0005.00              DCL        VAR(&BIB) TYPE(*CHAR) LEN(10)                 
0006.00              DCL        VAR(&MBR) TYPE(*CHAR) LEN(10)                 
0007.00                                                                       
0008.00              OVRDBF     FILE(QRPGSRC) TOFILE(&BIB/&FIC) MBR(&MBR)     
0009.00              MONMSG     MSGID(CPF0000) EXEC(DO)                       
0010.00              GOTO       CMDLBL(FIN)                                   
0011.00              ENDDO                                                    
0012.00                                                                       
0013.00              CALL       PGM(ITERATION)                               
0014.00                                                                       
0015.00              DLTOVR     FILE(*ALL)                                    
0016.00                                                                       
0017.00  FIN:        ENDPGM                                                   
        ***************  Fin des données  ************************************



Programme RPG IV (ITERATION) qui met à jour le source (QRPGLESRC)

0001.00  ********************************************************************            
0002.00 FQRPGSRC   UP A E           K DISK    RENAME(QRPGSRC:RPGF)                            
0003.00  ********************************************************************            
0004.00 F*                                                                                    
0005.00 D                 DS                                                                  
0006.00 D  WRKSRCDTA              1     80                                                    
0007.00 D  ZONE_TABLE             1      3                                                    
0008.00 D  ZONE_FRANCHE           1      5                                                    
0009.00 D  COULEUR                1      1                                                    
0010.00 D  COMPTEUR               2      4                                                    
0011.00 D  CARTE_C                6      6                                                    
0012.00 D  ETOILE                 7      7                                                    
0013.00 D  FIN_COULEUR            5      5                                                    
0014.00 D  CODOPERATION          26     32                                                    
0015.00 D  ITER_DEBUT            28     29                                                    
0016.00 D  ITER_FIN              28     30                                                    
0017.00 D  ITER_ELSE             28     31                                                    
0018.00 D  ITER_ENDSR            28     32                                                    
0019.00 D  INDIC_EGAL            58     59                                                    
0020.00 D  DEBUT_COMMENT         60     60                                                    
0021.00 D  COMMENTAIRE           60     74                                                    
0022.00  * Structure de données des erreurs programmes SDS                                    
0023.00 D                SDS   
0024.00 D  PGM                    1     10                                                                
0025.00 D  USER                 254    263                                                                
0026.00                                                                                                   
0027.00  *===================================================                       
0028.00 C     *ENTRY        PLIST                                                                         
0029.00 C                   PARM                    TRAITEMENT        5                                   
0030.00  *                                                                                                
0031.00 C                   SETOFF                                       50                               
0032.00 C                   EVAL      WRKSRCDTA = SRCDTA                                                  
0033.00                                                                                                   
0034.00  *  controle si tableau , si oui enregistrement pas traité                
0035.00 C                   IF        ZONE_TABLE  = '** '                                                 
0036.00 C                   SETON                                        LR                               
0037.00 C                   GOTO      FIN                                                                 
0038.00 C                   ENDIF                                                                         
0039.00                                                                                                   
0040.00 C                   CLEAR                   ZONE_FRANCHE                                          
0041.00                                                                                                   
0042.00 C                   IF        ETOILE='*'                                                          
0043.00 C*                                               
0044.00 C                   MOVEL     X'220F'       COULEUR                                               
0045.00 C                   GOTO      SAUT                                                                
0046.00 C                   ELSE                                                                          
0047.00 C                   MOVEL     X'200F'       COULEUR   
0048.00 C                   ENDIF                                                       
0049.00                                                                                 
0050.00 C                   IF        ITER_DEBUT='IF'                                   
0051.00 C                             OR ITER_DEBUT='DO'                                
0052.00 C                   EVAL      CPT=CPT+1                                         
0053.00 C*                             
0054.00 C                   MOVEL     X'280F'       COULEUR                             
0055.00 C                   MOVEL     X'200F'       FIN_COULEUR                         
0056.00 C                   MOVEL     'D'           COMPTEUR                            
0057.00 C                   MOVE      CPT           COMPTEUR                            
0058.00 C                   SETON                                        50             
0059.00 C                   ENDIF                                                       
0060.00                                                                                 
0061.00 C                   IF        ITER_ELSE ='ELSE'                                 
0062.00 C*                             
0063.00 C                   MOVEL     X'280F'       COULEUR                             
0064.00 C                   MOVEL     X'200F'       FIN_COULEUR                         
0065.00 C                   MOVEL     'X'           COMPTEUR                            
0066.00 C                   MOVE      CPT           COMPTEUR                            
0067.00 C                   SETON                                        50             
0068.00 C                   ENDIF                                                       
0069.00                                                                                 
0070.00 C                   IF        ITER_FIN ='END'                                   
0071.00 C                             AND ITER_ENDSR <>'ENDSR'                          
0072.00 C                             AND ITER_ENDSR <>'ENDSL'                          
0073.00 C                             AND ITER_ENDSR <>'ENDCS'                          
0074.00 C*                             
0075.00 C                   MOVEL     X'280F'       COULEUR                             
0076.00 C                   MOVEL     X'200F'       FIN_COULEUR                         
0077.00 C                   MOVEL     'F'           COMPTEUR                            
0078.00 C                   MOVE      CPT           COMPTEUR                            
0079.00 C                   EVAL      CPT=CPT-1                                         
0080.00 C                   SETON                                        50             
0081.00 C                   ENDIF                                                       
0082.00                                                                                 
0083.00 C                   IF        ITER_ENDSR ='ENDSR'                               
0084.00 C                             OR ITER_ENDSR ='BEGSR'                            
0085.00 C*                         
0086.00 C*                         
0087.00 C*                         
0088.00 C                   MOVEL     X'300F'       FIN_COULEUR                         
0089.00 C                   ENDIF                                                       
0090.00                                                                                 
0091.00                                                                                 
0092.00 C                   IF        CARTE_C   ='C'                                    
0093.00 C                   IF        COMMENTAIRE <> *BLANKS                            
0094.00 C                   MOVE      COMMENTAIRE   WRK_COMMENTAIR   16                 
0095.00 C                   MOVEL     WRK_COMMENTAIRCOMMENTAIRE                         
0096.00 C                   MOVEL     X'220F'       DEBUT_COMMENT                   
0097.00 C                   SETON                                        50         
0098.00 C                   ENDIF                                                   
0099.00 C                   ENDIF                                                   
0100.00                                                                             
0101.00 C     SAUT          TAG                                                     
0102.00 C                   EVAL      SRCDTA = WRKSRCDTA                            
0103.00 C                   UPDATE    RPGF                                          
0104.00                                                                             
0105.00 C     FIN           TAG                                                     
0106.00  *                                                                          
0107.00 C     *INZSR        BEGSR                                                   
0108.00 C                   Z-ADD     0             CPT               2 0           
0109.00 C                   ENDSR