Bonsoir,
Je te joins un programme Fortran qui utilise pas mal de tableaux. Il n'est pas nécessaire de comprendre sa finalité (certaines séquences sont d'ailleurs cohérentes mais non finalisées) , il suffit de "suivre" la description et l'utilisation d'un ou plusieurs tableaux.
En espérant que cela te sera utile .............. Il s'agit de ma façon d'utiliser les tableaux...
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) http://perso.enstimac.fr/~gaborit/lang/CoursDeFortran/
C(WE2) http://docs.sun.com/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
Cordialement.
Cchristian.
Compilateur fortran
