C CHAIPS SOURCE GOUNAND 23/01/16 21:15:03 11556 C SUBROUTINE CHAIPS (TITRE,LTITRE) *============================================================= * * MANIP POUR L INTERPRETATION DES CHAINES (TITRE LABEL LEGENDES ...) * LORS DE L ECRITURE D UN FICHIER POSTSCRIPT * *============================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Y) -INC PPARAM -INC CCOPTIO -INC CCTRACE CHARACTER*(*) TITRE CHARACTER*128 CHAINE PARAMETER(IUPS=24) cbp: on definit l angle du texte : ANGLE c + une position centrée (ou pas) : IALIGN=2 (ou 0 ou 1) *============================================================= * ROTATION DE LA CHAINE PAR RAPPORT AU POINT X *============================================================= c rotation si demandée ANGLE=dble(INFOTR(1)) if(ANGLE.ne.0.d0)then write (IUPS,fmt='(F4.1,'' rotate '')') ANGLE endif *============================================================= * CENTREMENT DE LA CHAINE PAR RAPPORT AU POINT X *============================================================= c seulement si centrement demandé, sinon inutile IALIGN=INFOTR(2) IF(IALIGN.GE.2) THEN c on commence par predimensionner la chaine qui va etre ecrite iposch=1 i=0 c---> Boucle sur les caracteres do 7 i7=1,LTITRE i=i+1 if(i.gt.LTITRE) goto 8 c -si on NE lit PAS un caractere définissant un contexte particulier if((titre(i:i+1).eq.'_{').or.(titre(i:i+1).eq.'^{')) then i=i+1 elseif((titre(i:i).ne.char(92)) # .and.(titre(i:i).ne.'{').and.(titre(i:i).ne.'}') # .and.(titre(i:i).ne.'(').and.(titre(i:i).ne.')')) then c alors on l'ajoute a la chaine iposch=iposch+1 CHAINE(iposch:iposch)=titre(i:i) endif 7 continue 8 continue c Centrement CHAINE(1:1)='(' CHAINE(iposch+1:iposch+1)=')' IF(IALIGN.EQ.2) write(IUPS,907) CHAINE(1:iposch+1) IF(IALIGN.EQ.3) write(IUPS,908) CHAINE(1:iposch+1) ENDIF *============================================================= * INITIALISATIONS *============================================================= c info sur la police utilisee iposiz = (IOPOTR+3)/4 ipopol = IOPOTR - (4*(iposiz-1)) iposiz = (iposiz*2) + 10 * write(ioimp,*) 'ipopol,iposiz=',ipopol,iposiz isymb = 0 c precedente police utilise (standard par defaut) iprec = 10 c eventuel decalage (ydec1=a apporter ; ydec=cumul=position) xdec = 0. ydec = 0. ydec1= 0. idec = 0 c indice de positionnement dans les chaine de caracteres iplac =1 iposch=1 c ecriture ? iecrit=0 *============================================================= * TRAVAIL CARACTERE PAR CARACTERE *============================================================= i=0 c---> Boucle sur les caracteres do 77777 i777=1,LTITRE c --- Lecture du i^eme caractere (s il est defini) --- i=i+1 if(i.gt.LTITRE) goto 77777 c -si on lit un caractere définissant un contexte particulier if((titre(i:i+1).eq.'_{').or.(titre(i:i+1).eq.'^{') # .or.(titre(i:i).eq.'}').or.(titre(i:i).eq.char(92))) then iecrit=1 c -sinon on le met dans CHAINE else c on met des \ avant des eventuelles parentheses ... if(titre(i:i).eq.'('.or.titre(i:i).eq.')') then iposch=iposch+2 c ... ATTENTION !!! Sur IBM (AIX) il considère le \ comme un "escape", c on est donc obligé d'en mettre deux, il faut espérer que ça ne va c pas foirer sur d'autres machines. J'aurais pu mettre char(92) au c lieu de ça, mais ça ne marcherait qu'en ASCII (il y a peut etre c encore des gens qui bossent sur des mainframes) (M'Bulik) ... * CHAINE(iposch-1:iposch-1)='\\' CHAINE(iposch-1:iposch-1)=char(92) CHAINE(iposch :iposch )=TITRE(i:i) else iposch=iposch+1 CHAINE(iposch:iposch)=TITRE(i:i) endif c tant qu'on est pas arrivé au bout, on enregistre sans écrire c if(i.lt.LTITRE) then c iecrit=0 c else c iecrit=1 c endif if(i.eq.LTITRE) iecrit=1 endif c write(6,*)'CHAINE=',CHAINE(2:iposch),' ipo,ecri',iposch,iecrit c --- Ecriture de la CHAINE dans le postscript --- c rem: si le 1er caractere est spécial (_{} par ex), alors on c peut ecrire une chaine vide (iposch=1) if(iecrit.eq.1.and.iposch.ge.1) then c -Ecriture de la police if(isymb.eq.0) then if(ydec.eq.0) then if(iprec.ne.10) then if(ipopol.eq.1) write(IUPS,1846) iposiz if(ipopol.eq.2) write(IUPS,1847) iposiz if(ipopol.eq.3) write(IUPS,1848) iposiz if(ipopol.eq.4) write(IUPS,1849) iposiz endif iprec = 10 else if(iprec.ne.7) then if(ipopol.eq.1) write(IUPS,2846) (0.71*iposiz) if(ipopol.eq.2) write(IUPS,2847) (0.71*iposiz) if(ipopol.eq.3) write(IUPS,2848) (0.71*iposiz) if(ipopol.eq.4) write(IUPS,2849) (0.71*iposiz) endif iprec = 7 endif endif c -Positionnement if(iplac.gt.1) then write(IUPS,977) xdec,ydec1,'rmoveto H1' xdec = 0. ydec1 = 0. c mise a 0 de idec si on écrit sur l'axe d'origine if(ydec.eq.0..and.iposch.gt.1) idec=0 endif c -Ecriture de la chaine ( TITRE(1:iposch) ) SX iplac=iplac+1 CHAINE(1:1)='(' CHAINE(iposch+1:iposch+4)=') SX' CHAINE(iposch+5:len(CHAINE))=' ' write (iups,955) CHAINE(1:iposch+4) 955 format (a) c -On recommence le remplissage de CHAINE avec les caracteres suivants iecrit=0 iposch=1 isymb =0 endif c --- Traitement des caracteres définissant un contexte particulier --- c --- Traitement des caracteres définissant une police (Symbole) --- c -un \ fourni par l utilisateur indique qu il veut un symbole grec if((titre(i:i).eq.char(92)).and.(i+1.le.LTITRE)) then c il faut changer la font + imposer d'écrire le caractere i+1 c write(6,*) 'on a trouvé un antislash \ ' isymb =1 iecrit=1 if(ydec.eq.0) then write(IUPS,1850) iposiz iprec = -10 else write(IUPS,2850) (0.71*iposiz) iprec = -7 endif endif c --- Traitement des caracteres définissant une position --- c -un _{ } fourni par l utilisateur indique qu'il veut un indice c if((titre(i:i+1).eq.'_{').and.(i+3.le.LTITRE)) then if((titre(i:i+1).eq.'_{')) then c write(6,*) 'on a trouvé un underscore _{' c on recupere la position courante car on en a peut etre besoin if(idec.eq.0) then write(IUPS,1111) idec=-1 c pour se replacer en ce point elseif(idec.eq.1) then write(IUPS,1112) idec=0 endif c on calcule le decalage vertical -2.5 ydec1 = ydec1 - (2.5*real(iposiz)) ydec = ydec + ydec1 c write(6,*) 'on va decaler de ',ydec1,' -> y=',ydec i=i+1 c -un ^{ } fourni par l utilisateur indique qu'il veut un exposant c elseif((titre(i:i+1).eq.'^{').and.(i+3.le.LTITRE)) then elseif((titre(i:i+1).eq.'^{')) then c write(6,*) 'on a trouvé un exposant ^{' c on recupere la position courante car on en a peut etre besoin if(idec.eq.0) then write(IUPS,1111) idec=1 c pour se replacer en ce point elseif(idec.eq.-1) then write(IUPS,1112) idec=0 endif c on calcule le decalage vertical +5 ydec1 = ydec1 + (5.*real(iposiz)) ydec = ydec + ydec1 c write(6,*) 'on va decaler de ',ydec1,' -> y=',ydec i=i+1 c -fin de la zone indice ou exposant elseif(titre(i:i).eq.'}') then c write(6,*) 'on a trouvé la fin de cette zone }' c il faut préparer le retour a l'alignement original (ydec=0) ydec1 = -1.*ydec ydec = ydec+ydec1 c write(6,*) 'on va decaler de ',ydec1,' retour en y=0=',ydec endif c i peut etre incrémenté en plus pour sauter l'accolade { 77777 continue *============================================================= * FORMATS UTILES *============================================================= *pour faire des "(chaine) center" (commande définie dans strini): 907 format (A,1X,'center') *pour faire des "(chaine) right" (commande définie dans strini): 908 format (A,1X,'right') *pour faire des "rmoveto H1" : 977 format (1X,F10.3,1X,F10.3,1X,A) *pour revenir a la police initiale : 1846 format('/Courier-ISOLatin1 findfont ',I2,' scalefont setfont') 1847 format('/CourierBold-ISOLatin1 findfont ',I2,' scalefont setfont') 1848 format('/Helvetica-ISOLatin1 findfont ',I2,' scalefont setfont') 1849 format('/Times-ISOLatin1 findfont ',I2,' scalefont setfont') *police Symbol : c 1850 format('/Symbol-ISOLatin1 findfont ',I2,' scalefont setfont') 1850 format('/Symbol findfont ',I2,' scalefont setfont') *police exposant et indice (=0.75*taille de la font par ex.) 2846 format('/Courier-ISOLatin1 findfont ',F4.1,' scalefont setfont') 2847 format('/CourierBold-ISOLatin1 findfont ',F4.1, $ ' scalefont setfont') 2848 format('/Helvetica-ISOLatin1 findfont ',F4.1,' scalefont setfont') 2849 format('/Times-ISOLatin1 findfont ',F4.1,' scalefont setfont') *police Symbol exposant et indice : c 2850 format('/Symbol-ISOLatin1 findfont ',F4.1,' scalefont setfont') 2850 format('/Symbol findfont ',F4.1,' scalefont setfont') *stockage du point courant dans le stack et repositionnement en ce point 1111 format('currentpoint') 1112 format('moveto') *============================================================= * AVANT DE QUITTER, ON REMET TOUT PAR DEFAUT *============================================================= c on remet la police d origine if(iprec.ne.10) then if(ipopol.eq.1) write(IUPS,1846) iposiz if(ipopol.eq.2) write(IUPS,1847) iposiz if(ipopol.eq.3) write(IUPS,1848) iposiz if(ipopol.eq.4) write(IUPS,1849) iposiz endif c rotation inverse : on revient dans le bon sens if(ANGLE.ne.0.d0)then write (IUPS,fmt='(F4.1,'' neg rotate '')') ANGLE endif RETURN END