Télécharger mtrini.eso

Retour à la liste

mtrini
C MTRINI    SOURCE    CB215821  21/07/12    21:15:13     11074          
C
C   driver, derivato dalla strini.eso, per generazione di
C   un file mif da manipolare con FrameMaker per text-processing
C                                             02.09.92 folco,loris
C                                             15.09.93 pierre
C  1995 degrade pour le trace face Pierre Pegon JRC-ISPRA
C
      SUBROUTINE MTRINI(NOL,AXAX,AYAY,TITR,HAUTT,VALEU,NCOUMA)
      IMPLICIT INTEGER(I-N)
-INC CCREEL
 
-INC PPARAM
-INC CCOPTIO
      external long
      DIMENSION XTR(*),YTR(*)
      CHARACTER*(*) TITR,CARAC,PROMPT,REPLY
      CHARACTER*(500) LEGEND
      CHARACTER*(LOCHAI) TITRE
      CHARACTER*500 CHEMIN
      equivalence (chemin,ichemi)
      LOGICAL VALEU,FENE,VALEUR,FENET
      SAVE XIOCAD,YIOCAD,VALEUR,FENET,TITRE,LTITRE
      SAVE XMIN,YMIN,XXAX,YYAX,CLX,XRAP,YRAP,XDEP,YDEP
      save kcoul,initia,ipag,jfont,jfonl,jpol,landsc
CLP
      save lfi
CLP
CLP   PARAMETER(IUPS=24)
      PARAMETER(IUPS=97)
CPP   data  initia/0/
CPP   data ipag/1/
      DIMENSION ITB(17)
      logical landsc
      character miffil*64,line*256
      character*18 lfi,lsp
      character*2 cisov(18),cline(18)
C+PPf (FACE)
      DIMENSION ITCODP(6)
      DATA ITCODP/6,5,4,3,2,1/
C+PPf
      data sacfac/1.134/
      data  initia/0/
      data  jfont /0/
      data  jfonl /0/
      data  jpol  /0/
      data  ipag  /1/
c
C PP For a 7-color scale I assume it uses only   kolor(4,2,6,3,5,7,0)
c
      data cisov   /'D0','D1','D2','D3','D4','D5','D6','D7','D8',
     >              'D9','DA','DB','DC','DD','DE','DF','DG','DH'/
      data cline   /'C0','C1','C2','C3','C4','C5','C6','C7',10*'C0'/
c
* verification des bornes
      bornex(xxx)=min(max(xiocad*0.01,xxx),xiocad*0.99)
      borney(yyy)=min(max(yiocad*0.01,yyy),yiocad*0.99)
cfolco
c
c Note: saclay PostScript output generates a scale that is
c       not in true cm, but a bit larger (1 unit= 1.134 cm)
c       To obtain 'true' cm we must then divide by 1.134
c       We then add 2.0 cm to make the border
      coxmif(xxx)=(xxx/sacfac)+2.0
      coymif(yyy)=(21.0-yyy)/sacfac+2.0
cfolco
*
C  INITIALISATION
*  on part pour 7 couleurs
      NCOUMA=7
C!!!
      NCOUMA=16
C!!!
      kcoul=0
      LTITRE=LONG(TITR)
      TITRE=TITR
      VALEUR=VALEU
*  INITIALISATION DE POSTSCRIPT
      CLX=0.3
      xiocad=diocad
      yiocad=xiocad*21/29.7
CLP   lfi='<PenWidth 0.482pt>'
      lfi='<PenWidth 0.3pt>'
CLP   lsp='<PenWidth 0.723pt>'
      lsp='<PenWidth 0.6pt>'
      landsc=.true.
c
C+PP
      if (ZINIPS) then
        ZINIPS = .false.
        initia = 0
      endif
C+PP
      if (initia.eq.0) then
        initia=1
        kcoul=0
        write(iups,'(a)') '<MIFFile 3.00># Generated by CASTEM2000'
        write(iups,'(a,i1)') '# Dimension: ',idim
        write(iups,'(a,a)') '# Title:',titr
        write(iups,'(a)') '#'
C LP
C---------------------------
c
c 'mifheader.l' : name of file containing MIF header (Landscape)
c 'mifheader.p' : name of file containing MIF header (Portrait)
c
        chemin='MIF_PATH'//char(0)
        lchem=500
        call ooozen(ichemi,lchem)
        if (lchem.eq.0) then
         write (ioimp,*) 'Please define MIF_PATH'
         stop
        endif
        lchem=long(chemin(1:lchem))
        if(landsc) then
          miffil=chemin(1:lchem)//'/mifheader.la'
        else
          miffil=chemin(1:lchem)//'/mifheader.po'
        endif
        jfm=89
        open(jfm,file=miffil,FORM='FORMATTED',err=901)
        nlrd=0
    1   read(jfm,'(a)',end=2) line
        nlrd=nlrd+1
        klast=0
        do 3 k=256,1,-1
          if(line(k:k).ne.' ') then
            klast=k
            go to 4
          endif
    3   continue
    4   continue
        if(nlrd.eq.1) then
c
c comment out '<MIFFile 4.00 . . .' from header file
c
          if(klast.gt.0) write(iups,'(a)') '#'//line(1:klast)
        else
          if(klast.gt.0) write(iups,'(a)') line(1:klast)
        endif
        go to 1
    2   continue
        close (jfm)
C---------------------------
C LP
      endif
      goto 902
  901 write(ioimp,*) 'Cant open mif header file in ',chemin(1:lchem)
      stop
C
  902 RETURN
**
      ENTRY mDFENE(XMI,XXA,YMI,YYA,XR1,XR2,YR1,YR2,FENE)
*  DEFINITION FENETRE
      XR1=XMI
      XR2=XXA
      YR1=YMI
      YR2=YYA
      FENET=FENE
      XMIN=XMI
      XXAX=XXA
      YMIN=YMI
      YYAX=YYA
      IF (FENET) THEN
       if (.not.valeur) xiocad=xiocad-5*clx
       if (valeur) xiocad=xiocad-10*clx
      endif
       yiocad=yiocad-2*clx
      XRAP=xIOCAD/(XXAX-XMIN)*0.95
      YRAP=yIOCAD/(YYAX-YMIN)*0.95
      rap=min(xrap,yrap)
      if (fenet) then
       xrap=rap
       yrap=rap
      endif
      IF (FENET) THEN
       if (.not.valeur) xiocad=xiocad+5*clx
       if (valeur) xiocad=xiocad+10*clx
      endif
       yiocad=yiocad+2*clx
       XDEP=-XMIN + (xxax-xmin)*0.02
       YDEP=-YMIN + (YYAX-YMIN)*0.02 +CLX/YRAP
       NBC=LTITRE
      XCO=NBC*CLX/XRAP
      YCO=0
c
      xmif=2.5
      if(locerr.eq.'DESS') ymif=20.0
CLP   if(locerr.eq.'TRAC') ymif=20.5
      if(locerr.eq.'TRAC') ymif=20.2
      if(initia.gt.1) then
        do k=1,2
          backspace iups
        enddo
        write(iups,'(a)') '> # End of page'
      endif
      initia=initia+1
      write(iups,'(a)') '#'
      write(iups,'(a)') '# New Page ----------------------------'
      write(iups,'(a)') '#'
      write(iups,'(a)') '<Page'
      write(iups,'(a)') '<PageType BodyPage>'
      write(iups,'(a,i3,a)') '<PageNum `',ipag,'''>'
      if(landsc) then
        write(iups,'(a)') '<PageSize 29.7 21.0>'
        write(iups,'(a)') '<PageOrientation Landscape>'
      else
        write(iups,'(a)') '<PageSize 21.0 29.7>'
        write(iups,'(a)') '<PageOrientation Portrait>'
      endif
      write(iups,'(a)') '<PageBackground `Default''>'
      write(iups,'(a)') '#'
      write(iups,'(a)') '# Objects on page:'
      write(iups,'(a)') '#'
      write(iups,'(a)') '<TextLine'
      if(jfont.eq.1) write(iups,'(a)') ' <GroupID 1>'
      write(iups,'(a)') ' <Separation 0>'
      write(iups,'(a,2f8.3,a)') ' <TLOrigin ',xmif,ymif,'>'
      write(iups,'(a)') ' <TLAlignment Left>'
      write(iups,'(a)') ' <Angle 0>'
c------------(assegnazione fonts)------
      if(jfonl.eq.1) then
        write(iups,'(a)') ' <Font'
        write(iups,'(a)') '  <FAngle `Regular''>'
        write(iups,'(a)') '  <FWeight `Bold''>'
        write(iups,'(a)') '  <FSize  11.0 pt>'
        write(iups,'(a)') ' > # end of Font'
        jfonl=0
      endif
      if(jfont.eq.0) then
        write(iups,'(a)') ' <Font'
        write(iups,'(a)') '  <FTag `C4''>'
        write(iups,'(a)') '  <FFamily `Times''>'
        write(iups,'(a)') '  <FVar `Regular''>'
        write(iups,'(a)') '  <FWeight `Bold''>'
        write(iups,'(a)') '  <FAngle `Regular''>'
CLP     write(iups,'(a)') '  <FSize  13.7 pt>'
        write(iups,'(a)') '  <FSize  11.0 pt>'
        write(iups,'(a)') '  <FUnderline No >'
        write(iups,'(a)') '  <FOverline No >'
        write(iups,'(a)') '  <FStrike No >'
        write(iups,'(a)') '  <FSupScript No >'
        write(iups,'(a)') '  <FSubScript No >'
        write(iups,'(a)') '  <FChangeBar No >'
        write(iups,'(a)') '  <FOutline No >'
        write(iups,'(a)') '  <FShadow No >'
        write(iups,'(a)') '  <FPairKern No >'
        write(iups,'(a)') '  <FDoubleUnderline No >'
        write(iups,'(a)') '  <FNumericUnderline No >'
        write(iups,'(a)') '  <FDX  0.0 pt>'
        write(iups,'(a)') '  <FDY  0.0 pt>'
        write(iups,'(a)') '  <FDW  0.0 pt>'
        write(iups,'(a)') '  <FSeparation 0>'
        write(iups,'(a)') ' > # end of Font'
        jfont=1
      endif
      write(iups,'(a)') ' <String `'//titre(1:ltitre)//'''>'
      write(iups,'(a)') '> # end of TextLine'
      ipag=ipag+1
c
c
      RETURN
**
      ENTRY mTRLAB(XT,YT,CARAC,NCARR,HAUT)
*  ECRITURE TEXT
C
      kcoul=0
      write (IUPS,'(a)')cline(kcoul+1)
C
      xmif=coxmif(bornex((xdep+xt)*xrap))
      ymif=coymif(borney((ydep+yt)*yrap))
      write(iups,'(a)') '#'
      write(iups,'(a)') '<TextLine'
      if(jfont.eq.1) write(iups,'(a)') '<GroupID 1>'
      write(iups,'(a,2f8.3,a)') '<TLOrigin ',xmif,ymif,'>'
      write(iups,'(a)') '<TLAlignment Left>'
      write(iups,'(a)') '<Angle 0>'
c------------(assegnazione fonts)------
CLP
      if(jfonl.eq.0) then
        write(iups,'(a)') ' <Font'
        write(iups,'(a)') '  <FWeight `Regular''>'
        write(iups,'(a)') '  <FAngle `Italic''>'
        write(iups,'(a)') '  <FSize  9.0 pt>'
        write(iups,'(a)') ' > # end of Font'
        jfonl=1
      endif
CLP
      if(jfont.eq.0) then
        write(iups,'(a)') ' <Font'
        write(iups,'(a)') '  <FTag `C4''>'
        write(iups,'(a)') '  <FFamily `Times''>'
        write(iups,'(a)') '  <FVar `Regular''>'
CLP     write(iups,'(a)') '  <FWeight `Bold''>'
        write(iups,'(a)') '  <FWeight `Regular''>'
CLP     write(iups,'(a)') '  <FAngle `Regular''>'
        write(iups,'(a)') '  <FAngle `Italic''>'
CLP     write(iups,'(a)') '  <FSize  13.7 pt>'
        write(iups,'(a)') '  <FSize  9.0 pt>'
        write(iups,'(a)') '  <FUnderline No >'
        write(iups,'(a)') '  <FOverline No >'
        write(iups,'(a)') '  <FStrike No >'
        write(iups,'(a)') '  <FSupScript No >'
        write(iups,'(a)') '  <FSubScript No >'
        write(iups,'(a)') '  <FChangeBar No >'
        write(iups,'(a)') '  <FOutline No >'
        write(iups,'(a)') '  <FShadow No >'
        write(iups,'(a)') '  <FPairKern No >'
        write(iups,'(a)') '  <FDoubleUnderline No >'
        write(iups,'(a)') '  <FNumericUnderline No >'
        write(iups,'(a)') '  <FDX  0.0 pt>'
        write(iups,'(a)') '  <FDY  0.0 pt>'
        write(iups,'(a)') '  <FDW  0.0 pt>'
        write(iups,'(a)') '  <FSeparation 0>'
        write(iups,'(a)') ' > # end of Font'
        jfont=1
      endif
      write(iups,'(a,a,a)') ' <String `',carac(1:NCARR),'''>'
      write(iups,'(a)') '> # end of TextLine'
c
      RETURN
**
      ENTRY mCHCOU(JCOLO)
*  CHANGEMENT DE COULEUR
      kcoul=jcolo
      RETURN
**
      ENTRY mINSEG(JSEG,IRESS)
*  CHANGEMENT SEGMENT       IGNORE
      RETURN
**
      ENTRY mPOLRL(NTRSTU,XTR,YTR)
*  POLYLINE
      write(iups,'(a)') '#'
      write(iups,'(a)') '<PolyLine'
      if(jpol.eq.0) then
        write(iups,'(a)') ' <Pen 0>'
        write(iups,'(a)') lfi
        write(iups,'(a)') ' <HeadCap Round>'
        write(iups,'(a)') ' <TailCap Round>'
        write(iups,'(a)') ' <Smoothed No>'
        jpol=1
      endif
      write (IUPS,'(a)')cline(kcoul+1)
      write(iups,'(a,i3)') ' <NumPoints ',ntrstu,'>'
      do 10 i=1,ntrstu
      xmif=coxmif(bornex((xdep+xtr(i))*xrap))
      ymif=coymif(borney((ydep+ytr(i))*yrap))
      write(iups,'(a,2f8.3,a)')  ' <Point ',xmif,ymif,'>'
   10 continue
      write(iups,'(a)') '> # end of PolyLine'
c
      RETURN
**
      ENTRY mTRFAC(NTRSTU,XTR,YTR,ZN,ICOLE,IEFF)
*  FACETTE
C+PPf
      ZZN=ABS(ZN/XPI*2)
      IF (ZZN.GT.0.99999)ZZN=0.99999
      IZN=INT(6*ZZN)+1
      IZN=ITCODP(IZN)
C+PPf
      kcoul=icole
      write(iups,'(a)') '#'
      write(iups,'(a)') '<Polygon'
C+PPf
      write(iups,'(a)') '<Pen 15>'
C+PPf
C PPf if(jpol.eq.0) then
C PPf   write(iups,'(a)') '<Pen 0>'
C PPf   write(iups,'(a)') lfi
C PPf   write(iups,'(a)') '<Smoothed No>'
C PPf endif
C PPf write (IUPS,'(a)')cisov(kcoul+1)
      write (IUPS,'(a)')cline(kcoul+1)
C+PPf
      write(iups,'(a6,i1,a1)') '<Fill ',IZN,'>'
C+PPf
      do 20 i=1,ntrstu
      xmif=coxmif(bornex((xdep+xtr(i))*xrap))
      ymif=coymif(borney((ydep+ytr(i))*yrap))
      write(iups,'(a,2f8.3,a)')  '<Point ',xmif,ymif,'>'
   20 continue
      write(iups,'(a)') '>'
c
      IEFF=1
      RETURN
**
      ENTRY mTRAIS(NP,XTR,YTR,ICOLE)
*  FACETTE
      kcoul=icole
      write(iups,'(a)') '#'
      write(iups,'(a)') '<Polygon'
      if(jpol.eq.0) then
        write(iups,'(a)') '<Pen 0>'
        write(iups,'(a)') lfi
        write(iups,'(a)') '<Smoothed No>'
      endif
      write (IUPS,'(a)')cisov(kcoul+1)
      do 30 i=1,np
      xmif=coxmif(bornex((xdep+xtr(i))*xrap))
      ymif=coymif(borney((ydep+ytr(i))*yrap))
      write(iups,'(a,2f8.3,a)')  '<Point ',xmif,ymif,'>'
   30 continue
      write(iups,'(a)') '>'
c
      RETURN
**
      ENTRY mTRDIG(XRO,XCOL,ICLE)
*  DIGITALISATION DE POINT  IGNORE
      ICLE=0
      RETURN
**
      ENTRY mTRAFF(ICLE)
*  FIN DE DESSIN
      ICLE=0
      jpol=0
      write(iups,'(a)') ' <Group <ID 1> >'
      write(iups,'(a)') ' <Group <ID 100> >'
      write(iups,'(a)') ' <Group <ID 101> >'
      write(iups,'(a)') ' <Group <ID 102> >'
      write(iups,'(a)') ' <Group <ID 103> >'
      write(iups,'(a)') ' <Group <ID 104> >'
      write(iups,'(a)') ' <Group <ID 105> >'
      write(iups,'(a)') ' <Group <ID 106> >'
      write(iups,'(a)') ' <Group <ID 107> >'
      write(iups,'(a)') ' <Group <ID 201> >'
      write(iups,'(a)') ' <Group <ID 202> >'
      write(iups,'(a)') ' <Group <ID 203> >'
      write(iups,'(a)') ' <Group <ID 204> >'
      write(iups,'(a)') ' <Group <ID 205> >'
      write(iups,'(a)') ' <Group <ID 206> >'
      write(iups,'(a)') ' <Group <ID 207> >'
      write(iups,'(a)') ' <Group <ID 208> >'
      write(iups,'(a)') ' <Group <ID 209> >'
      write(iups,'(a)') ' <Group <ID 210> >'
      write(iups,'(a)') ' <Group <ID 211> >'
      write(iups,'(a)') ' <Group <ID 212> >'
      write(iups,'(a)') ' <Group <ID 213> >'
      write(iups,'(a)') ' <Group <ID 214> >'
      write(iups,'(a)') ' <Group <ID 215> >'
      write(iups,'(a)') ' <Group <ID 216> >'
      write(iups,'(a)') '> # End of page'
      write(iups,'(a)') '# End of MIFFile'
      RETURN
**
      ENTRY mMENU(LEGEND,NCASE,LLONG)
*  MENU       IGNORE
      RETURN
**
      ENTRY mTRANI(ITYPI,NBIMAH)
*  ANIMATION  IGNOREE
      RETURN
**
      ENTRY mTRIMA(IMAGI)
*  IMAGE      IGNOREE
      RETURN
**
      ENTRY mFVALI(IFENI,IRESU,NH)
*  CHANGEMENT DE VIEW PORT
      IF (IFENI.EQ.1) THEN
       XRAP=CLX*10/0.95
       YRAP=clx*2/0.95
       XDEP=(xiocad-10*clx)/xrap
       YDEP=0.
      ENDIF
       NH=31
      RETURN
**
      ENTRY mZOOM(IZOOM,XMI,XMA,YMI,YMA)
*  IGNOREE
      RETURN
**
      ENTRY mINIt(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA)
*  RETOUR AU DESSIN INITIAL   IGNORE
      RETURN
**
      ENTRY mCHANG(IRESU,ISORT,ICHANG,JSEG)
*  AFFICHAGE DESAFFICHAGE NUM NOEUDS ELEMENTS QUAL  IGNORE
       RETURN
**
      ENTRY mTRBOX(HAUTX,HAUTY)
*  INUTILISE
      RETURN
**
      ENTRY mTREFF
*  INUTILISE
      RETURN
**
      ENTRY mVAL(IRESU,ISORT,NISO)
*  INUTILISE
      RETURN
**
      ENTRY mMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL)
*  INUTILISE
      RETURN
**
**
      ENTRY mIMPR
*  INUTILISE
      RETURN
**
      ENTRY mTRTIN
*  INUTILISE
      RETURN
**
      ENTRY mFLGI
*  INUTILISE
      RETURN
**
      ENTRY mTRMES(CARAC)
*  INUTILISE
      RETURN
**
      ENTRY mTRGET(PROMPT,REPLY)
*  INUTILISE
      RETURN
      ENTRY mTRMFI
*  INUTILISE
      RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 
 

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