Télécharger la plaquette Cast3M


fr en

Télécharger xtrini.eso

Retour à la liste

Numérotation des lignes : 

xtrini

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

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