Télécharger chaine.eso

Retour à la liste

C CHAINE    SOURCE    JC220346  14/02/19    21:15:00     7941
      SUBROUTINE CHAINE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     CET OPERATEUR crée une chaîne de caractères
C
C     En présence du modificateur
C       *N : justifie l'entrée à droite jusqu'à la colonne N
C       /N : justifie l'entrée à gauche à partie de la colonne N
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     Appelé par PILOT
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     Remarques
C
C       ITOT : longueur de la chaîne élémentaire
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Auteur : ?
C
C     Modifications :
C       PM 17/01/2006
C         - plus d'erreur si on impose une colonne d'écriture trop
C           petite : on se contente de décaler vers la droite
C         - ajout de commentaires
C         - Ne tronque plus les chaînes en entrée de + de 72 caractères
C           par passage de ITXTIN de 72 à LMAX caractères
C         - ne conserve pas indûment le dernier alignement spécifié
C           pour les entrées suivantes, ce qui corrige le bug survenant
C           si on donne encore une entrée après une spécification d'alignement
C           ex : 'CHAI' (bonjour*20 monde) ;
C         - n'interprête plus les caractères * et / isolés comme des
C           spécifications incomplètes de tabulation
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC SMTEXTE
*     taille maximale d'une chaîne de caractères
      PARAMETER       (LMAX=512)
 
      EXTERNAL         LONG
      LOGICAL          LPO,LPO1,DEJALU
      REAL*8           XPO,XPO1
      CHARACTER*(LMAX) ITIT1
      CHARACTER*(LMAX) ITXTIN,ITXTI1
      CHARACTER*72     MFMT
      CHARACTER*(8)    CTYP,CTYP1,CTAB,CFMT
      CHARACTER*4      IMO(2)
      CHARACTER*4      CC
 
      DATA             IMO/'*   ','/   '/
 
      ITIT1 = ' '
      ILON  = 0
*     Format par défaut
      MFMT  = '(1PE12.5)'
      IRETF = 9
      DEJALU= .FALSE.
 
*     Boucle infinie sur tous les objets en entrée
 1    CONTINUE
 
*     initialisation
      IDECA = 0
 
*     Lecture de l'objet en cours
*     ===========================
      IF (.NOT.DEJALU) THEN
         CALL QUETYP(CTYP,0,IRETOU)
         IF(IRETOU.EQ.0) GOTO 10
         IF     (CTYP.EQ.'ENTIER  ')THEN
            CALL LIRENT(IPO,1,IRETOU)
            IF(IERR.NE.0) GOTO 1010
         ELSEIF (CTYP.EQ.'FLOTTANT')  THEN
            CALL LIRREE(XPO,1,IRETOU)
            IF(IERR.NE.0) GOTO 1010
         ELSEIF (CTYP.EQ.'LOGIQUE ')  THEN
            CALL LIRLOG(LPO,1,IRETOU)
            IF(IERR.NE.0) GOTO 1010
         ELSEIF ((CTYP.EQ.'MOT     ').OR.(CTYP.EQ.'PROCEDUR')) THEN
            CTYP='MOT'
            CALL LIRCHA(ITXTIN,1,IRETOU)
            IF(IERR.NE.0) GOTO 1010
*           on lit la spécification éventuelle du format
            IF(ITXTIN.EQ.'FORMAT')THEN
               CALL LIRCHA(MFMT,1,IRETF)
               IF(IERR.NE.0) GOTO 1010
               GOTO 1
            ENDIF
         ENDIF
      ELSE
*        on gère ce cas dans toute sa généralité, même si en pratique,
*        on ne peut avoir qu'un MOT, valant '*' ou '/' (de longueur 1)
         DEJALU=.FALSE.
         CTYP  = CTYP1
         IF     (CTYP.EQ.'ENTIER  ')THEN
            IPO=IPO1
         ELSEIF (CTYP.EQ.'FLOTTANT')  THEN
            XPO=XPO1
         ELSEIF (CTYP.EQ.'LOGIQUE ')  THEN
            LPO=LPO1
         ELSEIF (CTYP.EQ.'MOT     ') THEN
            ITXTIN=ITXTI1
            IRETOU=IRETO1
*           on lit la spécification éventuelle du format
            IF(ITXTIN.EQ.'FORMAT')THEN
               CALL LIRCHA(MFMT,1,IRETF)
               IF(IERR.NE.0) GOTO 1010
               GOTO 1
            ENDIF
         ENDIF
      ENDIF
 
*     Lecture d'un indicateur éventuel de tabulation ('*' ou '/')
      CALL QUETYP(CTAB,0,IRETO)
      IF(CTAB.EQ.'MOT     ') THEN
         CALL LIRMOT(IMO,2,IRET,0)
         IF(IRET.NE.0) THEN
*           y a-t-il un entier derrière ?
            CALL QUETYP(CTYP1,0,IRETO)
            IF(CTYP1.EQ.'ENTIER  ') THEN
*              si oui, on a affaire à une spécification de tabulation
               CALL LIRENT(IPOS,0,IRETO)
               IF(IERR.NE.0) GOTO 1010
               IDECA = IRET
            ELSE
*              sinon on considère * ou / comme un simple caractère, sans
*              signification particulière
*              mais on a lu un mot en avance
               DEJALU=.TRUE.
               CTYP1 = 'MOT     '
               ipo1=ipo
               xpo1=xpo
               lpo1=lpo
               ITXTI1 = IMO(IRET)
               IRETO1 = 1
            ENDIF
         ENDIF
      ENDIF
 
*     Construction de la chaîne de caractère élémentaire en fonction du
*     type d'objet
*     =================================================================
 
      IF(CTYP.EQ.'ENTIER  ')THEN
         IDEJ=0
         IF(IPO.LT.0) IDEJ=1
         IPO=ABS(IPO)
*        nombre de chiffres à écrire, converti en chaîne
         IF(IPO.EQ.0) THEN
            idpl  = 1
         ELSE
            xnb   = log10 (real(ipo))
            idpl  = (int(xnb)) + 1
         ENDIF
*        format d'écriture correspondant
         IF (idpl.LT.10)   THEN
            WRITE(cc,FMT='(I1)') idpl
            CFMT  = '(I'//cc(1:1)//')'
            IRETI = 4
         ELSE
*           ce cas n'est pas atteint lorsqu'un entier à plus de 10 chiffres est
*           considéré comme un réel.
            CFMT  = '(I10)'
            IRETI = 5
         ENDIF
 
         ITOT=IDEJ+IDPL
 
C        a-t-on un cadrage a droite ou a gauche ?
         IF(IDECA.EQ.1) THEN
*           On écrit à droite d'une colonne spécifiée
            IF(ILON+ITOT.GT.IPOS) THEN
*              on décale la suite à droite si l'on manque de place.
*PM            GOTO 1000
               IPOS=ILON+ITOT
            ENDIF
            ILON=IPOS-ITOT
         ELSEIF(IDECA.EQ.2) THEN
*           On écrit à gauche d'une colonne spécifiée
            IF(IPOS.LE.ILON) THEN
*              on décale la suite à droite si l'on manque de place.
*PM            GOTO 1000
               IPOS=ILON+1
            ENDIF
            ILON=IPOS-1
         ENDIF
 
*        erreur si chaîne totale trop grande
         IF(ILON+ITOT.GT.LMAX) GOTO 1000
 
*        ajout du signe si négatif
         IF(IDEJ.EQ.1)  THEN
            ITIT1(ILON+1:ILON+1)='-'
            ILON=ILON+1
         ENDIF
 
*        sauvegarde (write interne)
*        write (6,*) ' format: ',ireti,cfmt(1:ireti)
         WRITE(ITIT1(ILON+1:ILON+IDPL),FMT=CFMT(1:IRETI)) IPO
         ILON=ILON+IDPL
 
         GOTO 1
 
      ELSEIF (CTYP.EQ.'FLOTTANT')  THEN
*        conversion en chaîne suivant le format
         ITXTIN(1:LMAX)=' '
         WRITE(ITXTIN,FMT=MFMT(1:IRETF)) XPO
         ITOT=LONG(ITXTIN)
 
C        a-t-on un cadrage a droite ou a gauche ?
         IF(IDECA.EQ.1) THEN
*           On écrit à droite d'une colonne spécifiée
            IF(ILON+ITOT.GT.IPOS) THEN
*              on décale la suite à droite si l'on manque de place.
*PM            GOTO 1000
               IPOS=ILON+ITOT
            ENDIF
            ILON=IPOS-ITOT
         ELSEIF(IDECA.EQ.2) THEN
*           On écrit à gauche d'une colonne spécifiée
            IF(IPOS.LE.ILON) THEN
*              on décale la suite à droite si l'on manque de place.
*PM            GOTO 1000
               IPOS=ILON+1
            ENDIF
            ILON=IPOS-1
         ENDIF
 
*        erreur si chaîne totale trop grande
         IF(ILON+ITOT.GT.LMAX) GOTO 1000
 
*        sauvegarde
         ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT)
         ILON=ILON+ITOT
         GOTO 1
 
      ELSEIF(CTYP.EQ.'LOGIQUE ') THEN
         ITOT=IRETOU
 
C        a-t-on un cadrage a droite ou a gauche ?
         IF(IDECA.EQ.1) THEN
*           On écrit à droite d'une colonne spécifiée
            IF(ILON+ITOT.GT.IPOS) THEN
*              on décale la suite à droite si l'on manque de place.
*PM            GOTO 1000
               IPOS=ILON+ITOT
            ENDIF
            ILON=IPOS-ITOT
         ELSEIF(IDECA.EQ.2) THEN
*           On écrit à gauche d'une colonne spécifiée
            IF(IPOS.LE.ILON) THEN
*              on décale la suite à droite si l'on manque de place.
*PM            GOTO 1000
               IPOS=ILON+1
            ENDIF
            ILON=IPOS-1
         ENDIF
 
*        erreur si chaîne totale trop grande
         IF(ILON+ITOT.GT.LMAX) GOTO 1000
 
*        sauvegarde
         IF (LPO) THEN
            ITIT1(ILON+1:ILON+ITOT)='VRAI'
         ELSE
            ITIT1(ILON+1:ILON+ITOT)='FAUX'
         ENDIF
         ILON=ILON+ITOT
         GOTO 1
 
      ELSEIF(CTYP.EQ.'MOT     ') THEN
         ITOT=IRETOU
 
C        a-t-on un cadrage a droite ou a gauche ?
         IF(IDECA.EQ.1) THEN
*           On écrit à droite d'une colonne spécifiée
            IF(ILON+ITOT.GT.IPOS) THEN
*              on décale la suite à droite si l'on manque de place.
*PM            GOTO 1000
               IPOS=ILON+ITOT
            ENDIF
            ILON=IPOS-ITOT
         ELSEIF(IDECA.EQ.2) THEN
*           On écrit à gauche d'une colonne spécifiée
            IF(IPOS.LE.ILON) THEN
*              on décale la suite à droite si l'on manque de place.
*PM            GOTO 1000
               IPOS=ILON+1
            ENDIF
            ILON=IPOS-1
         ENDIF
 
*        erreur si chaîne totale trop grande
         IF(ILON+ITOT.GT.LMAX) GOTO 1000
 
*        sauvegarde
         ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT)
         ILON=ILON+ITOT
         GOTO 1
      ELSE
         GOTO 1020
      ENDIF
 
*     Il y a eu une erreur
 1000 CONTINUE
*     Un titre ou un texte ne peut avoir plus de 72 caractères
*PM   (ce qui est faux pour le texte => nouvelle erreur à écrire dans GIBI.ERREUR)
      CALL ERREUR(425)
      RETURN
 
 1010 CONTINUE
*     Erreur anormale.contactez votre support
      CALL ERREUR(5)
      RETURN
 
 1020 CONTINUE
*     Données incompatibles
      CALL ERREUR(21)
      RETURN
 
 
*     On a tout lu sans erreur
*     On écrit la chaîne en sortie si elle n'est pas vide
 10   CONTINUE
      IF(ILON.EQ.0) GOTO 1000
      CALL ECRCHA(ITIT1(1:ILON))
      RETURN
 
      END
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales