Sources Esope | Cast3M

chaips
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