Télécharger mtrini.eso

Retour à la liste

Numérotation des lignes :

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

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