Télécharger chaips.eso

Retour à la liste

Numérotation des lignes :

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

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