Fortran

C     NOM:         FORTRANS.                                  
C     AUTEUR:      CH.
C     LANGAGE:     FORTRAN 77. 
C     DESCRIPTION: Force 2.0  (G77)
C     DATE:        Début le 02/06/2008   
C     Références :
C 
C(FIV)   Livre : fortran IV de M. DREYFUS         (DUNOD Paris 1970)       
C(ILF)   Livre : Initiation au langage fortran    (DUNOD Paris 1970)  
C(IBM)   IBM : Common Programming interface-FORTRAN Référence (1990)
C
C(WE1)   https://perso.imt-mines-albi.fr/~gaborit/lang/CoursDeFortran/
C(WE2)   https://docs.oracle.com/pls/topic/lookup?ctx=dsc&id=/app/docs/doc/802-2998/6i6u3logs?a=view
C(WE3)   http://www-ipst.u-strasbg.fr/pat/program/fortran/
C     __________________________________________________________________
C
C     Ce programme n'a aucun objectif fonctionnel particulier, il se 
C        propose d'effectuer, après les avoir isolés, une transcodifica-
C        tion de groupes de caractères présents dans une chaîne caracté-
C        risant des formules. A l'issue de cette transcodification un 
C        fichier est créé.

 
       PROGRAM  FORTRANS

       IMPLICIT NONE
C--------------------              
C  
       CHARACTER      ENREG_F*80     /' '/
       CHARACTER      ZONE_GRP*64    /' '/
       CHARACTER      C_XX*1         /' '/
       CHARACTER      IO_ORDRE*16
       CHARACTER      EXT_OUT*12          
       CHARACTER      FMT_OUT*32         /'(A25, 1X, A25, 1X, A28)'/
       CHARACTER      F_NAME_IN*16,       F_NAME_OUT*16,    NOM_PGM*8 
       CHARACTER      TAB_RANG_OK*32 /' '/!Table de passation de valeurs
       
C                                                Numéric Type (p.15 IBM)     
       INTEGER        IND_F                        
       INTEGER        ISAVE_POS                   
       INTEGER        IPOS_TRANS                  
       INTEGER        IVAL_NUM                    
       INTEGER        IND_GRP                     
       INTEGER        NB_POSTES_VALID   
       INTEGER        NB_POSTES         
       INTEGER        INDIC_ANOM        
       INTEGER        SAVIND_ANOM        
       INTEGER        INDIC_INFOS        
       INTEGER        CPT_ENREG             
       INTEGER        IO_RC          
       INTEGER        IS_KO_OK       
       INTEGER        IS_I                        
       INTEGER        K                     
       INTEGER        II                     
C      Comptage du nb. de c.par groupe et position des groupes.
       INTEGER        ICPT_CAR                    
       INTEGER        IPOS_GRP                     
       INTEGER        ICPT_GRP                    
       INTEGER        ISAVE_CPT_CAR               
C      Variables permettant de borner les tables (voir PARAMETER).
       INTEGER        LONG_TABS 
       INTEGER        LONG_DIMS
       INTEGER        ZONE_L_DIMS 
C      Variables de définition des unités (unit) (voir PARAMETER).
       INTEGER        DATA_UT_IN    
       INTEGER        DATA_UT_OUT    

C                                              (WE3) Variables communes.        
       COMMON        /VAR_INIT/
     S      IND_F,    ICPT_CAR,    ICPT_GRP,   ISAVE_CPT_CAR,
     S	    ISAVE_POS,IPOS_TRANS,  IVAL_NUM,   IND_GRP

       COMMON        /ANOM_INIT/
     S      NB_POSTES_VALID,       NB_POSTES,   INDIC_ANOM,
     S      INDIC_INFOS,           SAVIND_ANOM, CPT_ENREG,    IO_RC

C----------------------------------------------------------------------- 
C                                                  Constantes (p.40 IBM)     
       PARAMETER  (   DATA_UT_IN  = 10,
     S                F_NAME_IN   = 'reactions.txt',
     S                DATA_UT_OUT = 11,
     S                EXT_OUT     = '',
     S                LONG_TABS   = 256,
     S                LONG_DIMS   = 32,
     S                NOM_PGM     = 'FORTRANS'   )

C-----------------------------------------------------------------------              
C                                    Déclaration des tableaux (p.21 IBM)     

       DIMENSION  TAB_GRP        (LONG_TABS) !Tableau des groupes de c.  
       CHARACTER  TAB_GRP*32                 !et signes valides. 

       DIMENSION  TAB_VAL_GRP    (LONG_TABS)!Tableau des valeurs affec- 
       INTEGER    TAB_VAL_GRP         ! tées aux groupes de c.et signes 

C     Tableau de stockage résultats intermédiaires:TAB_GRP<=>TAB_VAL_GRP 
       INTEGER*8  TAB_INT_VAL    (LONG_DIMS) !Tableau intermédiaire .
	   
C      Tableaux de stockage.
       DIMENSION  TAB_FORM_INIT  (LONG_TABS) ! Tableau des formules  
       CHARACTER  TAB_FORM_INIT*80           ! d'origine (idem fichier)   
                                                       
C      Tableaux de stockage des résultats des transcodifications.
       DIMENSION  TAB_FORM       (LONG_TABS)
       CHARACTER  TAB_FORM*32     !Tableau des formules sans opérateurs.

       INTEGER*8  TAB_VAL_NUM    (LONG_TABS) !Tableau valeurs<=>formules
                  
       DIMENSION  TAB_CHAR_NUM   (LONG_TABS)!Tableau des valeurs des for 
       CHARACTER  TAB_CHAR_NUM*32            ! mules en mode caractères.

       INTEGER AV_POSTES_FLECHE  (LONG_TABS) !nb.positions avant ->.
       INTEGER AV2_POSTES_FLECHE (LONG_TABS) !nb.positions avant ->.


C       DIMENSION  TAB_ANOM2 (10)     
C       INTEGER    TAB_ANOM2

C      Tableaux des messages affichés en fin d"exécution.
       DIMENSION  TAB_ANOM       (LONG_DIMS) !Tableau des meessages   
       CHARACTER  TAB_ANOM*80                !d'anomalies détectées.   
C      Tableaux des messages d'information.
       DIMENSION  TAB_INFOS      (LONG_DIMS) !Tableau des meessages   
       CHARACTER  TAB_INFOS*80                !d'informations.   

C      Tableaux de définition des codes et des équivalences numériques. 
       DATA (TAB_GRP           (K), K = 1,23,1)               /
     S                    'H1', 'a', 'H2+', 'H3', 'b', 'H4+',
     S                    'H5', 'c', 'H6+', 'H7', 'd', 'H8+',
     S                    'H2', 'e', 'abcde', 'x','H9+','->',
     S                              '£', 
     S                     '+', '-', ' ',
     S                              '$'                        /
C      '£' Borne identifiant la fin des groupes à transcoder.        
C      '$' Borne identifiant la fin du tableau.        
C      Les groupes de caractères compris entre le début du tableau et'£'
C           génèrent une transcodification (voir TAB_VAL_GRP ci-dessous) 
C      Les groupes de caractères compris entre '£' et '$' ne génèrent
C           aucune transcodification. 

C      Equivalences numériques(POSITIONNELLES avec TAB_GRP ex: H2 = 03):
C      Taleaux de définition des équivalences numériques des groupes à
C           transcoder. 
       DATA (TAB_VAL_GRP       (K), K = 1,18,1)                /
     S                      01,  02,  03,   04,   05,  06,
     S                      07,  08,  09,   10,   11,  12,
     S                      13,  14,  15,   16,   17,   0             /

C      Initialisation des tableaux de stockage des résultats de transco.
C ----------------------------------------------------------------------

       DATA (TAB_FORM_INIT     (K), K = 1,LONG_TABS,1) /LONG_TABS * ' '/ 

       DATA (TAB_FORM          (K), K = 1,LONG_TABS,1) /LONG_TABS * ' '/

       DATA (TAB_VAL_NUM       (K), K = 1,LONG_TABS,1) /LONG_TABS *  0/

       DATA (TAB_CHAR_NUM      (K), K = 1,LONG_TABS,1) /LONG_TABS * ' '/
       
       DATA (AV_POSTES_FLECHE  (K), K = 1,LONG_TABS,1) /LONG_TABS * -1/
       DATA (AV2_POSTES_FLECHE (K), K = 1,LONG_TABS,1) /LONG_TABS * -1/

       DATA (TAB_INFOS         (K), K = 1,LONG_DIMS,1) /LONG_DIMS * ' '/
       DATA (TAB_ANOM          (K), K = 1,LONG_DIMS,1) /LONG_DIMS * ' '/

C----------------------------------------------------------------------- 
C      Appel de sous programmes externes :            
C                  -----------------------------------------------------
C                  Modification de la taille de la fenetre Windows (DOS)     
 
       CALL SYSTEM    ('MODE CON COLS=150 LINES=90')
       CALL SYSTEM    ('ERASE VVVV.TXT')


C***********************************************************************
C                        SEQUENCE PRINCIPALE.
C***********************************************************************

       PRINT *,  NOM_PGM
       CALL      INIT_GEN     ()     
       CALL      CONTROL_GEN  (TAB_GRP,    TAB_ANOM,  LONG_TABS, 
     S                         DATA_UT_IN, F_NAME_IN  )     
      
       print 1000
       print 1010
  
C      Boucle de lectures des enregistrements du fichier en INPUT.         
       DO  WHILE          (IO_RC      ==   0)
C         .AND.  INDIC_ANOM  ==  0)
C                                                 ----------------------
C                                                 READ -WRITE (p 77 IBM)
         IO_ORDRE                      =  ' READ_IN'
         READ   (UNIT   = DATA_UT_IN,      FMT    = 500,
     S           IOSTAT = IO_RC,           ERR    = 15)
     S	         ENREG_F

         IF               (IO_RC    .eq.    -1)                    THEN
C          Ecriture en table des messages d'information.
           CALL   AFFICH_STATINFOS (TAB_INFOS, F_NAME_IN, INDIC_INFOS, 
     S                              IO_ORDRE,  LONG_TABS, CPT_ENREG,
     S                              IO_RC      )
           
         ELSE
           CPT_ENREG                   =  CPT_ENREG   +   1
           IF (CPT_ENREG               >  LONG_TABS   -   1)       THEN
C          IF (CPT_ENREG              >  2  )        THEN
              IF   (SAVIND_ANOM       == 0 )                       THEN
	         SAVIND_ANOM           =  INDIC_ANOM  +   1
                 INDIC_ANOM            =  INDIC_ANOM  +   2 
	      END IF   
              WRITE (TAB_ANOM  (SAVIND_ANOM),     040) 
     S               CPT_ENREG - (LONG_TABS - 1), LONG_TABS  -  1,   
     S                                            F_NAME_IN
              WRITE (TAB_ANOM  (SAVIND_ANOM + 1), 041)
           END IF 
           
C          Sauvegarde dans TAB_FORM_INIT des enregistrements lus: 
           TAB_FORM_INIT   (CPT_ENREG) =  ENREG_F
C          Initialisation des éléments utiles au traitement d'1 enreg.
           CALL   INIT_VAR (TAB_INT_VAL,  LONG_DIMS) 
           
C          Boucle d'exploration des caractères d'un même enregistrement.             
           DO WHILE        (IND_F      <= LEN      (ENREG_F) )
  	     C_XX                      =  ENREG_F  (IND_F:1)
C  	     Identification des caractères significatifs (# de space)
	     IF (C_XX    .eq. ' '  .AND.  IND_F  <  LEN(ENREG_F))  THEN
C              Traitement du groupe venant d'être identifié (ICPT_CAR).
               IF (ICPT_CAR            >  0)                       THEN  	        
	          ZONE_GRP (1:ICPT_CAR) = 
     S	                        ENREG_F (ISAVE_POS:ISAVE_POS + ICPT_CAR)
	          ISAVE_POS            =  IND_F      +   1  
                  ISAVE_CPT_CAR        =  ICPT_CAR 
                  ICPT_CAR             =  0 
                  IF    (ZONE_GRP (1:2)== '->')                    THEN
		      AV2_POSTES_FLECHE   (CPT_ENREG) = ICPT_GRP
		  END IF  
                  ICPT_GRP             =  ICPT_GRP   +   1 
C              Elimination des espaces superflus (> 1) entre 2 groupes.                 
               ELSE
                  ISAVE_POS            =  ISAVE_POS  +   1       
               END IF
	     ELSE
C	       Comptage du nb.de c. constituant le groupe en cours.
               ICPT_CAR                =  ICPT_CAR   +   1
C????????????? IF        (ZONE_GRP (1:1) .ne. ' ' .OR. IND_F == 1) THEN
	       IF        (ZONE_GRP (1:1) .ne. ' ' )                THEN
C                 Recherche d'égalité entre TAB_GRP <=> groupe en cours.          
                  CALL CHERCH_GRP (ZONE_GRP,  TAB_GRP,         IS_KO_OK,
     S                             NB_POSTES, NB_POSTES_VALID, IPOS_GRP)
C                 Le groupe existe (OK) ou pas (KO) en table TAB_GRP ?
                  IF     (IS_KO_OK     ==  1 )                     THEN
                     IF  (ZONE_GRP (1:2)==  '->')                  THEN
		       AV_POSTES_FLECHE   (CPT_ENREG) = IND_GRP  
                     ELSE
C		       Formatage TAB_FORM Table formules sans opérateur: 
	               IND_GRP         =  IND_GRP     +   1   
                       TAB_FORM       (CPT_ENREG) = 
     S                     TAB_FORM   (CPT_ENREG)    (1:IPOS_TRANS)   // 
     S    	                       ZONE_GRP      (1:ISAVE_CPT_CAR)
                       IPOS_TRANS      =  IPOS_TRANS + ISAVE_CPT_CAR + 1
C	               Correspondance groupe <=> valeur numérique
                       TAB_INT_VAL    (IND_GRP) = TAB_VAL_GRP (IPOS_GRP) 		    
                     END IF
C                 KO   
                  ELSE                     
                     IF  (IS_KO_OK    == 0)                        THEN
C                    Groupe inconnu dans table TAB_GRP. 
                       INDIC_ANOM      =  INDIC_ANOM  +   1
                       WRITE (TAB_ANOM   (INDIC_ANOM),  060) 
     S 		                          ZONE_GRP    (1:10),
     S		                          ENREG_F     (1:32)
                     END IF                ! Fin du précédent IF
                  END IF              ! Fin du test OK KO
	       ZONE_GRP                =  ' '  
	       END IF             ! Fin du test ZONE_GRP (1:1)
             END IF          ! Fin du test ident. des c.
             IND_F                     =  IND_F        +   1 
	       
           END DO ! Fin de la Boucle d'exploration des c. d'un enreg.
       
C          Traitement effectué uniquement s'il n'existe aucune anomalie.       
           IF (INDIC_ANOM               ==  0 )                    THEN
C            Par enregistrement génération d'une valeur alpha/numérique.
             ZONE_L_DIMS                 =  LONG_DIMS
             CALL GENER_VAL (TAB_INT_VAL,   ZONE_L_DIMS, 
     S                       TAB_RANG_OK,   IVAL_NUM,       EXT_OUT  )
             TAB_CHAR_NUM   (CPT_ENREG)  =  TAB_RANG_OK 
             TAB_VAL_NUM    (CPT_ENREG)  =  IVAL_NUM
	   END IF

          END IF                  ! Fin normale de fichier.
       END DO                ! Fin de la Boucle de lecture du fichier.

C      Affichage des messages d'Information/Anomalie en fin d'exécution.
       CALL         AFFICH_STATANO ( TAB_ANOM,  TAB_INFOS, INDIC_ANOM,
     S                               INDIC_INFOS )

C      Séquence itérative d'écriture des fichiers: 1 fichier par formule
       II                                =  1 
              
       
C       DO  WHILE                ( II    <= CPT_ENREG )
       
C          F_NAME_OUT                     = TAB_CHAR_NUM  (II)
          F_NAME_OUT                     = 'VVVV.TXT' 
           
          IO_ORDRE                       = 'OPEN_NOFORM'        
          OPEN   (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC, 
     S            FILE   = F_NAME_OUT,     STATUS = 'NEW',
     S            ACCESS = 'SEQUENTIAL',   FORM   = 'FORMATTED', 
     S            ERR    = 15)
          IO_ORDRE                       = 'OPEN_NOFORM'        

       II                                =  1 
       DO  WHILE                ( II    <= CPT_ENREG )
          IO_ORDRE                       = 'WRITE_NOFORM'        
          WRITE  (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,
     S	          FMT    = FMT_OUT,        ERR    = 15)
     S            TAB_CHAR_NUM  (II), ! Si changement modifier le format  
     S            TAB_FORM      (II), ! FMT_OUT en conséquence.
     S            TAB_FORM_INIT (II)
C                 Contenu de chaque enreg. (à déterminer précisément)     

          II                             =  II    +   1 
       END DO       




          IO_ORDRE                       = 'CLOSE_NOFORM'        
          CLOSE  (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,
     S              ERR    = 15,           STATUS = 'KEEP')

          IO_ORDRE                       = 'OPEN_NOFORM'        
          OPEN   (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC, 
     S            FILE   = F_NAME_OUT,     STATUS = 'OLD',
     S            ACCESS = 'SEQUENTIAL',   FORM   = 'FORMATTED', 
     S            ERR    = 15)
          IO_ORDRE                       = 'OPEN_NOFORM'        

       IO_ORDRE          = 'REWIND'
       REWIND    (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,    ERR = 15) 

       II                                =  1 
       DO WHILE (IO_RC .ne. -1  )
          IO_ORDRE          = 'READ'
          READ (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC, 
     S          FMT    = FMT_OUT,            ERR    = 15)
     S          TAB_CHAR_NUM  (II), ! Si changement modifier le format  
     S          TAB_FORM      (II), ! FMT_OUT en conséquence.
     S          TAB_FORM_INIT (II)

          IF     (IO_RC    .eq.    -1)     THEN
            INDIC_ANOM                  =  INDIC_ANOM +   1 
            WRITE    (TAB_ANOM (INDIC_ANOM), 030) NOM_PGM,
     S                                           IO_RC,
     S	                                         IO_ORDRE
            INDIC_ANOM                  =  INDIC_ANOM +   1 
            WRITE    (TAB_ANOM (INDIC_ANOM), 031) CPT_ENREG
C          ELSE
C	    PRINT *,'*TAB_CHAR_NUM  (II) ', TAB_CHAR_NUM  (II),' II ',II
          ENDIF                   
          II                             =  II    +   1 
       END DO       



       IO_ORDRE          = 'OPEN_DIR'        
       OPEN      (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC, 
     S            FILE   = F_NAME_OUT,     STATUS = 'OLD',
     S            ACCESS = 'DIRECT',       FORM   = 'FORMATTED',
     S            ERR    = 15,             RECL   = 78)

       IO_ORDRE          = 'REWIND'
       REWIND    (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,    ERR = 15) 

C       print *,'0000000000000000',TAB_CHAR_NUM  (50)
C       print *,TAB_FORM      (50) ! FMT_OUT en conséquence.
C       print *,TAB_FORM_INIT (50)
            IO_ORDRE        = 'READ_DIR'        
            READ (UNIT     = DATA_UT_OUT,  IOSTAT = IO_RC,
     S	          FMT      = FMT_OUT,          REC    = 1, 
     S            ERR      = 15)
     S            TAB_CHAR_NUM  (50), 
     S            TAB_FORM      (50),
     S            TAB_FORM_INIT (50)

C       print *,'TAB_CHAR_NUM  (50)', TAB_CHAR_NUM  (50) 
C       print *,'TAB_FORM      (50)', TAB_FORM      (50)
C       print *,'TAB_FORM_INIT (50)', TAB_FORM_INIT (50) (1:32)

C                         pause
        go to 005
        
                  
C------recherche d'une formule sur sa cle ------------------------       
00101   CONTINUE
       IO_ORDRE          = 'REWIND'
       REWIND    (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,    ERR = 15) 

       CPT_ENREG                         = 0 
       II                                =  1 
       TAB_CHAR_NUM  (1) = ' '              
       DO WHILE (IO_RC .ne. -1  .AND. TAB_CHAR_NUM  (1)
     S                                            .ne. '12322')

       IO_ORDRE          = 'READ'
            READ (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC, 
     S            FMT    = FMT_OUT,            ERR    = 15)
     S            TAB_CHAR_NUM  (1), ! Si changement modifier le format  
     S            TAB_FORM      (1), ! FMT_OUT en conséquence.
     S            TAB_FORM_INIT (1)

          IF     (IO_RC    .eq.    -1)     THEN
            PRINT *,F_NAME_OUT, ': Fin normale de fichier RC : ', 
     S              IO_RC,' SUR ORDRE : ', IO_ORDRE
            PRINT *,F_NAME_OUT,': Nb.d''enregistrements lus/affiches: ',
     S              CPT_ENREG      
          ELSE
	    PRINT *, 'TAB_CHAR_NUM  (1) ', TAB_CHAR_NUM  (1)
            CPT_ENREG                    = CPT_ENREG  +  1
          ENDIF                   
          II                             =  II    +   1 
       END DO       
C       call rien (II)
C       call rien2 (II)
       PAUSE
C                                                    ENDFILE  (p 88 IBM)
       
          IO_ORDRE                       = 'CLOSE_NOFORM'        
          CLOSE  (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,
     S              ERR    = 15,           STATUS = 'KEEP')
       

C       GO TO 001       

C---------------------------------------------------------------------       
       
       
       II                                =  1 

       DO  WHILE                ( II    <= CPT_ENREG )
       
          F_NAME_OUT                     = TAB_CHAR_NUM  (II) (1:16)
           
          IO_ORDRE                       = 'OPEN_NOFORM'        
          OPEN   (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC, 
     S            FILE   = F_NAME_OUT,     STATUS = 'NEW',
     S            ACCESS = 'SEQUENTIAL',   FORM   = 'FORMATTED', 
     S            ERR    = 15)
          IO_ORDRE                       = 'OPEN_NOFORM'        

          IO_ORDRE                       = 'WRITE_NOFORM'        
          WRITE  (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,
     S	          FMT    = FMT_OUT,        ERR    = 15)
     S            TAB_CHAR_NUM  (II), ! Si changement modifier le format  
     S            TAB_FORM      (II), ! FMT_OUT en conséquence.
     S            TAB_FORM_INIT (II)
C                 Contenu de chaque enreg. (à déterminer précisément)     

          IO_ORDRE                       = 'CLOSE_NOFORM'        
          CLOSE  (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,
     S              ERR    = 15,           STATUS = 'KEEP')
          II                             =  II    +   1 
       END DO       
C---------------------------------------------------------------------       








C                                                    ENDFILE  (p 88 IBM)
005     ENDFILE   (UNIT   = DATA_UT_OUT,   IOSTAT = IO_RC,    ERR = 15)
     
          IO_ORDRE                       = 'CLOSE_NOFORM'        
          CLOSE  (UNIT   = DATA_UT_OUT,    IOSTAT = IO_RC,
     S              ERR    = 15,           STATUS = 'KEEP')
     
       IO_ORDRE                          = 'CLOSE_IN'        
       CLOSE       (UNIT   = DATA_UT_IN,   IOSTAT = IO_RC,
     S              ERR    = 15,           STATUS = 'KEEP')




C001       print *, ' '  

 
       print *, ' '  
       print *, ' '  
       print *, 'TAB_FORM_INIT : Table des formules avant compactage: '
       IS_I             = 1
       do while (IS_I   <=  CPT_ENREG )
           print *,TAB_FORM_INIT (IS_I) (1:42), 'nb.groupes avant -> ',
     S	                                   AV2_POSTES_FLECHE (IS_I), 
     S  '==> ', IS_I
	   IS_I         = IS_I  +  1 
       end do
								   
       print *, ' '
       print *, 'TAB_FORM : Table des formules sans operateurs : '
       IS_I             = 1
       do while (IS_I   <=  CPT_ENREG )
           print *,TAB_FORM (IS_I), 'nb.groupes avant ->  ',
     S                                      AV_POSTES_FLECHE (IS_I),
     S  '==> ', IS_I 
	   IS_I         = IS_I  +  1 
       end do

       print *, ' '
       print *, 'TAB_VAL_NUM : Table des valeurs des formules : '
       IS_I             = 1
       do while (IS_I   <=  CPT_ENREG )
           print *, TAB_VAL_NUM (IS_I) 
	   IS_I         = IS_I  +  1 
       end do

       print *, ' '
C       print *, 'TAB_CHAR_NUM : Table des valeurs des formules : '
       print *, 'TAB_CHAR_NUM : Table des noms de fichiers/formules : '
       IS_I             = 1
       do while (IS_I   <=  CPT_ENREG )
           print *, TAB_CHAR_NUM (IS_I) 
	   IS_I         = IS_I  +  1 
       end do
	
C-----------------------------------------------------------------------              
C                                    -----------------------------------              
C                                   FORMAT (p 92 IBM) (p 77 fortran IV)
C        (WE3) Entrées Sortie et Formats (quatre cinquième de page web).        

C      FORMATS des messages d'anomalie/information (TAB_ANOM TAB_INFOS)   
030   FORMAT ('--Fin normale de fichier ',           A15,
     S         'RC : ',                               I2,
     S         ' SUR ORDRE :',                        A16              ) 
031    FORMAT ('Nb. d''enregistrements traités : ',   I4,
     S         ' pour un max. de ',                   I4               )
     

040    FORMAT (                                       I4,
     S        ' PLUS DE ',                            I4,
     S        ' ENREGISTREMENTS DANS LE FICHIER ',    A15              ) 
041    FORMAT (
     S '    (Affecter une valeure superieure a la variable LONG_TABS.)')
060    FORMAT (                                       A6,     
     S         ' INCONNU DANS TABLE TAB_GRP.',                          
     S         ' FORMULE: ',                          A32              ) 

500    FORMAT (                                       A80              )
1000   FORMAT (
     S        '0        1         2         3         4         5     ',
     S        '    6         7         8'                              )
1010   FORMAT (
     S        '1---5----0----5----0----5----0----5----0----5----0----5',
     S        '----0----5----0----5----0', /                           )

       GO TO 110
       
15     PRINT *,' '
       PRINT *, 'ANOMALIE ENTREE/SORTIE FS : ',    IO_RC, ' SUR ORDRE :'            
     S         ,IO_ORDRE 
110    CONTINUE   

       STOP     
       END      


C***********************************************************************
C      S.P.APPELES PAR UN ORDRE CALL PRESENT DANS LA SEQUENCE PRINCIPALE.
C***********************************************************************

C-----------------------------------------------------------------------              
C         S.P. d'initialisation des variables utiles au traitement.          
C-----------------------------------------------------------------------              

       SUBROUTINE  INIT_GEN  ()     

       IMPLICIT    NONE          

       INTEGER          NB_POSTES_VALID   
       INTEGER          NB_POSTES         
       INTEGER          INDIC_ANOM        
       INTEGER          INDIC_INFOS        
       INTEGER          SAVIND_ANOM        
       INTEGER          CPT_ENREG             
       INTEGER          IO_RC          

       COMMON          /ANOM_INIT/
     S       NB_POSTES_VALID,       NB_POSTES,   INDIC_ANOM,
     S       INDIC_INFOS,           SAVIND_ANOM, CPT_ENREG,    IO_RC

       NB_POSTES_VALID                 =  1
       NB_POSTES                       =  1
       INDIC_ANOM                      =  0 
       INDIC_INFOS                     =  0 
       SAVIND_ANOM                     =  0 
       CPT_ENREG                       =  0
       IO_RC                           =  0

       RETURN
       END


C-----------------------------------------------------------------------              
C         S.P. effectuant les principaux contrôles. 
C-----------------------------------------------------------------------              

       SUBROUTINE CONTROL_GEN   (TAB_GRP,    TAB_ANOM, LONG_TABS,
     S                           DATA_UT_IN, F_NAME_IN )     

       IMPLICIT    NONE          

       CHARACTER  IO_ORDRE*16
       CHARACTER  F_NAME_IN*16
       DIMENSION  TAB_GRP        (*)          !Tableau des signes et   
       CHARACTER  TAB_GRP*32                  !groupes de c. valides. 
       DIMENSION  TAB_ANOM       (*)          !Tableau des meessages   
       CHARACTER  TAB_ANOM*80                 !d'anomalies détectées.   
       CHARACTER  SYMB_FINGRP                 
       
       INTEGER    NB_POSTES_VALID   
       INTEGER    NB_POSTES         
       INTEGER    INDIC_ANOM        
       INTEGER    INDIC_INFOS        
       INTEGER    SAVIND_ANOM        
       INTEGER    CPT_ENREG             
       INTEGER    IO_RC                   
       INTEGER    DATA_UT_IN
       INTEGER    LONG_TABS

       COMMON       /ANOM_INIT/
     S       NB_POSTES_VALID,       NB_POSTES,   INDIC_ANOM,
     S       INDIC_INFOS,           SAVIND_ANOM, CPT_ENREG,    IO_RC


C      Contrôle de présence du fichier en entrée (ouverture si OK)  
       IO_ORDRE                        =   'OPEN_IN'        
       OPEN      (UNIT   = DATA_UT_IN,     IOSTAT = IO_RC, 
     S            FILE   = F_NAME_IN,      STATUS = 'OLD',
     S            ACCESS = 'SEQUENTIAL',   FORM   = 'FORMATTED'  ) 
       IF  (IO_RC                    .ne.   0)                     THEN 
           INDIC_ANOM                  =  INDIC_ANOM +  1 
           WRITE    (TAB_ANOM (INDIC_ANOM), 010)   F_NAME_IN,
     S                                             IO_RC,
     S	                                           IO_ORDRE 
       END IF

C      Recherche la position de la borne £ de fin des groupes à retenir.        
       NB_POSTES_VALID                 =  1 
       DO WHILE     (TAB_GRP (NB_POSTES_VALID) (1:1)  .ne.   '£'  .AND.
     S               NB_POSTES_VALID  <=  LONG_TABS )
         NB_POSTES_VALID               =  NB_POSTES_VALID  +  1
         IF     (NB_POSTES_VALID       >  LONG_TABS)               THEN
           INDIC_ANOM                  =  INDIC_ANOM       +  1
	   SYMB_FINGRP                 =  '£'  
C                                              -------------------------
C                                              Internal Files (p 76 IBM)
           WRITE    (TAB_ANOM (INDIC_ANOM), 020)   SYMB_FINGRP 
         END IF   
       END DO     

C      Recherche de la position de la borne $ de fin du tableau.        
       NB_POSTES                       =  1 
       DO WHILE     (TAB_GRP (NB_POSTES)  (1:1)       .ne.   '$'  .AND.
     S               NB_POSTES        <=  LONG_TABS )
         NB_POSTES                     =  NB_POSTES        +  1
         IF         (NB_POSTES         >  LONG_TABS)               THEN
           INDIC_ANOM                  =  INDIC_ANOM       +  1 
	   SYMB_FINGRP                 =  '$'  
           WRITE    (TAB_ANOM (INDIC_ANOM), 020)   SYMB_FINGRP
         END IF   
       END DO     

      
010    FORMAT ('--ERREUR A L''OUVERTURE DU FICHIER: ', A15,
     S         ' RC : ',                               I2,
     S         ' SUR ORDRE :',                         A16             ) 
020    FORMAT ('ABSENCE DE BORNE DE FIN DE GROUPES (', A,
     S         ') TABLE TAB_GRP.'                                      )

       RETURN
       END

C-----------------------------------------------------------------------              
C      S.P.d'initialisation des variables utiles au traitement d'1 enreg          
C-----------------------------------------------------------------------              

       SUBROUTINE    INIT_VAR  (TAB_INT_VAL, LONG_DIMS)     


       IMPLICIT    NONE          

       INTEGER     IND_F                        
       INTEGER     ICPT_CAR                    
       INTEGER     ICPT_GRP                    
       INTEGER     ISAVE_CPT_CAR               
       INTEGER     ISAVE_POS                   
       INTEGER     IPOS_TRANS                  
       INTEGER     IVAL_NUM                    
       INTEGER     IND_GRP                     
       INTEGER     LONG_DIMS                  
       INTEGER*8   TAB_INT_VAL (*) !Tableau de résultats intermédiaires.
       INTEGER          II           /1/  

       COMMON          /VAR_INIT/
     S       IND_F,     ICPT_CAR,   ICPT_GRP, ISAVE_CPT_CAR,
     S	     ISAVE_POS, IPOS_TRANS, IVAL_NUM, IND_GRP

       IND_F                       =  1
       ICPT_CAR                    =  0
       ICPT_GRP                    =  0
       ISAVE_CPT_CAR               =  0
       ISAVE_POS                   =  1
       IPOS_TRANS                  =  0
       IVAL_NUM                    =  0
       IND_GRP                     =  0

       II                          =  1 
       DO  WHILE            (II    <= LONG_DIMS)
          TAB_INT_VAL       (II)   =  -1
          II                       =  II    +    1      	  
       END DO

       RETURN
       END

C-----------------------------------------------------------------------              
C         S.P. de recherche d'égalité entre TAB_GRP <=> groupe en cours.          
C-----------------------------------------------------------------------              

       SUBROUTINE   CHERCH_GRP ( GRP, TAB_GRP,    IS_KO_OK,  NB_POSTES,
     S                           NB_POSTES_VALID, IS_POS_GRP )

       IMPLICIT     NONE          

       CHARACTER    GRP*64

       INTEGER      IS_POS_GRP    
       INTEGER      NB_POSTES_VALID   
       INTEGER      NB_POSTES         
       INTEGER      IS_KO_OK       

       DIMENSION    TAB_GRP(*)  !Tableau des groupes de caractères et  
       CHARACTER    TAB_GRP*32  !signes valides.(voir dimension en main) 

       IS_KO_OK                   =   2
       IS_POS_GRP                 =   1             
		       
       DO  WHILE   ( IS_POS_GRP   <   NB_POSTES                 .AND. 
     S                                TAB_GRP (IS_POS_GRP) .ne. GRP )
           IS_POS_GRP             =   IS_POS_GRP   +   1
       END DO

       IF           (IS_POS_GRP   <   NB_POSTES_VALID)            THEN
         IS_KO_OK                 =   1
       ELSE                     
          IF        (IS_POS_GRP   ==  NB_POSTES)                  THEN
            IS_KO_OK              =   0
          END IF
       END IF 
 
       RETURN
       END

C-----------------------------------------------------------------------              
C         S.P. de génération d'une valeur numérique par formule  
C-----------------------------------------------------------------------              

       SUBROUTINE   GENER_VAL ( TAB_VAL,    IS_POS_VAL, TAB_RANG,
     S                          IS_VAL_NUM, S_EXT_OUT )

       IMPLICIT    NONE          

       CHARACTER*16 ZONE_CHARNUM
       CHARACTER*1  CS_XX
       CHARACTER    S_EXT_OUT*12        
       CHARACTER    TAB_RANG*32       

       INTEGER      IS_IND_CAR        /0/         
       INTEGER      IS_VAL9           /0/         
       INTEGER      IND_RANG          /0/         
       INTEGER      IS_RANG           /0/         
       INTEGER      IS_SYSNUM        /10/         
       INTEGER      IS_VAL_NUM                  
       INTEGER      IS_POS_VAL                  

       INTEGER*8    TAB_VAL  (*)  
                
       TAB_RANG                       =  ' '  	   
       IND_RANG                       =  LEN (TAB_RANG)
       IS_RANG                        =  0
       IS_VAL_NUM                     =  0

       DO  WHILE       (IS_POS_VAL    >  0 )
         IF (TAB_VAL   (IS_POS_VAL)   >  -1)                      THEN 
           WRITE       (ZONE_CHARNUM, '(I5)')    TAB_VAL (IS_POS_VAL)
           IS_IND_CAR                 =  LEN     (ZONE_CHARNUM )
           DO  WHILE   (IS_IND_CAR    >  0 )
	     CS_XX                    =  ZONE_CHARNUM     (IS_IND_CAR:1)
	     IF        (CS_XX  .ne. ' ')                          THEN  
	       IND_RANG               =  IND_RANG     -   1
	       TAB_RANG               =  CS_XX  // TAB_RANG (1:IND_RANG)
	       IS_VAL9                =  ICHAR (CS_XX) - 48
	           IS_VAL_NUM         =  IS_VAL_NUM   + 
     S                               ( IS_VAL9 * (IS_SYSNUM**IS_RANG ) )    
	       IS_RANG                =  IS_RANG      +   1
	     END IF
             IS_IND_CAR               =  IS_IND_CAR   -   1
	   END DO
         END IF
         IS_POS_VAL                   =  IS_POS_VAL   -   1 
       END DO

C       print *, 'TAB_RANG ',TAB_RANG
C      Ajout de l'extension au nom des fichiers?????????????????.
C       TAB_RANG                     = TAB_RANG (1:IS_RANG) // S_EXT_OUT

C----- COMMENTAIRES:
C      ------------- 
C     Tableau de stockage résultats intermédiaires:TAB_GRP<=>TAB_VAL_GRP
C      TAB_VAL à ce niveau se présente sous forme: (-1 =poste inutilisé)
C      13 3 6 3 14 14 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1

C      Attribution d'un identifiant numérique à chaque formule par con-
C      caténation des valeurs associées à chacun des groupes la consti- 
C      tuant. Ex: (Un élément de TAB_VAL ci dessus): 
C                 Concaténation de 14  14  3  6  3  13 ==> 133631414

C      Chaque valeur attribuée à un groupe est d'abord transcrite en
C      "mode caractères" afin d'en extraire, un à un, le(s) chiffre(s)  
C      le composant. (Ex: valeur du groupe: "13" ==> "3" puis "1"). Dans 
C      un second temps la fonction ICHAR permet de ré-attribuer à chacun  
C      d'eux leur identité numérique (type) nécessaire au calcul:
C
C      Chaque caractère numérique est ensuite évalué de manière classi-
C      que en terme de puissance de 10 relativement au rang* qu'il  
C      occupe dans la suite de chiffres ainsi constituée. 

C     * Position évaluée et comptée de 0 à n de la droite vers la gauche.  
C-----------------------------------------------------------------------       
       
       RETURN
       END


C-----------------------------------------------------------------------              
C      S.P.Affichage en fin d'exécution messages d'Information/Anomalie.
C-----------------------------------------------------------------------              


       SUBROUTINE   AFFICH_STATANO ( TAB_ANOM,   TAB_INFOS, INDIC_ANOM,
     S                               INDIC_INFOS )

       IMPLICIT     NONE          

       INTEGER      INDIC_ANOM        
       INTEGER      INDIC_INFOS        
       INTEGER      II            /1/         

       DIMENSION    TAB_ANOM  (*)  !Tableau des messages d'anomalies  
       CHARACTER    TAB_ANOM*80  
       DIMENSION    TAB_INFOS (*)  !Tableau des messages d'informations.
       CHARACTER    TAB_INFOS*80

       II                                =  1 
       IF (INDIC_ANOM        .ne.  0 )                             THEN
           WRITE              (*, 010) INDIC_ANOM 
           DO  WHILE          (II       <=  INDIC_ANOM )
    	       WRITE          (*, 020) TAB_ANOM         (II)
               II                        =  II    +    1      	  
           END DO
       ELSE
           DO  WHILE          (II       <=  INDIC_INFOS)
    	       WRITE          (*, 020) TAB_INFOS        (II)
               II                        =  II    +    1      	  
           END DO
       END IF 

010    FORMAT (///,                                   
     S        ' COMPTE RENDU DES ANOMALIE(S) DETECTEE(S) ', 
     S                                                I2,   
     S        ' LIGNE(S):' /                                           )  
020    FORMAT ('/- ',                                 A80              )

       
       RETURN
       END

C-----------------------------------------------------------------------              
C      S.P.     Ecriture en table des messages d'Information.
C-----------------------------------------------------------------------              

       SUBROUTINE   AFFICH_STATINFOS (TAB_INFOS, F_NAME_IN, INDIC_INFOS, 
     S                                IO_ORDRE,  LONG_TABS, CPT_ENREG,
     S                                IO_RC  )

       IMPLICIT     NONE          


       CHARACTER    F_NAME_IN*16
       CHARACTER    IO_ORDRE*16

       INTEGER      INDIC_INFOS        
       INTEGER      IO_RC        
       INTEGER      CPT_ENREG        
       INTEGER      LONG_TABS        

       DIMENSION    TAB_INFOS (*)  !Tableau des messages d'informations.
       CHARACTER    TAB_INFOS*80


       INDIC_INFOS                       =  INDIC_INFOS   +   1 
       WRITE    (TAB_INFOS (INDIC_INFOS), *)   ' '
       INDIC_INFOS                       =  INDIC_INFOS   +   1 
       WRITE    (TAB_INFOS (INDIC_INFOS), 010) F_NAME_IN,
     S                                         IO_RC,
     S                                         IO_ORDRE
       INDIC_INFOS                       =  INDIC_INFOS   +   1 
       WRITE    (TAB_INFOS (INDIC_INFOS), 011) CPT_ENREG,
     S                                         LONG_TABS  -   1


010    FORMAT ('Fin normale de fichier ',             A15,
     S         'RC : ',                               I2,
     S         ' SUR ORDRE :',                        A16              ) 
011    FORMAT ('Nb. d''enregistrements traités : ',   I4,
     S         ' pour un max. de ',                   I4               )

       
       RETURN
       END