Télécharger xtrini.eso

Retour à la liste

Numérotation des lignes :

xtrini
  1. C XTRINI SOURCE FD218221 26/07/06 21:15:15 12578
  2. C INTERFACE POUR XWINDOW
  3. C
  4. C
  5. C
  6. C 1995 option FACE P.PEGON JRC-ISPRA
  7. SUBROUTINE XTRINI(NOL,AXAX,AYAY,TITR,HAUTT,VALEU,NCOUMA)
  8. IMPLICIT INTEGER(I-N)
  9. EXTERNAL LONG
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC CCTRACE
  14. CHARACTER*(18) HEGEND(4)
  15. CHARACTER*(500) LEGEND
  16. CHARACTER*(500) KEGEND
  17. EQUIVALENCE(KEGEND,IEGEND)
  18. EQUIVALENCE(HEGEND,JEGEND)
  19. CHARACTER*(*) TITR,CARAC,PROMPT,REPLY
  20. CHARACTER*80 CHAINE,CHMESS
  21. CHARACTER*(LOCHAI) TITRS
  22. LOGICAL VALEU,FENE,valeus
  23. REAL*8 ROUG(65), VERT(65), BLEU(65)
  24. INTEGER IROUG(65),IVERT(65),IBLEU(65)
  25. DIMENSION XTR(1),YTR(1)
  26. DIMENSION XMAT(3,3)
  27. EQUIVALENCE (CHAINE,ICHAIN)
  28. EQUIVALENCE (CHmess,ICHmes)
  29. save chmess,ichmes,titrs,valeus
  30. SAVE KEGEND,KCASE,KLONG
  31. SAVE mcouma,miso
  32. SAVE iret
  33. SAVE IDEFO
  34. SAVE DESSIN,DESSIC
  35. SAVE NBOPD,NBPD,NBCHRD,LTITRE
  36. SAVE IBOPD,IBPD,IBCHRD
  37. DATA IBOPD,IBPD/0,0/
  38. SEGMENT DESSIN
  39. CHARACTER*(LTITRE) TITRE
  40. LOGICAL VALEUR,FENET
  41. REAL XMIN,XXAX,YMIN,YYAX
  42. REAL OXMIN,OXXAX,OYMIN,OYYAX
  43. INTEGER NBOP,NBP,NBCHR
  44. INTEGER IOPER(NBOPD),IXINFO(2,NBPD)
  45. REAL X(NBPD),Y(NBPD),Z(NBPD)
  46. ENDSEGMENT
  47. *
  48. SEGMENT DESSIC
  49. CHARACTER*(NBCHRD) CARACT
  50. ENDSEGMENT
  51. POINTEUR CESSIN.DESSIN
  52. POINTEUR CESSIC.DESSIC
  53. *
  54. * DECLARATION POUR LGI
  55. DIMENSION Q(20),ICOLT(9)
  56. -INC CCREEL
  57. C+PPf (FACE)
  58. DIMENSION ITCODP(6),ITCODM(6)
  59. DATA ITCODP/3,1,5,4,6,2/
  60. DATA ITCODM/2,6,1,4,3,5/
  61. C+PPf
  62. DATA DESSIN/0/
  63. DATA ICOLT/0,1,2,5,3,6,4,7,8/
  64. DATA HEGEND/' ',
  65. > ' Framemaker ',
  66. > 'PostScript couleur',
  67. > ' PostScript NB '/
  68. DATA MISO/0/
  69. * Pour le lgi verification des bornes
  70. C INITIALISATION
  71. incr=0
  72. chmess=' '
  73. * OUVERTURE XWINDOW
  74. CALL XOPEN(NCOUMA,ICOSC,IOPOLI)
  75. * si ncouma = 0 pas de display on tente le lgi
  76. mcouma=ncouma
  77. TITRS=TITR
  78. LTITRE=LONG(TITRS)
  79. ltitre=72
  80. IF (DESSIN.EQ.0) THEN
  81. NBPD=5000
  82. NBOPD=5000
  83. NBCHRD=5000
  84. SEGINI DESSIN,DESSIC
  85. CALL SAVSEG(DESSIN)
  86. CALL SAVSEG(DESSIC)
  87. ENDIF
  88. TITRS=TITR
  89. valeus=valeu
  90. RETURN
  91. **
  92. C======================================================================
  93. ENTRY XDFENE(XMI,XXA,YMI,YYA,XR1,XR2,YR1,YR2,FENE)
  94. * DEFINITION FENETRE
  95. segact dessin*mod,dessic*mod
  96. * reinitialisation du dessin
  97. if (mcouma.eq.0) return
  98. IBOPD=0
  99. IBPD=0
  100. IBCHRD=0
  101. LTITRE=LONG(TITRS)
  102. NBPD=5000
  103. NBOPD=5000
  104. NBCHRD=5000
  105. SEGADJ DESSIN,DESSIC
  106. NBOP=0
  107. NBCHR=0
  108. NBP=0
  109. TITRE=TITRS
  110. VALEUR=valeus
  111. * DEBUT DE DESSIN
  112. XR1=XMI
  113. XR2=XXA
  114. YR1=YMI
  115. YR2=YYA
  116. FENET=FENE
  117. XMIN=XMI
  118. XXAX=XXA
  119. YMIN=YMI
  120. YYAX=YYA
  121. OXMIN=XMI
  122. OXXAX=XXA
  123. OYMIN=YMI
  124. OYYAX=YYA
  125. RETURN
  126. **
  127. C======================================================================
  128. cbp ENTRY XTRLAB(XT,YT,CARAC,NCARR,HAUT,ipoli)
  129. cbp : ipoli est le 3 eme argument de xopen
  130. c (les 2 premiers étant ncouma et iscreen)
  131. ENTRY XTRLAB(XT,YT,CARAC,NCARR,HAUT,IANGLE)
  132. * ECRITURE TEXT CODE OPERATION 1 1 POINT DES CARACTERES
  133. ncar=long(carac(1:ncarr))
  134. NBOP=NBOP+2
  135. IF (NBOP.GT.NBOPD) THEN
  136. NBOPD=NBOPD+100000
  137. SEGADJ DESSIN
  138. ENDIF
  139. IOPER(NBOP-1)=1
  140. IOPER(NBOP)=NCAR
  141. NBP=NBP+1
  142. IF (NBP.GT.NBPD) THEN
  143. NBPD=NBPD+100000
  144. SEGADJ DESSIN
  145. ENDIF
  146. X(NBP)=XT
  147. Y(NBP)=YT
  148. Z(NBP)=0
  149. cbp: on stocke ANGLE + IALIGN de INFOTR(1 et 2) dans IXINFO
  150. c et on n utilisera pour l instant qu en cas de sortie PS...
  151. IXINFO(1,NBP)=INFOTR(1)
  152. IXINFO(2,NBP)=INFOTR(2)
  153. c if(INFOTR(1).ne.0.or.INFOTR(1).ne.0.) write(6,*)
  154. c &'CARAC=',CARAC(1:NCAR),' IXINFO=',IXINFO(1,NBP),IXINFO(2,NBP)
  155. NBCHR=NBCHR+NCAR
  156. IF (NBCHR.GT.NBCHRD) THEN
  157. NBCHRD=NBCHRD+100000
  158. SEGADJ DESSIC
  159. ENDIF
  160. CARACT(NBCHR-NCAR+1:NBCHR)=CARAC(1:NCAR)
  161. RETURN
  162. **
  163. C======================================================================
  164. ENTRY XCHCOU(JCOLO)
  165. * CHANGEMENT DE COULEUR CODE OPERATION 2 1 ENTIER
  166. NBOP=NBOP+2
  167. IF (NBOP.GT.NBOPD) THEN
  168. NBOPD=NBOPD+100000
  169. SEGADJ DESSIN
  170. ENDIF
  171. IOPER(NBOP-1)=2
  172. IOPER(NBOP)=JCOLO
  173. RETURN
  174. **
  175. C======================================================================
  176. ENTRY XINSEG(JSEG,IRESS)
  177. * CHANGEMENT SEGMENT CODE OPERATION 3 1 ENTIER
  178. segact dessin*mod,dessic*mod
  179. NBOP=NBOP+2
  180. IF (NBOP.GT.NBOPD) THEN
  181. NBOPD=NBOPD+100000
  182. SEGADJ DESSIN
  183. ENDIF
  184. IOPER(NBOP-1)=3
  185. IOPER(NBOP)=JSEG
  186. RETURN
  187. **
  188. C======================================================================
  189. ENTRY XPOLRL(NTRSTU,XTR,YTR)
  190. * POLYLINE CODE OPERATION 4 NBDE POINTS POINTS
  191. NBOP=NBOP+2
  192. IF (NBOP.GT.NBOPD) THEN
  193. NBOPD=NBOPD+100000
  194. SEGADJ DESSIN
  195. ENDIF
  196. IOPER(NBOP-1)=4
  197. IOPER(NBOP)=NTRSTU
  198. NBP=NBP+NTRSTU
  199. IF (NBP.GT.NBPD) THEN
  200. NBPD=NBPD+100000
  201. SEGADJ DESSIN
  202. ENDIF
  203. DO 10 I=1,NTRSTU
  204. X(NBP-NTRSTU+I)=XTR(I)
  205. Y(NBP-NTRSTU+I)=YTR(I)
  206. 10 CONTINUE
  207. RETURN
  208. **
  209. C======================================================================
  210. ENTRY XTRFAC(NTRSTU,XTR,YTR,ZN,ICOLE,IEFF)
  211. * FACETTE CODE OPERATION 5 NBDE POINTS COULEUR POINTS
  212. C PPf NBOP=NBOP+3
  213. NBOP=NBOP+4
  214. IF (NBOP.GT.NBOPD) THEN
  215. NBOPD=NBOPD+100000
  216. SEGADJ DESSIN
  217. ENDIF
  218. C PPf IOPER(NBOP-2)=5
  219. IOPER(NBOP-3)=5
  220. C PPf IOPER(NBOP-1)=NTRSTU
  221. IOPER(NBOP-2)=NTRSTU
  222. C PPf IOPER(NBOP)=ICOLE
  223. IOPER(NBOP-1)=ICOLE
  224. C+PPf
  225. ZZN=ABS(ZN/REAL(XPI)*2)
  226. IF (ZZN.GT.0.99999)ZZN=0.99999
  227. IZN=INT(6*ZZN)+1
  228. IOPER(NBOP)=ITCODP(IZN)
  229. C write (6,*)'ZN, ZZN, IZN, IOPER(NBOP)', ZN, ZZN, IZN, IOPER(NBOP)
  230. C+PPf
  231. NBP=NBP+NTRSTU
  232. IF (NBP.GT.NBPD) THEN
  233. NBPD=NBPD+100000
  234. SEGADJ DESSIN
  235. ENDIF
  236. DO 20 I=1,NTRSTU
  237. X(NBP-NTRSTU+I)=XTR(I)
  238. Y(NBP-NTRSTU+I)=YTR(I)
  239. Z(NBP-NTRSTU+I)=0
  240. 20 CONTINUE
  241. IEFF=1
  242. * IEFF=0 signifie qu'on ne met pas en noir les traits (cas des iso
  243. RETURN
  244. **
  245. C======================================================================
  246. ENTRY XTRAIS(NP,XTR,YTR,ICOLE)
  247. * FACETTE CODE OPERATION 6 NBDE POINTS POINTS
  248. NBOP=NBOP+3
  249. IF (NBOP.GT.NBOPD) THEN
  250. NBOPD=NBOPD+100000
  251. SEGADJ DESSIN
  252. ENDIF
  253. IOPER(NBOP-2)=6
  254. IOPER(NBOP-1)=NP
  255. IOPER(NBOP)=ICOLE
  256. NBP=NBP+NP
  257. IF (NBP.GT.NBPD) THEN
  258. NBPD=NBPD+100000
  259. SEGADJ DESSIN
  260. ENDIF
  261. DO 30 I=1,NP
  262. X(NBP-NP+I)=XTR(I)
  263. Y(NBP-NP+I)=YTR(I)
  264. Z(NBP-NP+I)=0
  265. 30 CONTINUE
  266. RETURN
  267. **
  268. C======================================================================
  269. * AFFICHAGE DU DESSIN ATTENTE D'EVENEMENT
  270. C======================================================================
  271. ENTRY XTRDIG(XRO,XCOL,ICLE)
  272. segact dessin*mod,dessic*mod
  273. ICLE=0
  274. IRDIG=1
  275. GOTO 35
  276. ENTRY XTRAFF(ICLE)
  277. SEGACT DESSIN,DESSIC
  278. ICLE=0
  279. IRDIG=0
  280. 35 CONTINUE
  281. * AFFICHAGE DU DESSIN ATTENTE D'EVENEMENT
  282. IDAFF=0
  283. ITYP=0
  284. 250 CONTINUE
  285. IBOP=IBOPD
  286. IBP=IBPD
  287. IBCHR=IBCHRD
  288. IF (IBOPD.EQ.0) THEN
  289. CHAINE(1:LTITRE)=TITRE(1:LTITRE)
  290. C Calcul des couleurs depuis la palette
  291. IF (MISO.LE.15) THEN
  292. CALL PALET2(IPALET,15,ROUG,VERT,BLEU)
  293. ELSE
  294. CALL PALET2(IPALET,(MISO+1),ROUG,VERT,BLEU)
  295. ENDIF
  296. C Conversion des codes RGB normalises [0. 1.] en 16 bits entiers [0 65535]
  297. C avec protection contre les debordements
  298. DO I=1,MAX((MISO+1),15)
  299. IROUG(I)=INT(MIN(MAX(ROUG(I),0.D0),1.D0)*65535.D0 + 0.5D0)
  300. IVERT(I)=INT(MIN(MAX(VERT(I),0.D0),1.D0)*65535.D0 + 0.5D0)
  301. IBLEU(I)=INT(MIN(MAX(BLEU(I),0.D0),1.D0)*65535.D0 + 0.5D0)
  302. ENDDO
  303. CALL XRINIT(ICHAIN,VALEUR,LTITRE,MISO,IROUG,IVERT,IBLEU)
  304. ENDIF
  305. CALL XFENET(XMIN,XXAX,YMIN,YYAX,FENET)
  306. 99 CONTINUE
  307. 100 CONTINUE
  308. IBOP=IBOP+1
  309. IF (IBOP.GT.NBOP) GOTO 200
  310. ICOD=IOPER(IBOP)
  311. IF (ICOD.EQ.1) THEN
  312. IBOP=IBOP+1
  313. NBCAR=IOPER(IBOP)
  314. IBP=IBP+1
  315. CHAINE(1:NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR)
  316. CALL XRLABL(X(IBP),Y(IBP),ICHAIN,NBCAR)
  317. IBCHR=IBCHR+NBCAR
  318. ELSEIF (ICOD.EQ.2) THEN
  319. IBOP=IBOP+1
  320. ICOUL=IOPER(IBOP)
  321. CALL XHCOUL(ICOUL)
  322. ELSEIF (ICOD.EQ.3) THEN
  323. * OUVERTURE SEGMENT
  324. IBOP=IBOP+1
  325. ELSEIF (ICOD.EQ.4) THEN
  326. IBOP=IBOP+1
  327. N=IOPER(IBOP)
  328. CALL XOLRL(N,X(IBP+1),Y(IBP+1))
  329. IBP=IBP+N
  330. ELSEIF (ICOD.EQ.5) THEN
  331. IBOP=IBOP+1
  332. N=IOPER(IBOP)
  333. IBOP=IBOP+1
  334. ICOL=IOPER(IBOP)
  335. CALL XHCOUL(ICOL)
  336. C+PPf
  337. IBOP=IBOP+1
  338. IZN=IOPER(IBOP)
  339. C+PPf
  340. C PPf CALL XRFACE(N,X(IBP+1),Y(IBP+1))
  341. CALL XRFACE(N,X(IBP+1),Y(IBP+1),IZN)
  342. IBP=IBP+N
  343. ELSEIF (ICOD.EQ.6) THEN
  344. IBOP=IBOP+1
  345. N=IOPER(IBOP)
  346. IBOP=IBOP+1
  347. ICO=IOPER(IBOP)
  348. if (ico.gt.1000.or.ico.lt.0) then
  349. * write (6,*) '1 - ico incorrect ',ico
  350. ico=0
  351. endif
  352. C palette des iso
  353. if (mcouma.ge.16) ico=ico+100
  354. CALL XHCOUL(ICO)
  355. if (N.GT.2) CALL XRAISO(N,X(IBP+1),Y(IBP+1))
  356. if (N.EQ.2) CALL XOLRL(N,X(IBP+1),Y(IBP+1))
  357. IBP=IBP+N
  358. ELSEIF (ICOD.EQ.7) THEN
  359. IBOP=IBOP+1
  360. IFENJ=IOPER(IBOP)
  361. CALL XVALIS(IFENJ,IRESV,NHH)
  362. ELSEIF (ICOD.EQ.8) THEN
  363. * menu en blanc
  364. CALL XHCOUL(7)
  365. CALL XENU(IEGEND,KCASE,KLONG)
  366. ELSEIF (ICOD.EQ.9) THEN
  367. IBOP=IBOP+1
  368. IMAG=IOPER(IBOP)
  369. CALL XRIMAG(IMAG)
  370. ELSEIF (ICOD.EQ.10) THEN
  371. IBOP=IBOP+1
  372. ITYP=IOPER(IBOP)
  373. IBOP=IBOP+1
  374. NBIMAG=IOPER(IBOP)
  375. CALL XRANIM(ITYP,NBIMAG)
  376. *** CALL XRSWAP(IRET)
  377. ELSEIF (ICOD.EQ.11) THEN
  378. * menu en blanc
  379. If(icosc.eq.1) then
  380. CALL XHCOUL(7)
  381. else
  382. CALL XHCOUL(0)
  383. endif
  384. ENDIF
  385. GOTO 100
  386. 200 CONTINUE
  387. IBPD=IBP
  388. IBOPD=IBOP-1
  389. IBCHRD=IBCHR
  390. * cas animation et affichage initial. on swappe pour voir qqchose
  391. ** IF (ITYP.GT.0.and.iret.eq.0) CALL XRSWAP(IRET)
  392. iret=0
  393. ICLE=-2
  394. * on affiche un message eventuel
  395. if (chmess.ne.' ') then
  396. nbcar=long(chmess)
  397. CALL XVALIS(3,IRESV,NHH)
  398. CALL XHCOUL(7)
  399. CALL XRLABL(0.,0.,ICHmes,NBCAR)
  400. endif
  401. CALL XRAFF(YRO,YCOL,IRDIG,ICLE)
  402. IF (IRDIG.EQ.1) THEN
  403. XRO=YRO
  404. XCOL=YCOL
  405. ENDIF
  406. * reaffichage
  407. IF (ICLE.EQ.-1) THEN
  408. IBPD=0
  409. IBOPD=0
  410. IBCHRD=0
  411. GOTO 250
  412. ENDIF
  413. * on invalide le message eventuel
  414. chmess=' '
  415. * CLE INACTIVE
  416. IF (ICLE.GE.0) THEN
  417. IF (KEGEND(ICLE*KLONG+1:(ICLE+1)*KLONG).EQ.' ') ICLE=-2
  418. IF(KEGEND(1+ICLE*KLONG+(klong-8)/2:
  419. # (ICLE+1)*KLONG).EQ.'Softcopy') GOTO 700
  420. ENDIF
  421. ** IF (ICLE.EQ.7.AND.KCASE.EQ.9) THEN
  422. iou=9
  423. ipuo=1+klong*(iou-1)
  424. * write(6,*) Kegend(IPUO:IPUO+10)
  425. * write(6,*)' icle ' , icle
  426. ipuo=1+klong*(iou-1)
  427. IF(ICLE.EQ.8.AND.Kegend(ipuo:ipuo+10).eq.' Animation')
  428. $ THEN
  429. * write(6,*) ' on tente lanimation '
  430. * ANIMATION
  431. IDES=0
  432. INCR=1
  433. 310 CONTINUE
  434. IDES=IDES+INCR
  435. IF (IDES.EQ.NBIMAG) INCR=-1
  436. IF (IDES.EQ.1) INCR= 1
  437. IBOP=0
  438. IBP=0
  439. IBCHR=0
  440. ITRAC=0
  441. CALL XFENET(XMIN,XXAX,YMIN,YYAX,FENET)
  442. 301 CONTINUE
  443. IBOP=IBOP+1
  444. IF (IBOP.GT.NBOP) GOTO 302
  445. ICOD=IOPER(IBOP)
  446. IF (ICOD.EQ.1) THEN
  447. IBOP=IBOP+1
  448. NBCAR=IOPER(IBOP)
  449. IBP=IBP+1
  450. CHAINE(1:NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR)
  451. IF (ITRAC.NE.0) CALL XRLABL(X(IBP),Y(IBP),ICHAIN,NBCAR)
  452. IBCHR=IBCHR+NBCAR
  453. ELSEIF (ICOD.EQ.2) THEN
  454. IBOP=IBOP+1
  455. ICOUL=IOPER(IBOP)
  456. IF (ITRAC.NE.0) CALL XHCOUL(ICOUL)
  457. ELSEIF (ICOD.EQ.3) THEN
  458. * OUVERTURE SEGMENT
  459. IBOP=IBOP+1
  460. ELSEIF (ICOD.EQ.4) THEN
  461. IBOP=IBOP+1
  462. N=IOPER(IBOP)
  463. IF (ITRAC.NE.0) CALL XOLRL(N,X(IBP+1),Y(IBP+1))
  464. IBP=IBP+N
  465. ELSEIF (ICOD.EQ.5) THEN
  466. IBOP=IBOP+1
  467. N=IOPER(IBOP)
  468. IBOP=IBOP+1
  469. ICOL=IOPER(IBOP)
  470. C+PPf
  471. IBOP=IBOP+1
  472. C+PPf
  473. IF (ITRAC.NE.0) THEN
  474. CALL XHCOUL(ICOL)
  475. C+PPf
  476. IZN=IOPER(IBOP)
  477. C+PPf
  478. C PPf CALL XRFACE(N,X(IBP+1),Y(IBP+1))
  479. CALL XRFACE(N,X(IBP+1),Y(IBP+1),IZN)
  480. ENDIF
  481. IBP=IBP+N
  482. ELSEIF (ICOD.EQ.6) THEN
  483. IBOP=IBOP+1
  484. N=IOPER(IBOP)
  485. IBOP=IBOP+1
  486. ICO=IOPER(IBOP)
  487. if (ico.gt.1000.or.ico.lt.0) then
  488. * write (6,*) '2 - ico incorrect ',ico
  489. ico=0
  490. endif
  491. if (mcouma.ge.16) ico=ico+100
  492. IF (ITRAC.NE.0) THEN
  493. CALL XHCOUL(ICO)
  494. if (N.GT.2) CALL XRAISO(N,X(IBP+1),Y(IBP+1))
  495. if (N.EQ.2) CALL XOLRL(N,X(IBP+1),Y(IBP+1))
  496. ENDIF
  497. IBP=IBP+N
  498. ELSEIF (ICOD.EQ.7) THEN
  499. IBOP=IBOP+1
  500. IFENJ=IOPER(IBOP)
  501. IF (ITRAC.NE.0) CALL XVALIS(IFENJ,IRESV,NHH)
  502. ELSEIF (ICOD.EQ.8) THEN
  503. ELSEIF (ICOD.EQ.9) THEN
  504. IBOP=IBOP+1
  505. IMAG=IOPER(IBOP)
  506. IF (IDES.EQ.IMAG) ITRAC=1
  507. IF (IDES.NE.IMAG) ITRAC=0
  508. ELSEIF (ICOD.EQ.10) THEN
  509. IBOP=IBOP+1
  510. ITYP=IOPER(IBOP)
  511. IBOP=IBOP+1
  512. NBIMAG=IOPER(IBOP)
  513. ELSEIF (ICOD.EQ.11) THEN
  514. ENDIF
  515. GOTO 301
  516. 302 CONTINUE
  517. CALL XRSWAP(IRET)
  518. IF (IRET.EQ.0.AND.(ITYP.NE.1.OR.INCR.EQ.1)) GOTO 310
  519. CALL XENU(IEGEND,KCASE,KLONG)
  520. GOTO 250
  521. ENDIF
  522. if (irdig.eq.0) SEGDES DESSIN,DESSIC
  523. RETURN
  524. 700 CONTINUE
  525. * on propose le choix de la softcopie
  526. CALL XHCOUL(7)
  527. CALL XENU(JEGEND,4,18)
  528. CALL XRAFF(YRO,YCOL,IRDIG,ICLE)
  529. if (icle.le.0) goto 700
  530. icle=icle+1
  531. * on signale qu'on a compris l'instruction
  532. CALL XVALIS(3,IRESV,NHH)
  533. CALL XHCOUL(0)
  534. chaine='Softcopie '//hegend(icle)
  535. > (1:long(hegend(icle)))//' effectuee'
  536. CALL XRLABL(0.,0.,ICHAIN,80)
  537. * on repositionne le menu
  538. CALL XENU(IEGEND,KCASE,KLONG)
  539. C---------------------------------------------------
  540. * impression du dessin (Softcopy)
  541. * on reboucle sur la structure du trace
  542. IDAFF=0
  543. ITYP=0
  544. 750 CONTINUE
  545. IBOP=0
  546. IBP=0
  547. IBCHR=0
  548. CHAINE=TITRE(1:LTITRE)
  549. if (icle.eq.4) then
  550. CALL strini(24,axax,ayay,chaine(1:ltitre),1.5,.true.,ncoumb)
  551. CALL sdfene(XMIN,XXAX,YMIN,YYAX,XXR1,XXR2,YYR1,YYR2,FENET)
  552. CALL sfvali(0,iresv,nhh,MISO)
  553. elseif (icle.eq.3) then
  554. CALL ctrini(24,axax,ayay,chaine(1:ltitre),1.5,.true.,ncoumb)
  555. CALL cdfene(XMIN,XXAX,YMIN,YYAX,XXR1,XXR2,YYR1,YYR2,FENET)
  556. CALL cfvali(0,iresv,nhh,MISO)
  557. elseif (icle.eq.2) then
  558. CALL mtrini(24,axax,ayay,chaine,1.5,.true.,ncoumb)
  559. CALL mdfene(XMIN,XXAX,YMIN,YYAX,XXR1,XXR2,YYR1,YYR2,FENET)
  560. endif
  561. c boucle sur le objets IBOP
  562. 760 CONTINUE
  563. IBOP=IBOP+1
  564. IF (IBOP.GT.NBOP) then
  565. if (icle.eq.4) then
  566. call straff(ibid)
  567. elseif (icle.eq.3) then
  568. call ctraff(ibid)
  569. elseif (icle.eq.2) then
  570. call mtraff(ibid)
  571. endif
  572. GOTO 200
  573. endif
  574. ICOD=IOPER(IBOP)
  575. c il s'agit d un label
  576. IF (ICOD.EQ.1) THEN
  577. IBOP=IBOP+1
  578. NBCAR=IOPER(IBOP)
  579. IBP=IBP+1
  580. CHAINE(1:NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR)
  581. INFOTR(1)=IXINFO(1,IBP)
  582. INFOTR(2)=IXINFO(2,IBP)
  583. if (icle.eq.4) then
  584. CALL strlab(X(IBP),Y(IBP),CHAINE,NBCAR,0.15)
  585. elseif (icle.eq.3) then
  586. CALL ctrlab(X(IBP),Y(IBP),CHAINE,NBCAR,0.15)
  587. elseif (icle.eq.2) then
  588. CALL mtrlab(X(IBP),Y(IBP),CHAINE,NBCAR,0.15)
  589. endif
  590. INFOTR(1)=0
  591. INFOTR(2)=0
  592. IBCHR=IBCHR+NBCAR
  593. c il s'agit d une couleur
  594. ELSEIF (ICOD.EQ.2) THEN
  595. IBOP=IBOP+1
  596. ICOUL=IOPER(IBOP)
  597. if (icle.eq.4) then
  598. CALL schcou(ICOUL)
  599. elseif (icle.eq.3) then
  600. CALL cchcou(ICOUL)
  601. elseif (icle.eq.2) then
  602. CALL mchcou(ICOUL)
  603. endif
  604. ELSEIF (ICOD.EQ.3) THEN
  605. * OUVERTURE SEGMENT
  606. IBOP=IBOP+1
  607. ELSEIF (ICOD.EQ.4) THEN
  608. IBOP=IBOP+1
  609. N=IOPER(IBOP)
  610. if (icle.eq.4) then
  611. CALL spolrl(N,X(IBP+1),Y(IBP+1))
  612. elseif (icle.eq.3) then
  613. CALL cpolrl(N,X(IBP+1),Y(IBP+1))
  614. elseif (icle.eq.2) then
  615. CALL mpolrl(N,X(IBP+1),Y(IBP+1))
  616. endif
  617. IBP=IBP+N
  618. ELSEIF (ICOD.EQ.5) THEN
  619. IBOP=IBOP+1
  620. N=IOPER(IBOP)
  621. IBOP=IBOP+1
  622. ICOL=IOPER(IBOP)
  623. if (icle.eq.4) then
  624. CALL strfac(N,X(IBP+1),Y(IBP+1),Z(IBP+1),icol,ibid)
  625. elseif (icle.eq.3) then
  626. CALL ctrfac(N,X(IBP+1),Y(IBP+1),Z(IBP+1),icol,ibid)
  627. elseif (icle.eq.2) then
  628. C+PPf
  629. IZN=IOPER(IBOP+1)
  630. IZN=ITCODM(IZN)
  631. ZZN=(IZN-0.99999)*REAL(XPI)/12
  632. C+PPf
  633. C PPf CALL mtrfac(N,X(IBP+1),Y(IBP+1),Z(IBP+1),icol,ibid)
  634. CALL mtrfac(N,X(IBP+1),Y(IBP+1),ZZN,icol,ibid)
  635. endif
  636. C+PPf
  637. IBOP=IBOP+1
  638. C+PPf
  639. IBP=IBP+N
  640. ELSEIF (ICOD.EQ.6) THEN
  641. IBOP=IBOP+1
  642. N=IOPER(IBOP)
  643. IBOP=IBOP+1
  644. ICO=IOPER(IBOP)
  645. if (icle.eq.4) then
  646. CALL strais(N,X(IBP+1),Y(IBP+1),ico)
  647. elseif (icle.eq.3) then
  648. CALL ctrais(N,X(IBP+1),Y(IBP+1),ico)
  649. elseif (icle.eq.2) then
  650. CALL mtrais(N,X(IBP+1),Y(IBP+1),ico)
  651. endif
  652. IBP=IBP+N
  653. ELSEIF (ICOD.EQ.7) THEN
  654. IBOP=IBOP+1
  655. IFENJ=IOPER(IBOP)
  656. if (icle.eq.4) then
  657. CALL sfvali(IFENJ,IRESV,NHH,miso)
  658. elseif (icle.eq.3) then
  659. CALL cfvali(IFENJ,IRESV,NHH,miso)
  660. elseif (icle.eq.2) then
  661. CALL mfvali(IFENJ,IRESV,NHH)
  662. endif
  663. ELSEIF (ICOD.EQ.8) THEN
  664. * pas de menu
  665. ELSEIF (ICOD.EQ.9) THEN
  666. * pas de nouvelle image
  667. IBOP=IBOP+1
  668. ELSEIF (ICOD.EQ.10) THEN
  669. IBOP=IBOP+1
  670. ITYP=IOPER(IBOP)
  671. IBOP=IBOP+1
  672. NBIMAG=IOPER(IBOP)
  673. ELSEIF (ICOD.EQ.11) THEN
  674. * menu en blanc
  675. ENDIF
  676. goto 760
  677.  
  678.  
  679. **
  680. C======================================================================
  681. ENTRY XMENU(LEGEND,NCASE,LLONG)
  682. *
  683. * MENU on sauve le contenu
  684. *
  685. segact dessin*mod,dessic*mod
  686. KCASE=NCASE
  687. KLONG=LLONG
  688.  
  689. KEGEND(1:KLONG*KCASE)=LEGEND(1:KLONG*KCASE)
  690. * on rajoute une touche PS (certains cas seront a exclure)
  691. kcase=kcase+1
  692. KEGEND(1+KLONG*(kcase-1):KLONG*kcase)=' '
  693. KEGEND(1+KLONG*(kcase-1)+(klong-8)/2:KLONG*kcase)='Softcopy'
  694. C#MC 05/01/99 utilite ? IDEFOR inconuu...
  695. C IDEFO=IDEFOR
  696. * ON SE MET DANS LE SEGMENT 0
  697. * CHANGEMENT SEGMENT CODE OPERATION 3 1 ENTIER
  698. NBOP=NBOP+2
  699. IF (NBOP.GT.NBOPD) THEN
  700. NBOPD=NBOPD+100000
  701. SEGADJ DESSIN
  702. ENDIF
  703. IOPER(NBOP-1)=3
  704. IOPER(NBOP)=0
  705. NBOP=NBOP+1
  706. IF (NBOP.GT.NBOPD) THEN
  707. NBOPD=NBOPD+100000
  708. SEGADJ DESSIN
  709. ENDIF
  710. IOPER(NBOP)=8
  711. RETURN
  712. **
  713. ENTRY XTRANI(ITYPI,NBIMAH)
  714. NBOP=NBOP+3
  715. IF (NBOP.GT.NBOPD) THEN
  716. NBOPD=NBOPD+100000
  717. SEGADJ DESSIN
  718. ENDIF
  719. IOPER(NBOP-2)=10
  720. IOPER(NBOP-1)=ITYPI
  721. IOPER(NBOP)=NBIMAH
  722. RETURN
  723. **
  724. ENTRY XTRIMA(IMAGI)
  725. NBOP=NBOP+2
  726. IF (NBOP.GT.NBOPD) THEN
  727. NBOPD=NBOPD+100000
  728. SEGADJ DESSIN
  729. ENDIF
  730. IOPER(NBOP-1)=9
  731. IOPER(NBOP)=IMAGI
  732. RETURN
  733. **
  734. ENTRY XFVALI(IFENI,IRESU,NH,NISO)
  735. segact dessin*mod,dessic*mod
  736. * sauver le nb d'iso
  737. MISO=NISO
  738. * CHANGEMENT DE VIEW PORT
  739. IF (IFENI.EQ.1) THEN
  740. NBOP=NBOP+2
  741. IF (NBOP.GT.NBOPD) THEN
  742. NBOPD=NBOPD+100000
  743. SEGADJ DESSIN
  744. ENDIF
  745. IOPER(NBOP-1)=7
  746. IOPER(NBOP)=IFENI
  747. ENDIF
  748. NH=31
  749. RETURN
  750. **
  751. C======================================================================
  752. ENTRY XZOOM(IZOOM,XMI,XMA,YMI,YMA)
  753. * mise à jour du cadre
  754. * IZOOM=1 zoom
  755. * IZOOM=-1 zoom inverse
  756. * IZOOM=0 pan
  757. segact dessin*mod,dessic*mod
  758. if (izoom.eq.1) then
  759. XMIN=XMI
  760. XXAX=XMA
  761. YMIN=YMI
  762. YYAX=YMA
  763. endif
  764. if (izoom.eq.-1) then
  765. AXMIN=XMIN-(XMI-XMIN)*(XXAX-XMIN)/(XMA-XMI)
  766. AXXAX=AXMIN+(XXAX-XMIN)*(XXAX-XMIN)/(XMA-XMI)
  767. XMIN=AXMIN
  768. XXAX=AXXAX
  769. AYMIN=YMIN-(YMI-YMIN)*(YYAX-YMIN)/(YMA-YMI)
  770. AYYAX=AYMIN+(YYAX-YMIN)*(YYAX-YMIN)/(YMA-YMI)
  771. YMIN=AYMIN
  772. YYAX=AYYAX
  773. endif
  774. if (izoom.eq.0) then
  775. XMIN=XMIN-(XMA-XMI)
  776. XXAX=XXAX-(XMA-XMI)
  777. YMIN=YMIN-(YMA-YMI)
  778. YYAX=YYAX-(YMA-YMI)
  779. endif
  780. XMI=OXMIN
  781. XMA=OXXAX
  782. YMI=OYMIN
  783. YMA=OYYAX
  784. IBPD=0
  785. IBOPD=0
  786. IBCHRD=0
  787. RETURN
  788. **
  789. C======================================================================
  790. ENTRY XINI(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA)
  791. * RETOUR AU DESSIN INITIAL
  792. segact dessin*mod,dessic*mod
  793. XMIN=OXMIN
  794. XXAX=OXXAX
  795. YMIN=OYMIN
  796. YYAX=OYYAX
  797. ISORT=0
  798. IRESU=2
  799. IBPD=0
  800. IBOPD=0
  801. IBCHRD=0
  802. RETURN
  803. **
  804. C======================================================================
  805. ENTRY XCHANG(IRESU,ISORT,ICHANG,JSEG)
  806. segact dessin*mod,dessic*mod
  807. IDSGT=0
  808. * affichage desaffichage num noeuds elements qual
  809. IF (ICHANG.EQ.1) THEN
  810. IBON=1
  811. IBOP=0
  812. IBCHR=0
  813. IBP=0
  814. JBOP=0
  815. JBCHR=0
  816. JBP=0
  817. 300 CONTINUE
  818. IBOP=IBOP+1
  819. IF (IBOP.GT.NBOP) GOTO 350
  820. ICOD=IOPER(IBOP)
  821. IF (IBON.EQ.1) THEN
  822. JBOP=JBOP+1
  823. IOPER(JBOP)=IOPER(IBOP)
  824. IF (ICOD.EQ.1) THEN
  825. * xrlabl
  826. IBOP=IBOP+1
  827. JBOP=JBOP+1
  828. IOPER(JBOP)=IOPER(IBOP)
  829. NBCAR=IOPER(IBOP)
  830. CARACT(JBCHR+1:JBCHR+NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR)
  831. IBCHR=IBCHR+NBCAR
  832. JBCHR=JBCHR+NBCAR
  833. IBP=IBP+1
  834. JBP=JBP+1
  835. X(JBP)=X(IBP)
  836. Y(JBP)=Y(IBP)
  837. Z(JBP)=Z(IBP)
  838. ELSEIF (ICOD.EQ.2) THEN
  839. * chcoul
  840. IBOP=IBOP+1
  841. JBOP=JBOP+1
  842. IOPER(JBOP)=IOPER(IBOP)
  843. ELSEIF (ICOD.EQ.3) THEN
  844. * OUVERTURE SEGMENT
  845. IBOP=IBOP+1
  846. IF (IOPER(IBOP).EQ.JSEG) THEN
  847. IBON=0
  848. * IL FAUDRA REPRENDRE LE DESSIN AU DEBUT
  849. IBOPD=0
  850. IBPD=0
  851. IBCHRD=0
  852. * ON NE STOCKE PAS CE CHANGEMENT DE SEGMENT
  853. JBOP=JBOP-1
  854. GOTO 300
  855. ELSE
  856. JBOP=JBOP+1
  857. IOPER(JBOP)=IOPER(IBOP)
  858. ENDIF
  859. ELSEIF (ICOD.EQ.4) THEN
  860. * polyline
  861. IBOP=IBOP+1
  862. JBOP=JBOP+1
  863. IOPER(JBOP)=IOPER(IBOP)
  864. N=IOPER(IBOP)
  865. DO 305 IIP=1,N
  866. IBP=IBP+1
  867. JBP=JBP+1
  868. X(JBP)=X(IBP)
  869. Y(JBP)=Y(IBP)
  870. Z(JBP)=Z(IBP)
  871. 305 CONTINUE
  872. ELSEIF (ICOD.EQ.5) THEN
  873. * face
  874. IBOP=IBOP+1
  875. JBOP=JBOP+1
  876. IOPER(JBOP)=IOPER(IBOP)
  877. N=IOPER(IBOP)
  878. IBOP=IBOP+1
  879. JBOP=JBOP+1
  880. IOPER(JBOP)=IOPER(IBOP)
  881. DO 307 IIP=1,N
  882. IBP=IBP+1
  883. JBP=JBP+1
  884. X(JBP)=X(IBP)
  885. Y(JBP)=Y(IBP)
  886. Z(JBP)=Z(IBP)
  887. 307 CONTINUE
  888. C+PPf
  889. IBOP=IBOP+1
  890. JBOP=JBOP+1
  891. IOPER(JBOP)=IOPER(IBOP)
  892. C+PPf
  893. ELSEIF (ICOD.EQ.6) THEN
  894. * iso
  895. IBOP=IBOP+1
  896. JBOP=JBOP+1
  897. IOPER(JBOP)=IOPER(IBOP)
  898. N=IOPER(IBOP)
  899. IBOP=IBOP+1
  900. JBOP=JBOP+1
  901. IOPER(JBOP)=IOPER(IBOP)
  902. DO 309 IIP=1,N
  903. IBP=IBP+1
  904. JBP=JBP+1
  905. X(JBP)=X(IBP)
  906. Y(JBP)=Y(IBP)
  907. Z(JBP)=Z(IBP)
  908. IOPER(JBOP)=IOPER(IBOP)
  909. 309 CONTINUE
  910. ELSEIF (ICOD.EQ.7) THEN
  911. * fvalis
  912. IBOP=IBOP+1
  913. JBOP=JBOP+1
  914. IOPER(JBOP)=IOPER(IBOP)
  915. ELSEIF (ICOD.EQ.8) THEN
  916. * menu
  917. ELSEIF (ICOD.EQ.9) THEN
  918. * changement image
  919. IBOP=IBOP+1
  920. JBOP=JBOP+1
  921. IOPER(JBOP)=IOPER(IBOP)
  922. ELSEIF (ICOD.EQ.10) THEN
  923. * initialisation animation
  924. IBOP=IBOP+2
  925. JBOP=JBOP+2
  926. IOPER(JBOP)=IOPER(IBOP)
  927. ELSEIF (ICOD.EQ.11) THEN
  928. ENDIF
  929. ELSE
  930. IF (ICOD.EQ.1) THEN
  931. * xrlabl
  932. IBOP=IBOP+1
  933. NBCAR=IOPER(IBOP)
  934. IBCHR=IBCHR+NBCAR
  935. IBP=IBP+1
  936. ELSEIF (ICOD.EQ.2) THEN
  937. * chcoul
  938. IBOP=IBOP+1
  939. ELSEIF (ICOD.EQ.3) THEN
  940. * OUVERTURE SEGMENT ON REVIENT EN TETE
  941. IBOP=IBOP-1
  942. IBON=1
  943. GOTO 300
  944. ELSEIF (ICOD.EQ.4) THEN
  945. * polyline
  946. IBOP=IBOP+1
  947. N=IOPER(IBOP)
  948. IBP=IBP+N
  949. ELSEIF (ICOD.EQ.5) THEN
  950. * face
  951. IBOP=IBOP+1
  952. N=IOPER(IBOP)
  953. IBOP=IBOP+1
  954. C+PPf
  955. IBOP=IBOP+1
  956. C+PPf
  957. IBP=IBP+N
  958. ELSEIF (ICOD.EQ.6) THEN
  959. * iso
  960. IBOP=IBOP+1
  961. N=IOPER(IBOP)
  962. IBOP=IBOP+1
  963. IBP=IBP+N
  964. ELSEIF (ICOD.EQ.7) THEN
  965. * fvalis
  966. IBOP=IBOP+1
  967. ELSEIF (ICOD.EQ.8) THEN
  968. * menu
  969. ELSEIF (ICOD.EQ.9) THEN
  970. * changement image
  971. IBOP=IBOP+1
  972. ELSEIF (ICOD.EQ.10) THEN
  973. * initialisation animation
  974. IBOP=IBOP+2
  975. ELSEIF (ICOD.EQ.11) THEN
  976. ENDIF
  977. ENDIF
  978. GOTO 300
  979. 350 CONTINUE
  980. NBOP=JBOP
  981. NBP=JBP
  982. NBCHR=JBCHR
  983. ICHANG=0
  984. ISORT=0
  985. RETURN
  986. ELSE
  987. ISORT=1
  988. IRESU=JSEG
  989. ICHANG=1
  990. RETURN
  991. ENDIF
  992. **
  993. C======================================================================
  994. ENTRY XTRBOX(HAUTX,HAUTY)
  995. * INUTILISE
  996. RETURN
  997. **
  998. C======================================================================
  999. ENTRY XTREFF
  1000. * INUTILISE
  1001. RETURN
  1002. **
  1003. C======================================================================
  1004. ENTRY XVAL(IRESU,ISORT,ISO)
  1005. C#MC IF (ISO.NE.0.AND.IDEFO.EQ.0) THEN
  1006. IF (ISO.NE.0) THEN
  1007. IRESU=10
  1008. ISORT=1
  1009. ENDIF
  1010. RETURN
  1011. **
  1012. C======================================================================
  1013. ENTRY XMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL)
  1014. * INUTILISE
  1015. RETURN
  1016. **
  1017. **
  1018. C======================================================================
  1019. ENTRY XIMPR
  1020. * INUTILISE
  1021. RETURN
  1022. **
  1023. C======================================================================
  1024. ENTRY XTRTIN
  1025. * INUTILISE
  1026. RETURN
  1027. **
  1028. C======================================================================
  1029. ENTRY XFLGI
  1030. * INUTILISE
  1031. RETURN
  1032. **
  1033. C======================================================================
  1034. ENTRY XTRMFI
  1035. * INUTILISE
  1036. RETURN
  1037. **
  1038. C======================================================================
  1039. ENTRY XTRMES(CARAC)
  1040. CHMESS=CARAC
  1041. RETURN
  1042. **
  1043. C======================================================================
  1044. ENTRY XTRGET(PROMPT,REPLY)
  1045. segact dessin*mod,dessic*mod
  1046. LPROMP=LONG(PROMPT)
  1047. LREPLY=LONG(REPLY)
  1048. CHAINE=PROMPT
  1049. CALL XVALIS(3,IRESV,NHH)
  1050. IF(icosc.eq.1) then
  1051. ico1=7
  1052. else
  1053. ico1=8
  1054. endif
  1055. CALL XHCOUL(ico1)
  1056. CALL XRGET(ICHAIN,LPROMP,ICHAIN,LREPLY)
  1057. REPLY=' '
  1058. IF (LREPLY.NE.0) REPLY=CHAINE(1:LREPLY)
  1059. RETURN
  1060. **
  1061. C======================================================================
  1062. ENTRY XRCLIK(KCLICK)
  1063. CALL XCLIK(KCLICK)
  1064. END
  1065.  
  1066.  
  1067.  
  1068.  
  1069.  
  1070.  
  1071.  
  1072.  
  1073.  
  1074.  
  1075.  
  1076.  
  1077.  
  1078.  
  1079.  
  1080.  
  1081.  
  1082.  
  1083.  
  1084.  
  1085.  

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