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

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