Télécharger mtrini.eso

Retour à la liste

Numérotation des lignes :

  1. C MTRINI SOURCE CB215821 20/08/04 21:15:09 10680
  2. C
  3. C driver, derivato dalla strini.eso, per generazione di
  4. C un file mif da manipolare con FrameMaker per text-processing
  5. C 02.09.92 folco,loris
  6. C 15.09.93 pierre
  7. C 1995 degrade pour le trace face Pierre Pegon JRC-ISPRA
  8. C
  9. SUBROUTINE MTRINI(NOL,AXAX,AYAY,TITR,HAUTT,VALEU,NCOUMA)
  10. IMPLICIT INTEGER(I-N)
  11. -INC CCREEL
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. external long
  16. DIMENSION XTR(*),YTR(*)
  17. CHARACTER*(*) TITR,CARAC,PROMPT,REPLY
  18. CHARACTER*(500) LEGEND
  19. CHARACTER*80 TITRE
  20. CHARACTER*500 CHEMIN
  21. equivalence (chemin,ichemi)
  22. LOGICAL VALEU,FENE,VALEUR,FENET
  23. SAVE XIOCAD,YIOCAD,VALEUR,FENET,TITRE,LTITRE
  24. SAVE XMIN,YMIN,XXAX,YYAX,CLX,XRAP,YRAP,XDEP,YDEP
  25. save kcoul,initia,ipag,jfont,jfonl,jpol,landsc
  26. CLP
  27. save lfi
  28. CLP
  29. CLP PARAMETER(IUPS=24)
  30. PARAMETER(IUPS=97)
  31. CPP data initia/0/
  32. CPP data ipag/1/
  33. DIMENSION ITB(17)
  34. logical landsc
  35. character miffil*64,line*256
  36. character*18 lfi,lsp
  37. character*2 cisov(18),cline(18)
  38. C+PPf (FACE)
  39. DIMENSION ITCODP(6)
  40. DATA ITCODP/6,5,4,3,2,1/
  41. C+PPf
  42. data sacfac/1.134/
  43. data initia/0/
  44. data jfont /0/
  45. data jfonl /0/
  46. data jpol /0/
  47. data ipag /1/
  48. c
  49. C PP For a 7-color scale I assume it uses only kolor(4,2,6,3,5,7,0)
  50. c
  51. data cisov /'D0','D1','D2','D3','D4','D5','D6','D7','D8',
  52. > 'D9','DA','DB','DC','DD','DE','DF','DG','DH'/
  53. data cline /'C0','C1','C2','C3','C4','C5','C6','C7',10*'C0'/
  54. c
  55. * verification des bornes
  56. bornex(xxx)=min(max(xiocad*0.01,xxx),xiocad*0.99)
  57. borney(yyy)=min(max(yiocad*0.01,yyy),yiocad*0.99)
  58. cfolco
  59. c
  60. c Note: saclay PostScript output generates a scale that is
  61. c not in true cm, but a bit larger (1 unit= 1.134 cm)
  62. c To obtain 'true' cm we must then divide by 1.134
  63. c We then add 2.0 cm to make the border
  64. coxmif(xxx)=(xxx/sacfac)+2.0
  65. coymif(yyy)=(21.0-yyy)/sacfac+2.0
  66. cfolco
  67. *
  68. C INITIALISATION
  69. * on part pour 7 couleurs
  70. NCOUMA=7
  71. C!!!
  72. NCOUMA=16
  73. C!!!
  74. kcoul=0
  75. LTITRE=LONG(TITR)
  76. TITRE=TITR
  77. VALEUR=VALEU
  78. * INITIALISATION DE POSTSCRIPT
  79. CLX=0.3
  80. xiocad=diocad
  81. yiocad=xiocad*21/29.7
  82. CLP lfi='<PenWidth 0.482pt>'
  83. lfi='<PenWidth 0.3pt>'
  84. CLP lsp='<PenWidth 0.723pt>'
  85. lsp='<PenWidth 0.6pt>'
  86. landsc=.true.
  87. c
  88. C+PP
  89. if (ZINIPS) then
  90. ZINIPS = .false.
  91. initia = 0
  92. endif
  93. C+PP
  94. if (initia.eq.0) then
  95. initia=1
  96. kcoul=0
  97. write(iups,'(a)') '<MIFFile 3.00># Generated by CASTEM2000'
  98. write(iups,'(a,i1)') '# Dimension: ',idim
  99. write(iups,'(a,a)') '# Title:',titr
  100. write(iups,'(a)') '#'
  101. C LP
  102. C---------------------------
  103. c
  104. c 'mifheader.l' : name of file containing MIF header (Landscape)
  105. c 'mifheader.p' : name of file containing MIF header (Portrait)
  106. c
  107. chemin='MIF_PATH'//char(0)
  108. lchem=500
  109. call ooozen(ichemi,lchem)
  110. if (lchem.eq.0) then
  111. write (ioimp,*) 'Please define MIF_PATH'
  112. stop
  113. endif
  114. lchem=long(chemin(1:lchem))
  115. if(landsc) then
  116. miffil=chemin(1:lchem)//'/mifheader.la'
  117. else
  118. miffil=chemin(1:lchem)//'/mifheader.po'
  119. endif
  120. jfm=89
  121. open(jfm,file=miffil,FORM='FORMATTED',err=901)
  122. nlrd=0
  123. 1 read(jfm,'(a)',end=2) line
  124. nlrd=nlrd+1
  125. klast=0
  126. do 3 k=256,1,-1
  127. if(line(k:k).ne.' ') then
  128. klast=k
  129. go to 4
  130. endif
  131. 3 continue
  132. 4 continue
  133. if(nlrd.eq.1) then
  134. c
  135. c comment out '<MIFFile 4.00 . . .' from header file
  136. c
  137. if(klast.gt.0) write(iups,'(a)') '#'//line(1:klast)
  138. else
  139. if(klast.gt.0) write(iups,'(a)') line(1:klast)
  140. endif
  141. go to 1
  142. 2 continue
  143. close (jfm)
  144. C---------------------------
  145. C LP
  146. endif
  147. goto 902
  148. 901 write(ioimp,*) 'Cant open mif header file in ',chemin(1:lchem)
  149. stop
  150. C
  151. 902 RETURN
  152. **
  153. ENTRY mDFENE(XMI,XXA,YMI,YYA,XR1,XR2,YR1,YR2,FENE)
  154. * DEFINITION FENETRE
  155. XR1=XMI
  156. XR2=XXA
  157. YR1=YMI
  158. YR2=YYA
  159. FENET=FENE
  160. XMIN=XMI
  161. XXAX=XXA
  162. YMIN=YMI
  163. YYAX=YYA
  164. IF (FENET) THEN
  165. if (.not.valeur) xiocad=xiocad-5*clx
  166. if (valeur) xiocad=xiocad-10*clx
  167. endif
  168. yiocad=yiocad-2*clx
  169. XRAP=xIOCAD/(XXAX-XMIN)*0.95
  170. YRAP=yIOCAD/(YYAX-YMIN)*0.95
  171. rap=min(xrap,yrap)
  172. if (fenet) then
  173. xrap=rap
  174. yrap=rap
  175. endif
  176. IF (FENET) THEN
  177. if (.not.valeur) xiocad=xiocad+5*clx
  178. if (valeur) xiocad=xiocad+10*clx
  179. endif
  180. yiocad=yiocad+2*clx
  181. XDEP=-XMIN + (xxax-xmin)*0.02
  182. YDEP=-YMIN + (YYAX-YMIN)*0.02 +CLX/YRAP
  183. NBC=LTITRE
  184. XCO=NBC*CLX/XRAP
  185. YCO=0
  186. c
  187. xmif=2.5
  188. if(locerr.eq.'DESS') ymif=20.0
  189. CLP if(locerr.eq.'TRAC') ymif=20.5
  190. if(locerr.eq.'TRAC') ymif=20.2
  191. if(initia.gt.1) then
  192. do k=1,2
  193. backspace iups
  194. enddo
  195. write(iups,'(a)') '> # End of page'
  196. endif
  197. initia=initia+1
  198. write(iups,'(a)') '#'
  199. write(iups,'(a)') '# New Page ----------------------------'
  200. write(iups,'(a)') '#'
  201. write(iups,'(a)') '<Page'
  202. write(iups,'(a)') '<PageType BodyPage>'
  203. write(iups,'(a,i3,a)') '<PageNum `',ipag,'''>'
  204. if(landsc) then
  205. write(iups,'(a)') '<PageSize 29.7 21.0>'
  206. write(iups,'(a)') '<PageOrientation Landscape>'
  207. else
  208. write(iups,'(a)') '<PageSize 21.0 29.7>'
  209. write(iups,'(a)') '<PageOrientation Portrait>'
  210. endif
  211. write(iups,'(a)') '<PageBackground `Default''>'
  212. write(iups,'(a)') '#'
  213. write(iups,'(a)') '# Objects on page:'
  214. write(iups,'(a)') '#'
  215. write(iups,'(a)') '<TextLine'
  216. if(jfont.eq.1) write(iups,'(a)') ' <GroupID 1>'
  217. write(iups,'(a)') ' <Separation 0>'
  218. write(iups,'(a,2f8.3,a)') ' <TLOrigin ',xmif,ymif,'>'
  219. write(iups,'(a)') ' <TLAlignment Left>'
  220. write(iups,'(a)') ' <Angle 0>'
  221. c------------(assegnazione fonts)------
  222. if(jfonl.eq.1) then
  223. write(iups,'(a)') ' <Font'
  224. write(iups,'(a)') ' <FAngle `Regular''>'
  225. write(iups,'(a)') ' <FWeight `Bold''>'
  226. write(iups,'(a)') ' <FSize 11.0 pt>'
  227. write(iups,'(a)') ' > # end of Font'
  228. jfonl=0
  229. endif
  230. if(jfont.eq.0) then
  231. write(iups,'(a)') ' <Font'
  232. write(iups,'(a)') ' <FTag `C4''>'
  233. write(iups,'(a)') ' <FFamily `Times''>'
  234. write(iups,'(a)') ' <FVar `Regular''>'
  235. write(iups,'(a)') ' <FWeight `Bold''>'
  236. write(iups,'(a)') ' <FAngle `Regular''>'
  237. CLP write(iups,'(a)') ' <FSize 13.7 pt>'
  238. write(iups,'(a)') ' <FSize 11.0 pt>'
  239. write(iups,'(a)') ' <FUnderline No >'
  240. write(iups,'(a)') ' <FOverline No >'
  241. write(iups,'(a)') ' <FStrike No >'
  242. write(iups,'(a)') ' <FSupScript No >'
  243. write(iups,'(a)') ' <FSubScript No >'
  244. write(iups,'(a)') ' <FChangeBar No >'
  245. write(iups,'(a)') ' <FOutline No >'
  246. write(iups,'(a)') ' <FShadow No >'
  247. write(iups,'(a)') ' <FPairKern No >'
  248. write(iups,'(a)') ' <FDoubleUnderline No >'
  249. write(iups,'(a)') ' <FNumericUnderline No >'
  250. write(iups,'(a)') ' <FDX 0.0 pt>'
  251. write(iups,'(a)') ' <FDY 0.0 pt>'
  252. write(iups,'(a)') ' <FDW 0.0 pt>'
  253. write(iups,'(a)') ' <FSeparation 0>'
  254. write(iups,'(a)') ' > # end of Font'
  255. jfont=1
  256. endif
  257. write(iups,'(a)') ' <String `'//titre(1:ltitre)//'''>'
  258. write(iups,'(a)') '> # end of TextLine'
  259. ipag=ipag+1
  260. c
  261. c
  262. RETURN
  263. **
  264. ENTRY mTRLAB(XT,YT,CARAC,NCARR,HAUT)
  265. * ECRITURE TEXT
  266. C
  267. kcoul=0
  268. write (IUPS,'(a)')cline(kcoul+1)
  269. C
  270. xmif=coxmif(bornex((xdep+xt)*xrap))
  271. ymif=coymif(borney((ydep+yt)*yrap))
  272. write(iups,'(a)') '#'
  273. write(iups,'(a)') '<TextLine'
  274. if(jfont.eq.1) write(iups,'(a)') '<GroupID 1>'
  275. write(iups,'(a,2f8.3,a)') '<TLOrigin ',xmif,ymif,'>'
  276. write(iups,'(a)') '<TLAlignment Left>'
  277. write(iups,'(a)') '<Angle 0>'
  278. c------------(assegnazione fonts)------
  279. CLP
  280. if(jfonl.eq.0) then
  281. write(iups,'(a)') ' <Font'
  282. write(iups,'(a)') ' <FWeight `Regular''>'
  283. write(iups,'(a)') ' <FAngle `Italic''>'
  284. write(iups,'(a)') ' <FSize 9.0 pt>'
  285. write(iups,'(a)') ' > # end of Font'
  286. jfonl=1
  287. endif
  288. CLP
  289. if(jfont.eq.0) then
  290. write(iups,'(a)') ' <Font'
  291. write(iups,'(a)') ' <FTag `C4''>'
  292. write(iups,'(a)') ' <FFamily `Times''>'
  293. write(iups,'(a)') ' <FVar `Regular''>'
  294. CLP write(iups,'(a)') ' <FWeight `Bold''>'
  295. write(iups,'(a)') ' <FWeight `Regular''>'
  296. CLP write(iups,'(a)') ' <FAngle `Regular''>'
  297. write(iups,'(a)') ' <FAngle `Italic''>'
  298. CLP write(iups,'(a)') ' <FSize 13.7 pt>'
  299. write(iups,'(a)') ' <FSize 9.0 pt>'
  300. write(iups,'(a)') ' <FUnderline No >'
  301. write(iups,'(a)') ' <FOverline No >'
  302. write(iups,'(a)') ' <FStrike No >'
  303. write(iups,'(a)') ' <FSupScript No >'
  304. write(iups,'(a)') ' <FSubScript No >'
  305. write(iups,'(a)') ' <FChangeBar No >'
  306. write(iups,'(a)') ' <FOutline No >'
  307. write(iups,'(a)') ' <FShadow No >'
  308. write(iups,'(a)') ' <FPairKern No >'
  309. write(iups,'(a)') ' <FDoubleUnderline No >'
  310. write(iups,'(a)') ' <FNumericUnderline No >'
  311. write(iups,'(a)') ' <FDX 0.0 pt>'
  312. write(iups,'(a)') ' <FDY 0.0 pt>'
  313. write(iups,'(a)') ' <FDW 0.0 pt>'
  314. write(iups,'(a)') ' <FSeparation 0>'
  315. write(iups,'(a)') ' > # end of Font'
  316. jfont=1
  317. endif
  318. write(iups,'(a,a,a)') ' <String `',carac(1:NCARR),'''>'
  319. write(iups,'(a)') '> # end of TextLine'
  320. c
  321. RETURN
  322. **
  323. ENTRY mCHCOU(JCOLO)
  324. * CHANGEMENT DE COULEUR
  325. kcoul=jcolo
  326. RETURN
  327. **
  328. ENTRY mINSEG(JSEG,IRESS)
  329. * CHANGEMENT SEGMENT IGNORE
  330. RETURN
  331. **
  332. ENTRY mPOLRL(NTRSTU,XTR,YTR)
  333. * POLYLINE
  334. write(iups,'(a)') '#'
  335. write(iups,'(a)') '<PolyLine'
  336. if(jpol.eq.0) then
  337. write(iups,'(a)') ' <Pen 0>'
  338. write(iups,'(a)') lfi
  339. write(iups,'(a)') ' <HeadCap Round>'
  340. write(iups,'(a)') ' <TailCap Round>'
  341. write(iups,'(a)') ' <Smoothed No>'
  342. jpol=1
  343. endif
  344. write (IUPS,'(a)')cline(kcoul+1)
  345. write(iups,'(a,i3)') ' <NumPoints ',ntrstu,'>'
  346. do 10 i=1,ntrstu
  347. xmif=coxmif(bornex((xdep+xtr(i))*xrap))
  348. ymif=coymif(borney((ydep+ytr(i))*yrap))
  349. write(iups,'(a,2f8.3,a)') ' <Point ',xmif,ymif,'>'
  350. 10 continue
  351. write(iups,'(a)') '> # end of PolyLine'
  352. c
  353. RETURN
  354. **
  355. ENTRY mTRFAC(NTRSTU,XTR,YTR,ZN,ICOLE,IEFF)
  356. * FACETTE
  357. C+PPf
  358. ZZN=ABS(ZN/XPI*2)
  359. IF (ZZN.GT.0.99999)ZZN=0.99999
  360. IZN=INT(6*ZZN)+1
  361. IZN=ITCODP(IZN)
  362. C+PPf
  363. kcoul=icole
  364. write(iups,'(a)') '#'
  365. write(iups,'(a)') '<Polygon'
  366. C+PPf
  367. write(iups,'(a)') '<Pen 15>'
  368. C+PPf
  369. C PPf if(jpol.eq.0) then
  370. C PPf write(iups,'(a)') '<Pen 0>'
  371. C PPf write(iups,'(a)') lfi
  372. C PPf write(iups,'(a)') '<Smoothed No>'
  373. C PPf endif
  374. C PPf write (IUPS,'(a)')cisov(kcoul+1)
  375. write (IUPS,'(a)')cline(kcoul+1)
  376. C+PPf
  377. write(iups,'(a6,i1,a1)') '<Fill ',IZN,'>'
  378. C+PPf
  379. do 20 i=1,ntrstu
  380. xmif=coxmif(bornex((xdep+xtr(i))*xrap))
  381. ymif=coymif(borney((ydep+ytr(i))*yrap))
  382. write(iups,'(a,2f8.3,a)') '<Point ',xmif,ymif,'>'
  383. 20 continue
  384. write(iups,'(a)') '>'
  385. c
  386. IEFF=1
  387. RETURN
  388. **
  389. ENTRY mTRAIS(NP,XTR,YTR,ICOLE)
  390. * FACETTE
  391. kcoul=icole
  392. write(iups,'(a)') '#'
  393. write(iups,'(a)') '<Polygon'
  394. if(jpol.eq.0) then
  395. write(iups,'(a)') '<Pen 0>'
  396. write(iups,'(a)') lfi
  397. write(iups,'(a)') '<Smoothed No>'
  398. endif
  399. write (IUPS,'(a)')cisov(kcoul+1)
  400. do 30 i=1,np
  401. xmif=coxmif(bornex((xdep+xtr(i))*xrap))
  402. ymif=coymif(borney((ydep+ytr(i))*yrap))
  403. write(iups,'(a,2f8.3,a)') '<Point ',xmif,ymif,'>'
  404. 30 continue
  405. write(iups,'(a)') '>'
  406. c
  407. RETURN
  408. **
  409. ENTRY mTRDIG(XRO,XCOL,ICLE)
  410. * DIGITALISATION DE POINT IGNORE
  411. ICLE=0
  412. RETURN
  413. **
  414. ENTRY mTRAFF(ICLE)
  415. * FIN DE DESSIN
  416. ICLE=0
  417. jpol=0
  418. write(iups,'(a)') ' <Group <ID 1> >'
  419. write(iups,'(a)') ' <Group <ID 100> >'
  420. write(iups,'(a)') ' <Group <ID 101> >'
  421. write(iups,'(a)') ' <Group <ID 102> >'
  422. write(iups,'(a)') ' <Group <ID 103> >'
  423. write(iups,'(a)') ' <Group <ID 104> >'
  424. write(iups,'(a)') ' <Group <ID 105> >'
  425. write(iups,'(a)') ' <Group <ID 106> >'
  426. write(iups,'(a)') ' <Group <ID 107> >'
  427. write(iups,'(a)') ' <Group <ID 201> >'
  428. write(iups,'(a)') ' <Group <ID 202> >'
  429. write(iups,'(a)') ' <Group <ID 203> >'
  430. write(iups,'(a)') ' <Group <ID 204> >'
  431. write(iups,'(a)') ' <Group <ID 205> >'
  432. write(iups,'(a)') ' <Group <ID 206> >'
  433. write(iups,'(a)') ' <Group <ID 207> >'
  434. write(iups,'(a)') ' <Group <ID 208> >'
  435. write(iups,'(a)') ' <Group <ID 209> >'
  436. write(iups,'(a)') ' <Group <ID 210> >'
  437. write(iups,'(a)') ' <Group <ID 211> >'
  438. write(iups,'(a)') ' <Group <ID 212> >'
  439. write(iups,'(a)') ' <Group <ID 213> >'
  440. write(iups,'(a)') ' <Group <ID 214> >'
  441. write(iups,'(a)') ' <Group <ID 215> >'
  442. write(iups,'(a)') ' <Group <ID 216> >'
  443. write(iups,'(a)') '> # End of page'
  444. write(iups,'(a)') '# End of MIFFile'
  445. RETURN
  446. **
  447. ENTRY mMENU(LEGEND,NCASE,LLONG)
  448. * MENU IGNORE
  449. RETURN
  450. **
  451. ENTRY mTRANI(ITYPI,NBIMAH)
  452. * ANIMATION IGNOREE
  453. RETURN
  454. **
  455. ENTRY mTRIMA(IMAGI)
  456. * IMAGE IGNOREE
  457. RETURN
  458. **
  459. ENTRY mFVALI(IFENI,IRESU,NH)
  460. * CHANGEMENT DE VIEW PORT
  461. IF (IFENI.EQ.1) THEN
  462. XRAP=CLX*10/0.95
  463. YRAP=clx*2/0.95
  464. XDEP=(xiocad-10*clx)/xrap
  465. YDEP=0.
  466. ENDIF
  467. NH=31
  468. RETURN
  469. **
  470. ENTRY mZOOM(IZOOM,XMI,XMA,YMI,YMA)
  471. * IGNOREE
  472. RETURN
  473. **
  474. ENTRY mINIt(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA)
  475. * RETOUR AU DESSIN INITIAL IGNORE
  476. RETURN
  477. **
  478. ENTRY mCHANG(IRESU,ISORT,ICHANG,JSEG)
  479. * AFFICHAGE DESAFFICHAGE NUM NOEUDS ELEMENTS QUAL IGNORE
  480. RETURN
  481. **
  482. ENTRY mTRBOX(HAUTX,HAUTY)
  483. * INUTILISE
  484. RETURN
  485. **
  486. ENTRY mTREFF
  487. * INUTILISE
  488. RETURN
  489. **
  490. ENTRY mVAL(IRESU,ISORT,NISO)
  491. * INUTILISE
  492. RETURN
  493. **
  494. ENTRY mMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL)
  495. * INUTILISE
  496. RETURN
  497. **
  498. **
  499. ENTRY mIMPR
  500. * INUTILISE
  501. RETURN
  502. **
  503. ENTRY mTRTIN
  504. * INUTILISE
  505. RETURN
  506. **
  507. ENTRY mFLGI
  508. * INUTILISE
  509. RETURN
  510. **
  511. ENTRY mTRMES(CARAC)
  512. * INUTILISE
  513. RETURN
  514. **
  515. ENTRY mTRGET(PROMPT,REPLY)
  516. * INUTILISE
  517. RETURN
  518. ENTRY mTRMFI
  519. * INUTILISE
  520. RETURN
  521. END
  522.  
  523.  
  524.  
  525.  
  526.  
  527.  
  528.  
  529.  
  530.  
  531.  
  532.  
  533.  

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