Télécharger chaips.eso

Retour à la liste

Numérotation des lignes :

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

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