1 : C CHAIPS SOURCE BP208322 12/11/06 21:15:00 7561 2 : C 3 : SUBROUTINE CHAIPS (TITRE,LTITRE) 4 : *============================================================= 5 : * 6 : * MANIP POUR L INTERPRETATION DES CHAINES (TITRE LABEL LEGENDES ...) 7 : * LORS DE L ECRITURE D UN FICHIER POSTSCRIPT 8 : * 9 : *============================================================= 10 : IMPLICIT INTEGER(I-N) 11 : IMPLICIT REAL*8 (A-H,O-Y) 12 : 13 : -INC CCOPTIO 14 : -INC CCTRACE 15 : 16 : CHARACTER*80 TITRE 17 : CHARACTER*128 CHAINE 18 : PARAMETER(IUPS=24) 19 : 20 : cbp: on definit l angle du texte : ANGLE 21 : c + une position centrée (ou pas) : IALIGN=2 (ou 0 ou 1) 22 : 23 : *============================================================= 24 : * ROTATION DE LA CHAINE PAR RAPPORT AU POINT X 25 : *============================================================= 26 : c rotation si demandée 27 : ANGLE=dble(INFOTR(1)) 28 : if(ANGLE.ne.0.d0)then 29 : write (IUPS,fmt='(F4.1,'' rotate '')') ANGLE 30 : endif 31 : 32 : *============================================================= 33 : * CENTREMENT DE LA CHAINE PAR RAPPORT AU POINT X 34 : *============================================================= 35 : c seulement si centrement demandé, sinon inutile 36 : IALIGN=INFOTR(2) 37 : IF(IALIGN.EQ.2) THEN 38 : c on commence par predimensionner la chaine qui va etre ecrite 39 : iposch=1 40 : i=0 41 : c---> Boucle sur les caracteres 42 : do 7 i7=1,LTITRE 43 : i=i+1 44 : if(i.gt.LTITRE) goto 8 45 : c -si on NE lit PAS un caractere définissant un contexte particulier 46 : if((titre(i:i+1).eq.'_{').or.(titre(i:i+1).eq.'^{')) then 47 : i=i+1 48 : elseif((titre(i:i).ne.char(92)) 49 : # .and.(titre(i:i).ne.'{').and.(titre(i:i).ne.'}') 50 : # .and.(titre(i:i).ne.'(').and.(titre(i:i).ne.')')) then 51 : c alors on l'ajoute a la chaine 52 : iposch=iposch+1 53 : CHAINE(iposch:iposch)=titre(i:i) 54 : endif 55 : 7 continue 56 : 8 continue 57 : c Centrement 58 : CHAINE(1:1)='(' 59 : CHAINE(iposch+1:iposch+1)=')' 60 : write(IUPS,907) CHAINE(1:iposch+1) 61 : ENDIF 62 : 63 : *============================================================= 64 : * INITIALISATIONS 65 : *============================================================= 66 : c info sur la police utilisee 67 : iposiz = (IOPOTR+2)/3 68 : ipopol = IOPOTR - (3*(iposiz-1)) 69 : iposiz = (iposiz*2) + 10 70 : isymb = 0 71 : c precedente police utilise (standard par defaut) 72 : iprec = 10 73 : c eventuel decalage (ydec1=a apporter ; ydec=cumul=position) 74 : xdec = 0. 75 : ydec = 0. 76 : ydec1= 0. 77 : idec = 0 78 : c indice de positionnement dans les chaine de caracteres 79 : iplac =1 80 : iposch=1 81 : c ecriture ? 82 : iecrit=0 83 : 84 : *============================================================= 85 : * TRAVAIL CARACTERE PAR CARACTERE 86 : *============================================================= 87 : i=0 88 : c---> Boucle sur les caracteres 89 : do 77777 i777=1,LTITRE 90 : 91 : c --- Lecture du i^eme caractere (s il est defini) --- 92 : i=i+1 93 : if(i.gt.LTITRE) goto 77777 94 : 95 : c -si on lit un caractere définissant un contexte particulier 96 : if((titre(i:i+1).eq.'_{').or.(titre(i:i+1).eq.'^{') 97 : # .or.(titre(i:i).eq.'}').or.(titre(i:i).eq.char(92))) then 98 : iecrit=1 99 : c -sinon on le met dans CHAINE 100 : else 101 : c on met des \ avant des eventuelles parentheses ... 102 : if(titre(i:i).eq.'('.or.titre(i:i).eq.')') then 103 : iposch=iposch+2 104 : c ... ATTENTION !!! Sur IBM (AIX) il considère le \ comme un "escape", 105 : c on est donc obligé d'en mettre deux, il faut espérer que ça ne va 106 : c pas foirer sur d'autres machines. J'aurais pu mettre char(92) au 107 : c lieu de ça, mais ça ne marcherait qu'en ASCII (il y a peut etre 108 : c encore des gens qui bossent sur des mainframes) (M'Bulik) ... 109 : * CHAINE(iposch-1:iposch-1)='\\' 110 : CHAINE(iposch-1:iposch-1)=char(92) 111 : CHAINE(iposch :iposch )=TITRE(i:i) 112 : else 113 : iposch=iposch+1 114 : CHAINE(iposch:iposch)=TITRE(i:i) 115 : endif 116 : c tant qu'on est pas arrivé au bout, on enregistre sans écrire 117 : c if(i.lt.LTITRE) then 118 : c iecrit=0 119 : c else 120 : c iecrit=1 121 : c endif 122 : if(i.eq.LTITRE) iecrit=1 123 : endif 124 : c write(6,*)'CHAINE=',CHAINE(2:iposch),' ipo,ecri',iposch,iecrit 125 : 126 : c --- Ecriture de la CHAINE dans le postscript --- 127 : c rem: si le 1er caractere est spécial (_{} par ex), alors on 128 : c peut ecrire une chaine vide (iposch=1) 129 : if(iecrit.eq.1.and.iposch.ge.1) then 130 : c -Ecriture de la police 131 : if(isymb.eq.0) then 132 : if(ydec.eq.0) then 133 : if(iprec.ne.10) then 134 : if(ipopol.eq.1) write(IUPS,1847) iposiz 135 : if(ipopol.eq.2) write(IUPS,1848) iposiz 136 : if(ipopol.eq.3) write(IUPS,1849) iposiz 137 : endif 138 : iprec = 10 139 : else 140 : if(iprec.ne.7) then 141 : if(ipopol.eq.1) write(IUPS,2847) (0.71*iposiz) 142 : if(ipopol.eq.2) write(IUPS,2848) (0.71*iposiz) 143 : if(ipopol.eq.3) write(IUPS,2849) (0.71*iposiz) 144 : endif 145 : iprec = 7 146 : endif 147 : endif 148 : c -Positionnement 149 : if(iplac.gt.1) then 150 : write(IUPS,977) xdec,ydec1,'rmoveto H1' 151 : xdec = 0. 152 : ydec1 = 0. 153 : c mise a 0 de idec si on écrit sur l'axe d'origine 154 : if(ydec.eq.0..and.iposch.gt.1) idec=0 155 : endif 156 : c -Ecriture de la chaine ( TITRE(1:iposch) ) SX 157 : iplac=iplac+1 158 : CHAINE(1:1)='(' 159 : CHAINE(iposch+1:iposch+4)=') SX' 160 : CHAINE(iposch+5:len(CHAINE))=' ' 161 : write (iups,955) CHAINE(1:iposch+4) 162 : 955 format (a) 163 : c -On recommence le remplissage de CHAINE avec les caracteres suivants 164 : iecrit=0 165 : iposch=1 166 : isymb =0 167 : endif 168 : 169 : c --- Traitement des caracteres définissant un contexte particulier --- 170 : 171 : c --- Traitement des caracteres définissant une police (Symbole) --- 172 : c -un \ fourni par l utilisateur indique qu il veut un symbole grec 173 : if((titre(i:i).eq.char(92)).and.(i+1.le.LTITRE)) then 174 : c il faut changer la font + imposer d'écrire le caractere i+1 175 : c write(6,*) 'on a trouvé un antislash \ ' 176 : isymb =1 177 : iecrit=1 178 : if(ydec.eq.0) then 179 : write(IUPS,1850) iposiz 180 : iprec = -10 181 : else 182 : write(IUPS,2850) (0.71*iposiz) 183 : iprec = -7 184 : endif 185 : endif 186 : 187 : c --- Traitement des caracteres définissant une position --- 188 : c -un _{ } fourni par l utilisateur indique qu'il veut un indice 189 : c if((titre(i:i+1).eq.'_{').and.(i+3.le.LTITRE)) then 190 : if((titre(i:i+1).eq.'_{')) then 191 : c write(6,*) 'on a trouvé un underscore _{' 192 : c on recupere la position courante car on en a peut etre besoin 193 : if(idec.eq.0) then 194 : write(IUPS,1111) 195 : idec=-1 196 : c pour se replacer en ce point 197 : elseif(idec.eq.1) then 198 : write(IUPS,1112) 199 : idec=0 200 : endif 201 : c on calcule le decalage vertical -2.5 202 : ydec1 = ydec1 - (2.5*real(iposiz)) 203 : ydec = ydec + ydec1 204 : c write(6,*) 'on va decaler de ',ydec1,' -> y=',ydec 205 : i=i+1 206 : c -un ^{ } fourni par l utilisateur indique qu'il veut un exposant 207 : c elseif((titre(i:i+1).eq.'^{').and.(i+3.le.LTITRE)) then 208 : elseif((titre(i:i+1).eq.'^{')) then 209 : c write(6,*) 'on a trouvé un exposant ^{' 210 : c on recupere la position courante car on en a peut etre besoin 211 : if(idec.eq.0) then 212 : write(IUPS,1111) 213 : idec=1 214 : c pour se replacer en ce point 215 : elseif(idec.eq.-1) then 216 : write(IUPS,1112) 217 : idec=0 218 : endif 219 : c on calcule le decalage vertical +5 220 : ydec1 = ydec1 + (5.*real(iposiz)) 221 : ydec = ydec + ydec1 222 : c write(6,*) 'on va decaler de ',ydec1,' -> y=',ydec 223 : i=i+1 224 : c -fin de la zone indice ou exposant 225 : elseif(titre(i:i).eq.'}') then 226 : c write(6,*) 'on a trouvé la fin de cette zone }' 227 : c il faut préparer le retour a l'alignement original (ydec=0) 228 : ydec1 = -1.*ydec 229 : ydec = ydec+ydec1 230 : c write(6,*) 'on va decaler de ',ydec1,' retour en y=0=',ydec 231 : endif 232 : c i peut etre incrémenté en plus pour sauter l'accolade { 233 : 234 : 77777 continue 235 : 236 : *============================================================= 237 : * FORMATS UTILES 238 : *============================================================= 239 : 240 : *pour faire des "(chaine) center" (commande définie dans strini): 241 : 907 format (A,1X,'center') 242 : *pour faire des "rmoveto H1" : 243 : 977 format (1X,F10.3,1X,F10.3,1X,A) 244 : 245 : *pour revenir a la police initiale : 246 : 1847 format('/Courier-ISOLatin1 findfont ',I2,' scalefont setfont') 247 : 1848 format('/Helvetica-ISOLatin1 findfont ',I2,' scalefont setfont') 248 : 1849 format('/Times-ISOLatin1 findfont ',I2,' scalefont setfont') 249 : *police Symbol : 250 : c 1850 format('/Symbol-ISOLatin1 findfont ',I2,' scalefont setfont') 251 : 1850 format('/Symbol findfont ',I2,' scalefont setfont') 252 : *police exposant et indice (=0.75*taille de la font par ex.) 253 : 2847 format('/Courier-ISOLatin1 findfont ',F4.1,' scalefont setfont') 254 : 2848 format('/Helvetica-ISOLatin1 findfont ',F4.1,' scalefont setfont') 255 : 2849 format('/Times-ISOLatin1 findfont ',F4.1,' scalefont setfont') 256 : *police Symbol exposant et indice : 257 : c 2850 format('/Symbol-ISOLatin1 findfont ',F4.1,' scalefont setfont') 258 : 2850 format('/Symbol findfont ',F4.1,' scalefont setfont') 259 : 260 : *stockage du point courant dans le stack et repositionnement en ce point 261 : 1111 format('currentpoint') 262 : 1112 format('moveto') 263 : 264 : *============================================================= 265 : * AVANT DE QUITTER, ON REMET TOUT PAR DEFAUT 266 : *============================================================= 267 : c on remet la police d origine 268 : if(iprec.ne.10) then 269 : if(ipopol.eq.1) write(IUPS,1847) iposiz 270 : if(ipopol.eq.2) write(IUPS,1848) iposiz 271 : if(ipopol.eq.3) write(IUPS,1849) iposiz 272 : endif 273 : 274 : c rotation inverse : on revient dans le bon sens 275 : if(ANGLE.ne.0.d0)then 276 : write (IUPS,fmt='(F4.1,'' neg rotate '')') ANGLE 277 : endif 278 : 279 : RETURN 280 : 281 : END 282 : 283 :
© Cast3M 2003 - All rights reserved.
Disclaimer