[updated 8.Sep.2008]
Librairie lecdire > Fichier lcdonn.f |
SUBROUTINE LCDONN
Auteurs : D.Martin & O.DeBayser (Avril 1988)
Derniere modification : D.Martin (30 Aout 2000)
Version # 1.0.6
Sous-programme principal de LeCture des valeurs des DONNees
Mots-cles de la directive DONNEE --
+ DONNEE [ DE NOM ] &C
< ENTIERE / REELLE / COMPLEXE / CARACTERE >
< CONSTANTE &R1 [ + &R2 ]
/ TABLEAU [DE NIVEAU] &I
[ DE LONGUEUR &I = + < &I / &R1 [ &R2 ] > ]
/ FONCTION
[Donnee ASSOCIEE DE NOM &C [ < REELLE / COMPLEXE > ]
< CONSTANTE [ &R1 [ &R2] ]
/ TABLEAU [DE NIVEAU] &I
[ DE LONGUEUR &I = + < &I / &R1 [ &R2 ] > ]
>
>
FIN
INCLUDE 'CONTEX'
INCLUDE 'ALLOC'
CHARACTER DONINT*10,TYPINT*10 !utilite
INTEGER INTDON,INTTYP,KELCHN,KLCSTE !utilite
INTEGER NFIX,IRE,NER,NCAR,ILU,IOP,LUDONN,NIVIMP
& ,LUASSO,MCDONN,MCMDON,LGEDON,NBDONN,INCDON,NCHDON
& ,LGDONN,LGMDON,NWHDON,ITYDON,ITYPDO,NUCSTE
& ,NUDOAV,ITYDAV,ITYPAV,LONTAB,LONTAV,ITYDOV,NUCSTV
& ,ITYPDV,NBARTB,NIVTAB
& ,NUDONN,MCCTAB,LGA,MCL,LGU,NBCHAR,I,NCDONN
REAL REALPT
DOUBLE PRECISION FLOT
CHARACTER TEXTE*80,ERCODE*120,NMDONN*20,NOMTAB*6
& ,LUTYDO,LUCARA,READRE
COMMON/REDCO1/ FLOT,NFIX,IRE,NER,NCAR,ILU,IOP(5)
COMMON/REDCOM/ TEXTE
COMMON/FORMAH/ ERCODE
CALL PRFXMJ (1,'*Lcdonn*')
NIVIMP=0
READRE='Y'
Lecture des mots Impression, Donnee ou Fin
LUDONN=0
CALL REDLE
10 IF (LUDONN.GT.0.AND.IRE.EQ.4) GOTO 20
IF (IRE.NE.3) CALL REDERR (13,' ')
IF (NIVIMP.GT.0.AND.IMPMES.GT.0)
& WRITE (IMPMES,10000) '*Lcdonn*',TEXTE(1:NCAR)
IF (TEXTE(1:10).EQ.'IMPRESSION'.OR.TEXTE(1:5).EQ.'PRINT') THEN
NIVIMP=1
CALL REDLE
IF (IRE.EQ.3.AND.(TEXTE(1:NCAR).EQ.'NIVEAU'
& .OR.TEXTE(1:NCAR).EQ.'LEVEL')) CALL REDLE
IF (IRE.EQ.1) THEN
NIVIMP=NFIX
CALL REDLE
ENDIF
IF (IMPMES.LE.0) NIVIMP=0
IF (NIVIMP.GT.0) WRITE (IMPSDR,10011) '*Lcdonn*'
GOTO 10
ELSEIF (TEXTE(1:3).EQ.'FIN'.OR.TEXTE(1:3).EQ.'END') THEN
GOTO 90000
ELSEIF (TEXTE(1:6).EQ.'DONNEE'.OR.TEXTE(1:4).EQ.'DATA') THEN
LUDONN=LUDONN+1
CALL REDLE
ENDIF
LUASSO=0
19 IF (IRE.EQ.3.AND.(TEXTE(1:NCAR).EQ.'NOM'
& .OR.TEXTE(1:4).EQ.'NAME')) CALL REDLE
IF (IRE.NE.4) CALL REDERR (14,' ')
On a lu un texte (nom de donnee expected)
20 IF (NIVIMP.GT.0) WRITE (IMPMES,10004)'*Lcdonn*',NCAR,TEXTE(1:NCAR)
IF (READRE.EQ.'Y')
& CALL TBAR2 (ERCODE,'$DONNE',1,MCDONN,'#OMDON',1,MCMDON)
READRE='N'
CALL SDEXDB (IST(MCDONN),LGEDON,NBDONN,INCDON,NCHDON) !utilite
NUDONN=KELCHN (TEXTE(1:NCAR),AST(MCMDON),NBDONN,NCHDON)
NMDONN=TEXTE(1:NCAR)
NCDONN=NCAR
IF (IRE.EQ.4) NOMTAB=TEXTE(1:NCAR)
LUTYDO='N'
IF (NUDONN.LE.0) THEN
Cas d'une nouvelle donnee
CALL TBRR2 (ERCODE,'$DONNE',1,LGDONN,'#OMDON',1,LGMDON)
Agrandissement eventuel de la structure $DONNE
CALL SDAJST ('$DONNE',1,LGDONN,IST(MCDONN),INCDON,NBDONN,5) !sdexplo
Agrandissement eventuel du tableau des noms de donnees
NWHDON=MAX (NCHDON,NCAR)
CALL SDAJST ('#OMDON',1,LGMDON,0,NWHDON,NBDONN,5) !sdexplo
CALL TBAR2 (ERCODE,'$DONNE',1,MCDONN,'#OMDON',1,MCMDON)
Introduction du nouveau nom de donnee
CALL RIPCHN (AST(MCMDON),NBDONN,NCHDON,TEXTE(1:NCAR)) !utilite
NUDONN=NBDONN
ITYDON=-1
NUCSTE=0
ITYPDO=-1
CALL SDMKDB (IST(MCDONN),LGEDON,NBDONN,INCDON,NCHDON) !utilite
ELSE
La donnee existe deja : recherche de ses caracteristiques
CALL SDEXCO (NUDONN,IST(MCDONN),ITYDOV,NUCSTV,ITYPDV) !utilite
ITYDON=ITYDOV
NUCSTE=NUCSTV
ITYPDO=ITYPDV
LUTYDO='Y'
ENDIF
Lecture des attributs de la donnee
CALL REDLE
CALL LCCADO (ITYDON,NUCSTE,ITYPDO,LUCARA,NIVIMP,IMPMES) !lecdire
IF (LUTYDO.EQ.'Y') THEN
IF (LUCARA.EQ.'Y') THEN
IF (ITYDON.NE.ITYDOV) GOTO 99991
IF (ITYPDO.NE.ITYPDV) GOTO 99992
IF (ITYPDV.EQ.INTDON ('TABLEAU')
& .AND.NUCSTE.NE.NUCSTV) CALL ERDONN (18,NMDONN)
ENDIF
ENDIF
CALL SDMKCO (NUDONN,IST(MCDONN),ITYDON,NUCSTE,ITYPDO) !utilite
IF (LUASSO.GT.0) THEN
Cas d'une donnee associee a une fonction
CALL SDMKCO (NUDOAV,IST(MCDONN),ITYDAV,NUDONN,ITYPAV) !utilite
LUASSO=0
ENDIF
IF (ITYDON.EQ.INTDON ('FONCTION')) THEN !utilite
Cas d'une donnee de type FONCTION
Lecture du nom d'une eventuelle donnee associee
IF (IRE.NE.3) GOTO 10
IF (NIVIMP.GT.0) WRITE (IMPMES,10003) '*Lcdonn*',TEXTE(1:NCAR)
IF (TEXTE(1:6).EQ.'DONNEE'.OR.TEXTE(1:5).EQ.'ASSOC') CALL REDLE
IF (IRE.NE.3) GOTO 10
IF (TEXTE(1:5).EQ.'ASSOC'.OR.TEXTE(1:3).EQ.'DAT') THEN
NUDOAV=NUDONN
ITYDAV=ITYDON
ITYPAV=ITYPDO
LUASSO=1
CALL REDLE
GOTO 19
ENDIF
ELSEIF (ITYDON.EQ.INTDON ('TABLEAU')) THEN
NIVTAB=NUCSTE
IF (IRE.EQ.3.AND.(TEXTE(1:NCAR).EQ.'LONGUEUR'
& .OR.TEXTE(1:NCAR).EQ.'LENGTH')) THEN
Lecture de la longueur et du contenu du tableau
IF (NIVIMP.GT.0)
& WRITE (IMPMES,10003) '*Lcdonn*',TEXTE(1:NCAR)
CALL REDLE
IF (IRE.NE.1) CALL REDERR (11,' ')
IF (NIVIMP.GT.0) WRITE (IMPMES,10001) '*Lcdonn*',NFIX
LONTAB=NFIX
ERCODE='!'
CALL TBRR1 (ERCODE,NOMTAB,NIVTAB,LONTAV)
IF (ERCODE(1:1).EQ.' ') THEN
CALL TBTYPE (NOMTAB,NIVTAB,ITYPDV)
IF (LONTAB.GT.LONTAV) GOTO 99994
IF (ITYPDO.NE.ITYPDV) GOTO 99995
ELSE
CALL TBCREE (NOMTAB,NIVTAB,ITYPDO,LONTAB,'c')
ENDIF
CALL TBAR1 (ERCODE,NOMTAB,NIVTAB,MCCTAB)
NBARTB=0
IF (ITYPDO.EQ.INTTYP ('ENTIER')) THEN !utilite
101 CALL REDLE
IF (IRE.EQ.1) THEN
IF (NBARTB.GE.LONTAB) GOTO 99996
NBARTB=NBARTB+1
IST(MCCTAB)=NFIX
MCCTAB=MCCTAB+1
GOTO 101
ENDIF
ELSEIF (ITYPDO.EQ.INTTYP ('REEL')) THEN !utilite
102 CALL REDLE
IF (IRE.EQ.2.OR.IRE.EQ.1) THEN
IF (NBARTB.GE.LONTAB) GOTO 99996
NBARTB=NBARTB+1
RST(MCCTAB)=REAL(FLOT)
MCCTAB=MCCTAB+1
GOTO 102
ENDIF
ELSEIF (ITYPDO.EQ.INTTYP ('COMPLEXE')) THEN
104 CALL REDLE
IF (IRE.EQ.2.OR.IRE.EQ.1) THEN
IF (NBARTB.GE.LONTAB) GOTO 99996
NBARTB=NBARTB+1
REALPT=REAL(FLOT)
CALL REDLE
IF (IRE.NE.2.AND.IRE.NE.1) CALL REDERR (12,' ')
CST (MCCTAB)=CMPLX(REALPT,REAL(FLOT))
MCCTAB=MCCTAB+1
GOTO 104
ENDIF
ELSEIF (ITYPDO.GE.INTTYP ('CARACTERE')) THEN
108 CALL REDLE
IF (IRE.EQ.4) THEN
IF (NBARTB.GE.LONTAB) GOTO 10
IF (NCAR.GT.ITYPDO-10) GOTO 99997
NBARTB=NBARTB+1
DO 109 I=1,NCAR
AST(MCCTAB+I-1)=TEXTE(I:I)
109 CONTINUE
DO 110 I=NCAR,ITYPDO-10
AST(MCCTAB+I)=' '
110 CONTINUE
MCCTAB=MCCTAB+ITYPDO-10
GOTO 108
ENDIF
ENDIF
IF (NBARTB.LT.LONTAB)
& CALL WARNNG ('Tableau '//NOMTAB//' incompletement rempli.')!utilite
CALL TBSAVE (NOMTAB,NIVTAB)
READRE='Y'
ENDIF
ELSEIF (ITYDON.EQ.INTDON ('CONSTANTE')) THEN !utilite
IF (IRE.EQ.4) THEN
IF (LUTYDO.EQ.'N') NUCSTE=KLCSTE (TYPINT (ITYPDO)) !sdexplo
CALL TBRR1 (ERCODE,'$ACSTE',1,LGA)
CALL TBAR1 (ERCODE,'$LGCSA',1,MCL)
IF (NCAR.GT.IST(MCL+NUCSTE)) THEN
NBCHAR=NCAR-IST(MCL+NUCSTE)
LGU=0
DO 1 I=1,IST(MCL)
LGU=LGU+IST(MCL+I)
1 CONTINUE
IF (LGA.LT.LGU+2*NCAR) THEN
CALL TBAJST ('$ACSTE',1,LGU+NCAR)
ENDIF
ENDIF
ENDIF
Lecture de la valeur d'une donnee constante
CALL LCCSTE (NUCSTE,ITYPDO,NIVIMP,IMPMES) !lecdire
CALL TBAR2 (ERCODE,'$DONNE',1,MCDONN,'#OMDON',1,MCMDON)
READRE='N'
CALL SDMKCO (NUDONN,IST(MCDONN),ITYDON,NUCSTE,ITYPDO) !utilite
ENDIF
GOTO 10
90000 IF (IMPSDR.GT.0.AND.NIVIMP.GT.1) THEN
CALL PRDONN (IMPSDR) !prsd
CALL PRDCST (' ',IMPSDR) !prsd
CALL PRDTAB (' ',IMPSDR) !prsd
WRITE (IMPSDR,10010) '*Lcdonn*'
ENDIF
CALL PRFXMJ (-1,'*Lcdonn*')
RETURN
10011 FORMAT(/T2,A8,' ',88('-'))
10000 FORMAT(T2,A8,' ->Debut de la Directive : ',A)
10001 FORMAT(T2,A8,T56,' , suivi de nombre : ',I12)
10002 FORMAT(T2,A8,T56,' , suivi de nombre : ',E12.4)
10003 FORMAT(T2,A8,T56,' , suivi du mot : ',A)
10004 FORMAT(T2,A8,T56,' , suivi de la chaine (*',I2,') : ',A)
10010 FORMAT(/T2,A8,' ',59('-'),' Fin de lecture des donnees ',('-'),/)
99991 TEXTE=NMDONN
CALL BAISE ('Redefinition du type de representation ('
&//DONINT(ITYDOV)//') de la donnee '
&//TEXTE(1:NCDONN)//' interdite.')
99992 TEXTE=NMDONN
CALL BAISE ('Redefinition du type de declaration ('
&//TYPINT(ITYPDV)//') de la donnee '
&//TEXTE(1:NCDONN)//' interdite.')
99994 CALL ENCLER (LONTAV,ERCODE(1:6))
CALL BAISE ('Le tableau '//NOMTAB//' existe avec une longueur ('
&//ERCODE(1:6)//') insuffisante.')
99995 CALL BAISE ('Le tableau '//NOMTAB//' existe avec un type ('
&//TYPINT(ITYPDV)//') different.')
99996 CALL ENCLER (LONTAB,ERCODE(1:6))
CALL BAISE ('Nombre d''articles depasse pour le tableau '
&//NOMTAB//' de longueur '//ERCODE(1:6)//'.')
99997 CALL ENCLER (NBARTB,ERCODE(1:2))
CALL ENCLER (NCAR ,ERCODE(3:4))
I=0
IF (ITYPDO.GE.20) I=1
CALL ENCLER (ITYPDO-10,ERCODE(5:5+I))
CALL BAISE ('Le tableau '//NOMTAB//' est declare CARACTERE*'
&//ERCODE(5:5+I)//' et son coefficient #'//ERCODE(1:2)
&//' est une chaine de caracteres de longueur '
&//ERCODE(3:4)//'.')
END !Lcdonn
lcdonn est appelé dans (22 procédures)