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 IF(IRETOU.EQ.0) GOTO 10 IF (CTYP.EQ.'ENTIER ')THEN IF(IERR.NE.0) GOTO 1010 ELSEIF (CTYP.EQ.'FLOTTANT') THEN IF(IERR.NE.0) GOTO 1010 ELSEIF (CTYP.EQ.'LOGIQUE ') THEN IF(IERR.NE.0) GOTO 1010 ELSEIF ((CTYP.EQ.'MOT ').OR.(CTYP.EQ.'PROCEDUR')) THEN CTYP='MOT' IF(IERR.NE.0) GOTO 1010 * on lit la spécification éventuelle du format IF(ITXTIN.EQ.'FORMAT')THEN 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 IF(IERR.NE.0) GOTO 1010 GOTO 1 ENDIF ENDIF ENDIF * Lecture d'un indicateur éventuel de tabulation ('*' ou '/') IF(CTAB.EQ.'MOT ') THEN IF(IRET.NE.0) THEN * y a-t-il un entier derrière ? IF(CTYP1.EQ.'ENTIER ') THEN * si oui, on a affaire à une spécification de tabulation 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 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) RETURN 1010 CONTINUE * Erreur anormale.contactez votre support RETURN 1020 CONTINUE * Données incompatibles 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 RETURN END
© Cast3M 2003 - Tous droits réservés.
Mentions légales