1 : C CHAINE SOURCE JC220346 14/02/19 21:15:00 7941 2 : SUBROUTINE CHAINE 3 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 4 : C 5 : C CET OPERATEUR crée une chaîne de caractères 6 : C 7 : C En présence du modificateur 8 : C *N : justifie l'entrée à droite jusqu'à la colonne N 9 : C /N : justifie l'entrée à gauche à partie de la colonne N 10 : C 11 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 12 : C 13 : C Appelé par PILOT 14 : C 15 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 16 : C 17 : C Remarques 18 : C 19 : C ITOT : longueur de la chaîne élémentaire 20 : C 21 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 22 : C Auteur : ? 23 : C 24 : C Modifications : 25 : C PM 17/01/2006 26 : C - plus d'erreur si on impose une colonne d'écriture trop 27 : C petite : on se contente de décaler vers la droite 28 : C - ajout de commentaires 29 : C - Ne tronque plus les chaînes en entrée de + de 72 caractères 30 : C par passage de ITXTIN de 72 à LMAX caractères 31 : C - ne conserve pas indûment le dernier alignement spécifié 32 : C pour les entrées suivantes, ce qui corrige le bug survenant 33 : C si on donne encore une entrée après une spécification d'alignement 34 : C ex : 'CHAI' (bonjour*20 monde) ; 35 : C - n'interprête plus les caractères * et / isolés comme des 36 : C spécifications incomplètes de tabulation 37 : C 38 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 39 : IMPLICIT INTEGER(I-N) 40 : -INC CCOPTIO 41 : -INC SMTEXTE 42 : * taille maximale d'une chaîne de caractères 43 : PARAMETER (LMAX=512) 44 : 45 : EXTERNAL LONG 46 : LOGICAL LPO,LPO1,DEJALU 47 : REAL*8 XPO,XPO1 48 : CHARACTER*(LMAX) ITIT1 49 : CHARACTER*(LMAX) ITXTIN,ITXTI1 50 : CHARACTER*72 MFMT 51 : CHARACTER*(8) CTYP,CTYP1,CTAB,CFMT 52 : CHARACTER*4 IMO(2) 53 : CHARACTER*4 CC 54 : 55 : DATA IMO/'* ','/ '/ 56 : 57 : ITIT1 = ' ' 58 : ILON = 0 59 : * Format par défaut 60 : MFMT = '(1PE12.5)' 61 : IRETF = 9 62 : DEJALU= .FALSE. 63 : 64 : * Boucle infinie sur tous les objets en entrée 65 : 1 CONTINUE 66 : 67 : * initialisation 68 : IDECA = 0 69 : 70 : * Lecture de l'objet en cours 71 : * =========================== 72 : IF (.NOT.DEJALU) THEN 72 : CALL QUETYP(CTYP,0,IRETOU) 73 : IF(IRETOU.EQ.0) GOTO 10 74 : IF (CTYP.EQ.'ENTIER ')THEN 74 : CALL LIRENT(IPO,1,IRETOU) 75 : IF(IERR.NE.0) GOTO 1010 76 : ELSEIF (CTYP.EQ.'FLOTTANT') THEN 76 : CALL LIRREE(XPO,1,IRETOU) 77 : IF(IERR.NE.0) GOTO 1010 78 : ELSEIF (CTYP.EQ.'LOGIQUE ') THEN 78 : CALL LIRLOG(LPO,1,IRETOU) 79 : IF(IERR.NE.0) GOTO 1010 80 : ELSEIF ((CTYP.EQ.'MOT ').OR.(CTYP.EQ.'PROCEDUR')) THEN 81 : CTYP='MOT' 81 : CALL LIRCHA(ITXTIN,1,IRETOU) 82 : IF(IERR.NE.0) GOTO 1010 83 : * on lit la spécification éventuelle du format 84 : IF(ITXTIN.EQ.'FORMAT')THEN 84 : CALL LIRCHA(MFMT,1,IRETF) 85 : IF(IERR.NE.0) GOTO 1010 86 : GOTO 1 87 : ENDIF 88 : ENDIF 89 : ELSE 90 : * on gère ce cas dans toute sa généralité, même si en pratique, 91 : * on ne peut avoir qu'un MOT, valant '*' ou '/' (de longueur 1) 92 : DEJALU=.FALSE. 93 : CTYP = CTYP1 94 : IF (CTYP.EQ.'ENTIER ')THEN 95 : IPO=IPO1 96 : ELSEIF (CTYP.EQ.'FLOTTANT') THEN 97 : XPO=XPO1 98 : ELSEIF (CTYP.EQ.'LOGIQUE ') THEN 99 : LPO=LPO1 100 : ELSEIF (CTYP.EQ.'MOT ') THEN 101 : ITXTIN=ITXTI1 102 : IRETOU=IRETO1 103 : * on lit la spécification éventuelle du format 104 : IF(ITXTIN.EQ.'FORMAT')THEN 104 : CALL LIRCHA(MFMT,1,IRETF) 105 : IF(IERR.NE.0) GOTO 1010 106 : GOTO 1 107 : ENDIF 108 : ENDIF 109 : ENDIF 110 : 111 : * Lecture d'un indicateur éventuel de tabulation ('*' ou '/') 111 : CALL QUETYP(CTAB,0,IRETO) 112 : IF(CTAB.EQ.'MOT ') THEN 112 : CALL LIRMOT(IMO,2,IRET,0) 113 : IF(IRET.NE.0) THEN 114 : * y a-t-il un entier derrière ? 114 : CALL QUETYP(CTYP1,0,IRETO) 115 : IF(CTYP1.EQ.'ENTIER ') THEN 116 : * si oui, on a affaire à une spécification de tabulation 116 : CALL LIRENT(IPOS,0,IRETO) 117 : IF(IERR.NE.0) GOTO 1010 118 : IDECA = IRET 119 : ELSE 120 : * sinon on considère * ou / comme un simple caractère, sans 121 : * signification particulière 122 : * mais on a lu un mot en avance 123 : DEJALU=.TRUE. 124 : CTYP1 = 'MOT ' 125 : ipo1=ipo 126 : xpo1=xpo 127 : lpo1=lpo 128 : ITXTI1 = IMO(IRET) 129 : IRETO1 = 1 130 : ENDIF 131 : ENDIF 132 : ENDIF 133 : 134 : * Construction de la chaîne de caractère élémentaire en fonction du 135 : * type d'objet 136 : * ================================================================= 137 : 138 : IF(CTYP.EQ.'ENTIER ')THEN 139 : IDEJ=0 140 : IF(IPO.LT.0) IDEJ=1 141 : IPO=ABS(IPO) 142 : * nombre de chiffres à écrire, converti en chaîne 143 : IF(IPO.EQ.0) THEN 144 : idpl = 1 145 : ELSE 146 : xnb = log10 (real(ipo)) 147 : idpl = (int(xnb)) + 1 148 : ENDIF 149 : * format d'écriture correspondant 150 : IF (idpl.LT.10) THEN 151 : WRITE(cc,FMT='(I1)') idpl 152 : CFMT = '(I'//cc(1:1)//')' 153 : IRETI = 4 154 : ELSE 155 : * ce cas n'est pas atteint lorsqu'un entier à plus de 10 chiffres est 156 : * considéré comme un réel. 157 : CFMT = '(I10)' 158 : IRETI = 5 159 : ENDIF 160 : 161 : ITOT=IDEJ+IDPL 162 : 163 : C a-t-on un cadrage a droite ou a gauche ? 164 : IF(IDECA.EQ.1) THEN 165 : * On écrit à droite d'une colonne spécifiée 166 : IF(ILON+ITOT.GT.IPOS) THEN 167 : * on décale la suite à droite si l'on manque de place. 168 : *PM GOTO 1000 169 : IPOS=ILON+ITOT 170 : ENDIF 171 : ILON=IPOS-ITOT 172 : ELSEIF(IDECA.EQ.2) THEN 173 : * On écrit à gauche d'une colonne spécifiée 174 : IF(IPOS.LE.ILON) THEN 175 : * on décale la suite à droite si l'on manque de place. 176 : *PM GOTO 1000 177 : IPOS=ILON+1 178 : ENDIF 179 : ILON=IPOS-1 180 : ENDIF 181 : 182 : * erreur si chaîne totale trop grande 183 : IF(ILON+ITOT.GT.LMAX) GOTO 1000 184 : 185 : * ajout du signe si négatif 186 : IF(IDEJ.EQ.1) THEN 187 : ITIT1(ILON+1:ILON+1)='-' 188 : ILON=ILON+1 189 : ENDIF 190 : 191 : * sauvegarde (write interne) 192 : * write (6,*) ' format: ',ireti,cfmt(1:ireti) 193 : WRITE(ITIT1(ILON+1:ILON+IDPL),FMT=CFMT(1:IRETI)) IPO 194 : ILON=ILON+IDPL 195 : 196 : GOTO 1 197 : 198 : ELSEIF (CTYP.EQ.'FLOTTANT') THEN 199 : * conversion en chaîne suivant le format 200 : ITXTIN(1:LMAX)=' ' 201 : WRITE(ITXTIN,FMT=MFMT(1:IRETF)) XPO 202 : ITOT=LONG(ITXTIN) 203 : 204 : C a-t-on un cadrage a droite ou a gauche ? 205 : IF(IDECA.EQ.1) THEN 206 : * On écrit à droite d'une colonne spécifiée 207 : IF(ILON+ITOT.GT.IPOS) THEN 208 : * on décale la suite à droite si l'on manque de place. 209 : *PM GOTO 1000 210 : IPOS=ILON+ITOT 211 : ENDIF 212 : ILON=IPOS-ITOT 213 : ELSEIF(IDECA.EQ.2) THEN 214 : * On écrit à gauche d'une colonne spécifiée 215 : IF(IPOS.LE.ILON) THEN 216 : * on décale la suite à droite si l'on manque de place. 217 : *PM GOTO 1000 218 : IPOS=ILON+1 219 : ENDIF 220 : ILON=IPOS-1 221 : ENDIF 222 : 223 : * erreur si chaîne totale trop grande 224 : IF(ILON+ITOT.GT.LMAX) GOTO 1000 225 : 226 : * sauvegarde 227 : ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT) 228 : ILON=ILON+ITOT 229 : GOTO 1 230 : 231 : ELSEIF(CTYP.EQ.'LOGIQUE ') THEN 232 : ITOT=IRETOU 233 : 234 : C a-t-on un cadrage a droite ou a gauche ? 235 : IF(IDECA.EQ.1) THEN 236 : * On écrit à droite d'une colonne spécifiée 237 : IF(ILON+ITOT.GT.IPOS) THEN 238 : * on décale la suite à droite si l'on manque de place. 239 : *PM GOTO 1000 240 : IPOS=ILON+ITOT 241 : ENDIF 242 : ILON=IPOS-ITOT 243 : ELSEIF(IDECA.EQ.2) THEN 244 : * On écrit à gauche d'une colonne spécifiée 245 : IF(IPOS.LE.ILON) THEN 246 : * on décale la suite à droite si l'on manque de place. 247 : *PM GOTO 1000 248 : IPOS=ILON+1 249 : ENDIF 250 : ILON=IPOS-1 251 : ENDIF 252 : 253 : * erreur si chaîne totale trop grande 254 : IF(ILON+ITOT.GT.LMAX) GOTO 1000 255 : 256 : * sauvegarde 257 : IF (LPO) THEN 258 : ITIT1(ILON+1:ILON+ITOT)='VRAI' 259 : ELSE 260 : ITIT1(ILON+1:ILON+ITOT)='FAUX' 261 : ENDIF 262 : ILON=ILON+ITOT 263 : GOTO 1 264 : 265 : ELSEIF(CTYP.EQ.'MOT ') THEN 266 : ITOT=IRETOU 267 : 268 : C a-t-on un cadrage a droite ou a gauche ? 269 : IF(IDECA.EQ.1) THEN 270 : * On écrit à droite d'une colonne spécifiée 271 : IF(ILON+ITOT.GT.IPOS) THEN 272 : * on décale la suite à droite si l'on manque de place. 273 : *PM GOTO 1000 274 : IPOS=ILON+ITOT 275 : ENDIF 276 : ILON=IPOS-ITOT 277 : ELSEIF(IDECA.EQ.2) THEN 278 : * On écrit à gauche d'une colonne spécifiée 279 : IF(IPOS.LE.ILON) THEN 280 : * on décale la suite à droite si l'on manque de place. 281 : *PM GOTO 1000 282 : IPOS=ILON+1 283 : ENDIF 284 : ILON=IPOS-1 285 : ENDIF 286 : 287 : * erreur si chaîne totale trop grande 288 : IF(ILON+ITOT.GT.LMAX) GOTO 1000 289 : 290 : * sauvegarde 291 : ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT) 292 : ILON=ILON+ITOT 293 : GOTO 1 294 : ELSE 295 : GOTO 1020 296 : ENDIF 297 : 298 : * Il y a eu une erreur 299 : 1000 CONTINUE 300 : * Un titre ou un texte ne peut avoir plus de 72 caractères 301 : *PM (ce qui est faux pour le texte => nouvelle erreur à écrire dans GIBI.ERREUR) 301 : CALL ERREUR(425) 302 : RETURN 303 : 304 : 1010 CONTINUE 305 : * Erreur anormale.contactez votre support 305 : CALL ERREUR(5) 306 : RETURN 307 : 308 : 1020 CONTINUE 309 : * Données incompatibles 309 : CALL ERREUR(21) 310 : RETURN 311 : 312 : 313 : * On a tout lu sans erreur 314 : * On écrit la chaîne en sortie si elle n'est pas vide 315 : 10 CONTINUE 316 : IF(ILON.EQ.0) GOTO 1000 316 : CALL ECRCHA(ITIT1(1:ILON)) 317 : RETURN 318 : 319 : END 320 : 321 : 322 : 323 : 324 :
© Cast3M 2003 - All rights reserved.
Disclaimer