Télécharger la plaquette Cast3M


fr en

Télécharger optdes.eso

Retour à la liste

Numérotation des lignes : 

optdes

  1. C OPTDES    SOURCE    CB215821  21/07/12    21:15:19     11074          
  2.       SUBROUTINE OPTDES (IOPTIO,NOL,AXE,TITRE,TXTIT,TXAXE,TYAXE,
  3.      & TTXX,TTXXX,TTYY,TTYYY,ZAXES,ZSEPAR,ZOPTIO,ZLEGEN,IEV,
  4.      & DYN,NDIMT,CUR,NDIMT2,NC,INBEVO,ZMIMA,ZDATE,YMINI,YMAXI,
  5.      & IPOSI,XPOSI,YPOSI,IGRIL)
  6. *=============================================================
  7. *
  8. * TESTS POUR L'EVOLUTION DE DESSIN
  9. *
  10. *=============================================================
  11. *
  12. * Modifications :
  13. *
  14. *   05 sept. 2007 Maugis
  15. *     Maintien du segment AXE actif en modification
  16. *
  17. *=============================================================
  18. *
  19. * Entrée : Cf. dessin.eso
  20. *
  21. *=============================================================
  22.  
  23.       IMPLICIT LOGICAL (Z)
  24.       IMPLICIT INTEGER (I-N)
  25.       IMPLICIT REAL*8  (A-H,O-S,U-Y)
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC CCREEL
  30. -INC SMEVOLL
  31. -INC SMLREEL
  32. -INC CCGEOME
  33. -INC TMAXE
  34. -INC SMTABLE
  35.  
  36.       CHARACTER*(*)      TITRE,TXTIT,TXAXE,TYAXE
  37.       CHARACTER*(LOCHAI) BUFFER,CHOPT,TITOPT,TITOP2
  38. C     CHARACTER*(LOCHAI) TIME
  39.       CHARACTER*8        CTYPE,CHVIDE,ETYPE,MTYPI,MTYPR,CHARR
  40.  
  41. c     LOGICAL      VALEUR
  42.       LOGICAL      ZGRIL1,ZREMP2
  43.       REAL         RXDIM,RYDIM,HMIN
  44.  
  45.       SEGMENT DYN
  46.            LOGICAL ZTRACE(NDIMT)
  47.       ENDSEGMENT
  48.       SEGMENT CUR
  49.            LOGICAL ZCUR(NDIMT2)
  50.       ENDSEGMENT
  51.       NOL        = 25
  52.       ETYPE      ='ENTIER  '
  53.       CHVIDE     ='        '
  54.       ZREMP2     =.FALSE.
  55.  
  56.  
  57. *=============================================================
  58. * MARGE PROPORTIONNELLE A LA GRADUATION DE LA FENETRE USER
  59. *=============================================================
  60. *
  61.       SEGACT AXE*MOD
  62.  
  63.       D=ABS(XSUP-XINF)
  64.       IF (ZCARRE) THEN
  65.         BG=0.14*REAL(D)
  66.         BD=0.55*REAL(D)
  67.       ELSE
  68.         BG=0.10*REAL(D)
  69.         BD=0.10*REAL(D)
  70.       ENDIF
  71.  
  72.       D=ABS(YSUP-YINF)
  73.       BH=0.08*REAL(D)
  74.       BB=0.13*REAL(D)
  75.  
  76.  
  77. *=============================================================
  78. * DEFINITION FENETRE
  79. *=============================================================
  80. *
  81. c     DIOCAD = taille du cadre include CCOPTIO
  82.       XDIM = DIOCAD * .9D0*29.D0 / 30.D0 *1.134D0
  83.       YDIM = DIOCAD * .9D0*21.D0 / 30.D0 *1.08D0
  84.       IF (XSUP.LE.XINF) GOTO 950
  85.       IF (YSUP.LE.YINF) GOTO 950
  86.       RXDIM=XDIM
  87.       RYDIM=YDIM
  88.       IF (TXTIT.NE.' ') TITRE=TXTIT
  89.       NCOUMA=NBCOUL
  90. c     appel a trinit pour definir les bonnes ENTRY selon IOGRA
  91.       CALL TRINIT (NOL,RXDIM,RYDIM,TITRE,.15,.false.,NCOUMA)
  92.  
  93. c     definition de la fenetre
  94.       TTX1=REAL(XINF)-BG
  95.       TTX2=REAL(XSUP)+BD
  96.       TTX3=REAL(YINF)-BB
  97.       TTX4=REAL(YSUP)+BH
  98.       CALL DFENET (TTX1,TTX2,TTX3,TTX4,-1.,+1.,TTXX,TTXXX,TTYY,TTYYY,
  99.      >   .FALSE.)
  100.       XX =DBLE(TTXX)
  101.       XXX=DBLE(TTXXX)
  102.       YY =DBLE(TTYY)
  103.       YYY=DBLE(TTYYY)
  104.       IF (TXAXE.NE.' ') TITREX=TXAXE
  105.       IF (TYAXE.NE.' ') TITREY=TYAXE
  106.  
  107. *=============================================================
  108. * CONSTRUCTION DE L'AXE
  109. *=============================================================
  110.       CALL TRBOX(0.7,0.7)
  111.       CALL DAXES(AXE,ZAXES,IGRIL)
  112.       CALL TRBOX(1./0.7,1./0.7)
  113.  
  114. *=============================================================
  115. * AFFICHAGES DIVERS
  116. *=============================================================
  117. *
  118. * AFFICHAGE DU MINIMUM ET DU MAXIMUM
  119. *
  120.       IF (ZMIMA) THEN
  121.         CALL TRBOX(0.7,0.7)
  122.         TYY=REAL(YSUP)+BH/4.
  123.         TXX=REAL(XINF+(XSUP-XINF)*2.D0/3.D0)
  124.         BUFFER(1:10)='MINIMUM : '
  125.         WRITE (BUFFER(11:21),FMT='(G11.4)') YMINI
  126.         CALL TRLABL (TXX,TYY,0.,BUFFER,21,HMIN)
  127.         BUFFER(1:10)='MAXIMUM : '
  128.         TYY=YSUP+(BH/1.8)
  129.         TXX=XINF+(XSUP-XINF)*2/3
  130.         WRITE (BUFFER(11:21),FMT='(G11.4)') YMAXI
  131.         CALL TRLABL (TXX,TYY,0.,BUFFER,21,HMIN)
  132.         CALL TRBOX(1./0.7,1./0.7)
  133.       ENDIF
  134. *
  135. * AFFICHAGE DE LA DATE
  136. *
  137.       IF (ZDATE) THEN
  138.         CALL GIBDAT(JOUR,MOIS,IANNEE)
  139.         iannee=mod(iannee,100)
  140. **TC        TIME=FDATE()
  141.         BUFFER(1:22)='     /  /20           '
  142.         WRITE (BUFFER(4:5),FMT='(I2)') JOUR
  143.         WRITE (BUFFER(7:8),FMT='(I2)') MOIS
  144.         WRITE (BUFFER(12:13),FMT='(I2)') IANNEE
  145. **TC        WRITE (BUFFER(15:22),FMT='(A8)') TIME(12:20)
  146. cbp : cette position ne me semble pas tres esthetique ....
  147. c         TXX=TTXXX-0.98*(TTXXX-TTXX)
  148. c         TYY=TTYY +0.02*(TTYYY-TTYY)
  149.         IF (ZCARRE) THEN
  150.           TXX=REAL(XSUP)-(13.5*.017*(XSUP-XINF))
  151.         ELSE
  152.           TXX=REAL(XSUP)-(14.*.011*(XSUP-XINF))
  153.         ENDIF
  154.           TYY=REAL(YSUP)+(.05*(YSUP-YINF))
  155.         CALL TRBOX(0.8,0.8)
  156.         CALL TRLABL(TXX,TYY,0.,BUFFER(1:22),22,HMIN)
  157.         CALL TRBOX(1./0.8,1./0.8)
  158.       ENDIF
  159.  
  160.  
  161. *=============================================================
  162. * TRACE DES COURBES
  163. *=============================================================
  164.       MEVOLL=IEV
  165.       CALL ACTOBJ('EVOLUTION',MEVOLL,1)
  166.       IF (IERR.NE.0) RETURN
  167.  
  168.       CTYPE(1:8)=' '
  169.       NCT=0
  170.       NLG=0
  171. *
  172. * TRACES SEPARES  ====================================
  173. *
  174.       IF (ZSEPAR) THEN
  175.  
  176.         IPTR=IEVOLL(NC)
  177.         KEVOLL=IPTR
  178. *
  179. * RECHERCHE EVENTUELLE DES PARAMETRES SPECIFIQUES
  180. *
  181.         IF (ZOPTIO) THEN
  182.           CALL ACCTAB(IOPTIO,ETYPE,NC,X,CHVIDE,Z,II,CTYPE,ILG,XX,CHOPT,
  183.      #                ZZ,III)
  184.           IF (CTYPE(1:3).NE.'MOT') CHOPT=''''
  185. c             valeurs par defaut
  186.               IF(KEVTEX(1:4).EQ.'    ') THEN
  187.                 TITOPT='PAS DE LEGENDE'
  188.               ELSE
  189.                 TITOPT=KEVTEX
  190.               ENDIF
  191.               IDEB1=0
  192.               IFIN1=IGRAND
  193.               ISTYL=0
  194. c             variables bidons
  195.               IVALI=0
  196.               XVALI=0.D0
  197.               IRETI=0
  198.               IVALR=0
  199.               XVALR=0.D0
  200.               IRETR=0
  201.               MTYPI='MOT     '
  202.               MTYPR='        '
  203.               ITITOP=0
  204.               CHARR='        '
  205. c             lecture d'un titre de legende
  206.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'TITRE',.TRUE.,IRETI,
  207.      *                    MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  208.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  209.                  MTAB1=IRETR
  210.                  CTYPE(1:8)=' '
  211.                  CALL ACCTAB(MTAB1,ETYPE,NC,X,CHVIDE,Z,II,CTYPE,ILG,XX,
  212.      #                    TITOP2, ZZ,III)
  213.                  IF(CTYPE(1:3).EQ.'MOT')TITOPT=TITOP2
  214.               ENDIF
  215. c             lecture des points initial et final --> IDEB1 et IFIN1
  216.               MTYPR='        '
  217.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'INITIAL',.TRUE.,IRETI,
  218.      *                              MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  219.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  220.                  MTAB1=IRETR
  221.                  CTYPE(1:8)=' '
  222.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  223.      #                             CTYPE,IDEB1,XX,CHARR,ZZ,III)
  224.                  IF(CTYPE(1:6).NE.'ENTIER')IDEB1=0
  225.               ENDIF
  226.               MTYPR='        '
  227.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'FINAL',.TRUE.,IRETI,
  228.      *                              MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  229.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  230.                  MTAB1=IRETR
  231.                  CTYPE(1:8)=' '
  232.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  233.      #                             CTYPE,IFIN1,XX,CHARR,ZZ,III)
  234.                  IF(CTYPE(1:6).NE.'ENTIER')IFIN1=IGRAND
  235.               ENDIF
  236. c             lecture d un type de trait variable
  237.               MTYPR='        '
  238.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'LIGNE_VARIABLE',.TRUE.
  239.      *                    ,IRETI,MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  240.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  241.                  MTAB1=IRETR
  242.                  CTYPE(1:8)=' '
  243.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  244.      #                             CTYPE,IVALR,XVALR,CHARR,ZZ,ISTYL)
  245.                  IF(CTYPE(1:8).NE.'LISTENTI') ISTYL=0
  246.               ENDIF
  247.         ELSE
  248.             CHOPT=' '
  249.             IF(KEVTEX(1:4).EQ.'    ') THEN
  250.                 TITOPT='PAS DE LEGENDE'
  251.             ELSE
  252.                 TITOPT=KEVTEX
  253.             ENDIF
  254.             IDEB1=0
  255.             IFIN1=IGRAND
  256.             ISTYL=0
  257.         ENDIF
  258. *PM        SEGDES AXE
  259.         CALL TRBOX(0.7,0.7)
  260.         CALL TREVOL (AXE,IPTR,CHOPT,TITOPT,ZLEGEN,NCT,NLG,INBEVO
  261.      &  ,IPOSI,XPOSI,YPOSI,ZREMP2,IDEB1,IFIN1,ISTYL)
  262.  
  263.         CALL TRBOX(1./0.7,1./0.7)
  264. *PM        SEGACT AXE*MOD
  265.  
  266. *
  267. * CAS DES CURVILIGNES
  268. *
  269.         IF (ZCUR(NC+1)) THEN
  270. *         On affiche le long de l'axe des abscisses, avec des marqueurs,
  271. *         les noms des points nommés rencontrés
  272. *PM          SEGDES AXE
  273.           CALL TRBOX(0.7,0.7)
  274.           IPTR=IEVOLL(NC+1)
  275.           CALL TRCUR(AXE,IPTR)
  276.           CALL TRBOX(1./0.7,1./0.7)
  277. *PM          SEGACT AXE*MOD
  278.         ENDIF
  279. *
  280.  
  281. *
  282. * TRACES SIMULTANES ====================================
  283. *
  284.       ELSE
  285.  
  286.         KK=0
  287.         DO 49 I=1,INBEVO
  288.  
  289.           IF (ZTRACE(I)) THEN
  290.  
  291.             KK=KK+1
  292.             IPTR=IEVOLL(I)
  293.             KEVOLL=IPTR
  294. *
  295. * RECHERCHE EVENTUELLE DES PARAMETRES SPECIFIQUES
  296. *
  297.             IF (ZOPTIO) THEN
  298.  
  299. c             lecture des options (lign, marqueures etc...) --> CHOPT
  300.               CTYPE(1:8)=' '
  301.               CALL ACCTAB(IOPTIO,ETYPE,KK,X,CHVIDE,Z,II,CTYPE,ILG,XX,
  302.      #                                                     CHOPT,ZZ,III)
  303.  
  304.               IF (CTYPE(1:3).NE.'MOT') CHOPT=' '
  305. c             valeurs par defaut
  306.               IF(KEVTEX(1:4).EQ.'    ') THEN
  307.                 TITOPT='PAS DE LEGENDE'
  308.               ELSE
  309.                 TITOPT=KEVTEX
  310.               ENDIF
  311.               IDEB1=0
  312.               IFIN1=IGRAND
  313.               ISTYL=0
  314. c             variables bidons
  315.               IVALI=0
  316.               XVALI=0.D0
  317.               IRETI=0
  318.               IVALR=0
  319.               XVALR=0.D0
  320.               IRETR=0
  321.               MTYPI='MOT     '
  322.               MTYPR='        '
  323.               ITITOP=0
  324.               CHARR='        '
  325. c             lecture d'un titre de legende --> TITOPT
  326.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'TITRE',.TRUE.,IRETI,
  327.      *                              MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  328.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  329.                  MTAB1=IRETR
  330. c                  SEGACT MTAB1
  331.                  CTYPE(1:8)=' '
  332.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,CTYPE,ILG,XX,
  333.      #                                                   TITOP2,ZZ,III)
  334.                  IF(CTYPE(1:3).EQ.'MOT')TITOPT=TITOP2
  335.               ENDIF
  336. c             lecture des points initial et final --> IDEB1 et IFIN1
  337.               MTYPR='        '
  338.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'INITIAL',.TRUE.,IRETI,
  339.      *                              MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  340.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  341.                  MTAB1=IRETR
  342.                  CTYPE(1:8)=' '
  343.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  344.      #                             CTYPE,IDEB1,XX,CHARR,ZZ,III)
  345.                  IF(CTYPE(1:6).NE.'ENTIER')IDEB1=0
  346.               ENDIF
  347.               MTYPR='        '
  348.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'FINAL',.TRUE.,IRETI,
  349.      *                              MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  350.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  351.                  MTAB1=IRETR
  352.                  CTYPE(1:8)=' '
  353.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  354.      #                             CTYPE,IFIN1,XX,CHARR,ZZ,III)
  355.                  IF(CTYPE(1:6).NE.'ENTIER')IFIN1=IGRAND
  356.               ENDIF
  357. c             lecture d un type de trait variable
  358.               MTYPR='        '
  359.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'LIGNE_VARIABLE',.TRUE.
  360.      *                    ,IRETI,MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  361.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  362.                  MTAB1=IRETR
  363.                  CTYPE(1:8)=' '
  364.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  365.      #                             CTYPE,IVALR,XVALR,CHARR,ZZ,ISTYL)
  366.                  IF(CTYPE(1:8).NE.'LISTENTI') ISTYL=0
  367.               ENDIF
  368.             ELSE
  369.               CHOPT=' '
  370.               IF(KEVTEX(1:4).EQ.'    ') THEN
  371.                 TITOPT='PAS DE LEGENDE'
  372.               ELSE
  373.                 TITOPT=KEVTEX
  374.               ENDIF
  375.               IDEB1=0
  376.               IFIN1=IGRAND
  377.               ISTYL=0
  378.             ENDIF
  379. *PM            SEGDES AXE
  380.             CALL TRBOX(0.7,0.7)
  381.             CALL TREVOL (AXE,IPTR,CHOPT,TITOPT,ZLEGEN,NCT,NLG,INBEVO
  382.      &      ,IPOSI,XPOSI,YPOSI,ZREMP2,IDEB1,IFIN1,ISTYL)
  383.             CALL TRBOX(1./0.7,1./0.7)
  384. *PM            SEGACT AXE*MOD
  385.           ENDIF
  386. *
  387. * CAS DES CURVILIGNES
  388. *
  389.          IF (ZCUR(I)) THEN
  390. *           On affiche le long de l'axe des abscisses, avec des marqueurs,
  391. *           les noms des points nommés rencontrés
  392. *PM         SEGDES AXE
  393.             CALL TRBOX(0.7,0.7)
  394.             IPTR=IEVOLL(I)
  395.             CALL TRCUR(AXE,IPTR)
  396.             CALL TRBOX(1./0.7,1./0.7)
  397. *PM         SEGACT AXE*MOD
  398.           ENDIF
  399.  49     CONTINUE
  400. *
  401.       ENDIF
  402. C     SEGDES MEVOLL
  403.  
  404. *=============================================================
  405. *     On redessine les axes sans grille pour repasser sur d'éventuelles
  406. *     ombres
  407. *=============================================================
  408.       IF(ZREMP2) THEN
  409.         CALL TRBOX(0.7,0.7)
  410.         ZGRIL1=ZGRILL
  411.         ZGRILL=.FALSE.
  412.         CALL DAXES(AXE,ZAXES,IGRIL)
  413.         ZGRILL=ZGRIL1
  414.         CALL TRBOX (1./0.7,1./0.7)
  415.       ENDIF
  416.       RETURN
  417.  
  418. *     L'intervalle entre les bornes est trop faible.
  419. 950   CALL ERREUR (497)
  420.       END
  421.  
  422.  
  423.  
  424.  
  425.  
  426.  
  427.  
  428.  

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