Télécharger xtrini.eso

Retour à la liste

Numérotation des lignes :

xtrini
  1. C XTRINI SOURCE GOUNAND 26/07/30 21:15:10 12611
  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. KEGEND(1:KLONG*KCASE)=LEGEND(1:KLONG*KCASE)
  689. * on rajoute une touche PS (certains cas seront a exclure)
  690. * SG 20260730 : securite
  691. if (klong*(kcase+1).LE.LEN(KEGEND)) THEN
  692. kcase=kcase+1
  693. KEGEND(1+KLONG*(kcase-1):KLONG*kcase)=' '
  694. KEGEND(1+KLONG*(kcase-1)+(klong-8)/2:KLONG*kcase)='Softcopy'
  695. else
  696. MOTERR='xtrini'
  697. call erreur(1039)
  698. return
  699. endif
  700. C#MC 05/01/99 utilite ? IDEFOR inconuu...
  701. C IDEFO=IDEFOR
  702. * ON SE MET DANS LE SEGMENT 0
  703. * CHANGEMENT SEGMENT CODE OPERATION 3 1 ENTIER
  704. NBOP=NBOP+2
  705. IF (NBOP.GT.NBOPD) THEN
  706. NBOPD=NBOPD+100000
  707. SEGADJ DESSIN
  708. ENDIF
  709. IOPER(NBOP-1)=3
  710. IOPER(NBOP)=0
  711. NBOP=NBOP+1
  712. IF (NBOP.GT.NBOPD) THEN
  713. NBOPD=NBOPD+100000
  714. SEGADJ DESSIN
  715. ENDIF
  716. IOPER(NBOP)=8
  717. RETURN
  718. **
  719. ENTRY XTRANI(ITYPI,NBIMAH)
  720. NBOP=NBOP+3
  721. IF (NBOP.GT.NBOPD) THEN
  722. NBOPD=NBOPD+100000
  723. SEGADJ DESSIN
  724. ENDIF
  725. IOPER(NBOP-2)=10
  726. IOPER(NBOP-1)=ITYPI
  727. IOPER(NBOP)=NBIMAH
  728. RETURN
  729. **
  730. ENTRY XTRIMA(IMAGI)
  731. NBOP=NBOP+2
  732. IF (NBOP.GT.NBOPD) THEN
  733. NBOPD=NBOPD+100000
  734. SEGADJ DESSIN
  735. ENDIF
  736. IOPER(NBOP-1)=9
  737. IOPER(NBOP)=IMAGI
  738. RETURN
  739. **
  740. ENTRY XFVALI(IFENI,IRESU,NH,NISO)
  741. segact dessin*mod,dessic*mod
  742. * sauver le nb d'iso
  743. MISO=NISO
  744. * CHANGEMENT DE VIEW PORT
  745. IF (IFENI.EQ.1) THEN
  746. NBOP=NBOP+2
  747. IF (NBOP.GT.NBOPD) THEN
  748. NBOPD=NBOPD+100000
  749. SEGADJ DESSIN
  750. ENDIF
  751. IOPER(NBOP-1)=7
  752. IOPER(NBOP)=IFENI
  753. ENDIF
  754. NH=31
  755. RETURN
  756. **
  757. C======================================================================
  758. ENTRY XZOOM(IZOOM,XMI,XMA,YMI,YMA)
  759. * mise à jour du cadre
  760. * IZOOM=1 zoom
  761. * IZOOM=-1 zoom inverse
  762. * IZOOM=0 pan
  763. segact dessin*mod,dessic*mod
  764. if (izoom.eq.1) then
  765. XMIN=XMI
  766. XXAX=XMA
  767. YMIN=YMI
  768. YYAX=YMA
  769. endif
  770. if (izoom.eq.-1) then
  771. AXMIN=XMIN-(XMI-XMIN)*(XXAX-XMIN)/(XMA-XMI)
  772. AXXAX=AXMIN+(XXAX-XMIN)*(XXAX-XMIN)/(XMA-XMI)
  773. XMIN=AXMIN
  774. XXAX=AXXAX
  775. AYMIN=YMIN-(YMI-YMIN)*(YYAX-YMIN)/(YMA-YMI)
  776. AYYAX=AYMIN+(YYAX-YMIN)*(YYAX-YMIN)/(YMA-YMI)
  777. YMIN=AYMIN
  778. YYAX=AYYAX
  779. endif
  780. if (izoom.eq.0) then
  781. XMIN=XMIN-(XMA-XMI)
  782. XXAX=XXAX-(XMA-XMI)
  783. YMIN=YMIN-(YMA-YMI)
  784. YYAX=YYAX-(YMA-YMI)
  785. endif
  786. XMI=OXMIN
  787. XMA=OXXAX
  788. YMI=OYMIN
  789. YMA=OYYAX
  790. IBPD=0
  791. IBOPD=0
  792. IBCHRD=0
  793. RETURN
  794. **
  795. C======================================================================
  796. ENTRY XINI(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA)
  797. * RETOUR AU DESSIN INITIAL
  798. segact dessin*mod,dessic*mod
  799. XMIN=OXMIN
  800. XXAX=OXXAX
  801. YMIN=OYMIN
  802. YYAX=OYYAX
  803. ISORT=0
  804. IRESU=2
  805. IBPD=0
  806. IBOPD=0
  807. IBCHRD=0
  808. RETURN
  809. **
  810. C======================================================================
  811. ENTRY XCHANG(IRESU,ISORT,ICHANG,JSEG)
  812. segact dessin*mod,dessic*mod
  813. IDSGT=0
  814. * affichage desaffichage num noeuds elements qual
  815. IF (ICHANG.EQ.1) THEN
  816. IBON=1
  817. IBOP=0
  818. IBCHR=0
  819. IBP=0
  820. JBOP=0
  821. JBCHR=0
  822. JBP=0
  823. 300 CONTINUE
  824. IBOP=IBOP+1
  825. IF (IBOP.GT.NBOP) GOTO 350
  826. ICOD=IOPER(IBOP)
  827. IF (IBON.EQ.1) THEN
  828. JBOP=JBOP+1
  829. IOPER(JBOP)=IOPER(IBOP)
  830. IF (ICOD.EQ.1) THEN
  831. * xrlabl
  832. IBOP=IBOP+1
  833. JBOP=JBOP+1
  834. IOPER(JBOP)=IOPER(IBOP)
  835. NBCAR=IOPER(IBOP)
  836. CARACT(JBCHR+1:JBCHR+NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR)
  837. IBCHR=IBCHR+NBCAR
  838. JBCHR=JBCHR+NBCAR
  839. IBP=IBP+1
  840. JBP=JBP+1
  841. X(JBP)=X(IBP)
  842. Y(JBP)=Y(IBP)
  843. Z(JBP)=Z(IBP)
  844. ELSEIF (ICOD.EQ.2) THEN
  845. * chcoul
  846. IBOP=IBOP+1
  847. JBOP=JBOP+1
  848. IOPER(JBOP)=IOPER(IBOP)
  849. ELSEIF (ICOD.EQ.3) THEN
  850. * OUVERTURE SEGMENT
  851. IBOP=IBOP+1
  852. IF (IOPER(IBOP).EQ.JSEG) THEN
  853. IBON=0
  854. * IL FAUDRA REPRENDRE LE DESSIN AU DEBUT
  855. IBOPD=0
  856. IBPD=0
  857. IBCHRD=0
  858. * ON NE STOCKE PAS CE CHANGEMENT DE SEGMENT
  859. JBOP=JBOP-1
  860. GOTO 300
  861. ELSE
  862. JBOP=JBOP+1
  863. IOPER(JBOP)=IOPER(IBOP)
  864. ENDIF
  865. ELSEIF (ICOD.EQ.4) THEN
  866. * polyline
  867. IBOP=IBOP+1
  868. JBOP=JBOP+1
  869. IOPER(JBOP)=IOPER(IBOP)
  870. N=IOPER(IBOP)
  871. DO 305 IIP=1,N
  872. IBP=IBP+1
  873. JBP=JBP+1
  874. X(JBP)=X(IBP)
  875. Y(JBP)=Y(IBP)
  876. Z(JBP)=Z(IBP)
  877. 305 CONTINUE
  878. ELSEIF (ICOD.EQ.5) THEN
  879. * face
  880. IBOP=IBOP+1
  881. JBOP=JBOP+1
  882. IOPER(JBOP)=IOPER(IBOP)
  883. N=IOPER(IBOP)
  884. IBOP=IBOP+1
  885. JBOP=JBOP+1
  886. IOPER(JBOP)=IOPER(IBOP)
  887. DO 307 IIP=1,N
  888. IBP=IBP+1
  889. JBP=JBP+1
  890. X(JBP)=X(IBP)
  891. Y(JBP)=Y(IBP)
  892. Z(JBP)=Z(IBP)
  893. 307 CONTINUE
  894. C+PPf
  895. IBOP=IBOP+1
  896. JBOP=JBOP+1
  897. IOPER(JBOP)=IOPER(IBOP)
  898. C+PPf
  899. ELSEIF (ICOD.EQ.6) THEN
  900. * iso
  901. IBOP=IBOP+1
  902. JBOP=JBOP+1
  903. IOPER(JBOP)=IOPER(IBOP)
  904. N=IOPER(IBOP)
  905. IBOP=IBOP+1
  906. JBOP=JBOP+1
  907. IOPER(JBOP)=IOPER(IBOP)
  908. DO 309 IIP=1,N
  909. IBP=IBP+1
  910. JBP=JBP+1
  911. X(JBP)=X(IBP)
  912. Y(JBP)=Y(IBP)
  913. Z(JBP)=Z(IBP)
  914. IOPER(JBOP)=IOPER(IBOP)
  915. 309 CONTINUE
  916. ELSEIF (ICOD.EQ.7) THEN
  917. * fvalis
  918. IBOP=IBOP+1
  919. JBOP=JBOP+1
  920. IOPER(JBOP)=IOPER(IBOP)
  921. ELSEIF (ICOD.EQ.8) THEN
  922. * menu
  923. ELSEIF (ICOD.EQ.9) THEN
  924. * changement image
  925. IBOP=IBOP+1
  926. JBOP=JBOP+1
  927. IOPER(JBOP)=IOPER(IBOP)
  928. ELSEIF (ICOD.EQ.10) THEN
  929. * initialisation animation
  930. IBOP=IBOP+2
  931. JBOP=JBOP+2
  932. IOPER(JBOP)=IOPER(IBOP)
  933. ELSEIF (ICOD.EQ.11) THEN
  934. ENDIF
  935. ELSE
  936. IF (ICOD.EQ.1) THEN
  937. * xrlabl
  938. IBOP=IBOP+1
  939. NBCAR=IOPER(IBOP)
  940. IBCHR=IBCHR+NBCAR
  941. IBP=IBP+1
  942. ELSEIF (ICOD.EQ.2) THEN
  943. * chcoul
  944. IBOP=IBOP+1
  945. ELSEIF (ICOD.EQ.3) THEN
  946. * OUVERTURE SEGMENT ON REVIENT EN TETE
  947. IBOP=IBOP-1
  948. IBON=1
  949. GOTO 300
  950. ELSEIF (ICOD.EQ.4) THEN
  951. * polyline
  952. IBOP=IBOP+1
  953. N=IOPER(IBOP)
  954. IBP=IBP+N
  955. ELSEIF (ICOD.EQ.5) THEN
  956. * face
  957. IBOP=IBOP+1
  958. N=IOPER(IBOP)
  959. IBOP=IBOP+1
  960. C+PPf
  961. IBOP=IBOP+1
  962. C+PPf
  963. IBP=IBP+N
  964. ELSEIF (ICOD.EQ.6) THEN
  965. * iso
  966. IBOP=IBOP+1
  967. N=IOPER(IBOP)
  968. IBOP=IBOP+1
  969. IBP=IBP+N
  970. ELSEIF (ICOD.EQ.7) THEN
  971. * fvalis
  972. IBOP=IBOP+1
  973. ELSEIF (ICOD.EQ.8) THEN
  974. * menu
  975. ELSEIF (ICOD.EQ.9) THEN
  976. * changement image
  977. IBOP=IBOP+1
  978. ELSEIF (ICOD.EQ.10) THEN
  979. * initialisation animation
  980. IBOP=IBOP+2
  981. ELSEIF (ICOD.EQ.11) THEN
  982. ENDIF
  983. ENDIF
  984. GOTO 300
  985. 350 CONTINUE
  986. NBOP=JBOP
  987. NBP=JBP
  988. NBCHR=JBCHR
  989. ICHANG=0
  990. ISORT=0
  991. RETURN
  992. ELSE
  993. ISORT=1
  994. IRESU=JSEG
  995. ICHANG=1
  996. RETURN
  997. ENDIF
  998. **
  999. C======================================================================
  1000. ENTRY XTRBOX(HAUTX,HAUTY)
  1001. * INUTILISE
  1002. RETURN
  1003. **
  1004. C======================================================================
  1005. ENTRY XTREFF
  1006. * INUTILISE
  1007. RETURN
  1008. **
  1009. C======================================================================
  1010. ENTRY XVAL(IRESU,ISORT,ISO)
  1011. C#MC IF (ISO.NE.0.AND.IDEFO.EQ.0) THEN
  1012. IF (ISO.NE.0) THEN
  1013. IRESU=10
  1014. ISORT=1
  1015. ENDIF
  1016. RETURN
  1017. **
  1018. C======================================================================
  1019. ENTRY XMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL)
  1020. * INUTILISE
  1021. RETURN
  1022. **
  1023. **
  1024. C======================================================================
  1025. ENTRY XIMPR
  1026. * INUTILISE
  1027. RETURN
  1028. **
  1029. C======================================================================
  1030. ENTRY XTRTIN
  1031. * INUTILISE
  1032. RETURN
  1033. **
  1034. C======================================================================
  1035. ENTRY XFLGI
  1036. * INUTILISE
  1037. RETURN
  1038. **
  1039. C======================================================================
  1040. ENTRY XTRMFI
  1041. * INUTILISE
  1042. RETURN
  1043. **
  1044. C======================================================================
  1045. ENTRY XTRMES(CARAC)
  1046. CHMESS=CARAC
  1047. RETURN
  1048. **
  1049. C======================================================================
  1050. ENTRY XTRGET(PROMPT,REPLY)
  1051. segact dessin*mod,dessic*mod
  1052. LPROMP=LONG(PROMPT)
  1053. LREPLY=LONG(REPLY)
  1054. CHAINE=PROMPT
  1055. CALL XVALIS(3,IRESV,NHH)
  1056. IF(icosc.eq.1) then
  1057. ico1=7
  1058. else
  1059. ico1=8
  1060. endif
  1061. CALL XHCOUL(ico1)
  1062. CALL XRGET(ICHAIN,LPROMP,ICHAIN,LREPLY)
  1063. REPLY=' '
  1064. IF (LREPLY.NE.0) REPLY=CHAINE(1:LREPLY)
  1065. RETURN
  1066. **
  1067. C======================================================================
  1068. ENTRY XRCLIK(KCLICK)
  1069. CALL XCLIK(KCLICK)
  1070. END
  1071.  
  1072.  

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