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    SP204843  24/09/27    21:15:13     12017          
  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.             LSTY1 = LSTYL
  249.             MMAR1 = MMARQ
  250.             KTAI1 = KTAIL
  251.             CALL STYDES(LSTY1,MMAR1,KTAI1,CHOPT)
  252.             IF(KEVTEX(1:4).EQ.'    ') THEN
  253.                 TITOPT='PAS DE LEGENDE'
  254.             ELSE
  255.                 TITOPT=KEVTEX
  256.             ENDIF
  257.             IDEB1=0
  258.             IFIN1=IGRAND
  259.             ISTYL=0
  260.         ENDIF
  261. *PM        SEGDES AXE
  262.         CALL TRBOX(0.7,0.7)
  263.         CALL TREVOL (AXE,IPTR,CHOPT,TITOPT,ZLEGEN,NCT,NLG,INBEVO
  264.      &  ,IPOSI,XPOSI,YPOSI,ZREMP2,IDEB1,IFIN1,ISTYL)
  265.  
  266.         CALL TRBOX(1./0.7,1./0.7)
  267. *PM        SEGACT AXE*MOD
  268.  
  269. *
  270. * CAS DES CURVILIGNES
  271. *
  272.         IF (ZCUR(NC+1)) THEN
  273. *         On affiche le long de l'axe des abscisses, avec des marqueurs,
  274. *         les noms des points nommés rencontrés
  275. *PM          SEGDES AXE
  276.           CALL TRBOX(0.7,0.7)
  277.           IPTR=IEVOLL(NC+1)
  278.           CALL TRCUR(AXE,IPTR)
  279.           CALL TRBOX(1./0.7,1./0.7)
  280. *PM          SEGACT AXE*MOD
  281.         ENDIF
  282. *
  283.  
  284. *
  285. * TRACES SIMULTANES ====================================
  286. *
  287.       ELSE
  288.  
  289.         KK=0
  290.         DO 49 I=1,INBEVO
  291.  
  292.           IF (ZTRACE(I)) THEN
  293.  
  294.             KK=KK+1
  295.             IPTR=IEVOLL(I)
  296.             KEVOLL=IPTR
  297. *
  298. * RECHERCHE EVENTUELLE DES PARAMETRES SPECIFIQUES
  299. *
  300.             IF (ZOPTIO) THEN
  301.  
  302. c             lecture des options (lign, marqueures etc...) --> CHOPT
  303.               CTYPE(1:8)=' '
  304.               CALL ACCTAB(IOPTIO,ETYPE,KK,X,CHVIDE,Z,II,CTYPE,ILG,XX,
  305.      #                                                     CHOPT,ZZ,III)
  306.  
  307.               IF (CTYPE(1:3).NE.'MOT') CHOPT=' '
  308. c             valeurs par defaut
  309.               IF(KEVTEX(1:4).EQ.'    ') THEN
  310.                 TITOPT='PAS DE LEGENDE'
  311.               ELSE
  312.                 TITOPT=KEVTEX
  313.               ENDIF
  314.               IDEB1=0
  315.               IFIN1=IGRAND
  316.               ISTYL=0
  317. c             variables bidons
  318.               IVALI=0
  319.               XVALI=0.D0
  320.               IRETI=0
  321.               IVALR=0
  322.               XVALR=0.D0
  323.               IRETR=0
  324.               MTYPI='MOT     '
  325.               MTYPR='        '
  326.               ITITOP=0
  327.               CHARR='        '
  328. c             lecture d'un titre de legende --> TITOPT
  329.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'TITRE',.TRUE.,IRETI,
  330.      *                              MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  331.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  332.                  MTAB1=IRETR
  333. c                  SEGACT MTAB1
  334.                  CTYPE(1:8)=' '
  335.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,CTYPE,ILG,XX,
  336.      #                                                   TITOP2,ZZ,III)
  337.                  IF(CTYPE(1:3).EQ.'MOT')TITOPT=TITOP2
  338.               ENDIF
  339. c             lecture des points initial et final --> IDEB1 et IFIN1
  340.               MTYPR='        '
  341.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'INITIAL',.TRUE.,IRETI,
  342.      *                              MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  343.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  344.                  MTAB1=IRETR
  345.                  CTYPE(1:8)=' '
  346.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  347.      #                             CTYPE,IDEB1,XX,CHARR,ZZ,III)
  348.                  IF(CTYPE(1:6).NE.'ENTIER')IDEB1=0
  349.               ENDIF
  350.               MTYPR='        '
  351.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'FINAL',.TRUE.,IRETI,
  352.      *                              MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  353.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  354.                  MTAB1=IRETR
  355.                  CTYPE(1:8)=' '
  356.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  357.      #                             CTYPE,IFIN1,XX,CHARR,ZZ,III)
  358.                  IF(CTYPE(1:6).NE.'ENTIER')IFIN1=IGRAND
  359.               ENDIF
  360. c             lecture d un type de trait variable
  361.               MTYPR='        '
  362.               CALL ACCTAB(IOPTIO,MTYPI,IVALI,X,'LIGNE_VARIABLE',.TRUE.
  363.      *                    ,IRETI,MTYPR,IVALR,XVALR,CHARR,ZZ,IRETR)
  364.               IF(MTYPR(1:5).EQ.'TABLE')THEN
  365.                  MTAB1=IRETR
  366.                  CTYPE(1:8)=' '
  367.                  CALL ACCTAB(MTAB1,ETYPE,KK,X,CHVIDE,Z,II,
  368.      #                             CTYPE,IVALR,XVALR,CHARR,ZZ,ISTYL)
  369.                  IF(CTYPE(1:8).NE.'LISTENTI') ISTYL=0
  370.               ENDIF
  371.             ELSE
  372.               LSTY1 = LSTYL
  373.               MMAR1 = MMARQ
  374.               KTAI1 = KTAIL
  375.               CALL STYDES(LSTY1,MMAR1,KTAI1,CHOPT)
  376.               IF(KEVTEX(1:4).EQ.'    ') THEN
  377.                 TITOPT='PAS DE LEGENDE'
  378.               ELSE
  379.                 TITOPT=KEVTEX
  380.               ENDIF
  381.               IDEB1=0
  382.               IFIN1=IGRAND
  383.               ISTYL=0
  384.             ENDIF
  385. *PM            SEGDES AXE
  386.             CALL TRBOX(0.7,0.7)
  387.             CALL TREVOL (AXE,IPTR,CHOPT,TITOPT,ZLEGEN,NCT,NLG,INBEVO
  388.      &      ,IPOSI,XPOSI,YPOSI,ZREMP2,IDEB1,IFIN1,ISTYL)
  389.             CALL TRBOX(1./0.7,1./0.7)
  390. *PM            SEGACT AXE*MOD
  391.           ENDIF
  392. *
  393. * CAS DES CURVILIGNES
  394. *
  395.          IF (ZCUR(I)) THEN
  396. *           On affiche le long de l'axe des abscisses, avec des marqueurs,
  397. *           les noms des points nommés rencontrés
  398. *PM         SEGDES AXE
  399.             CALL TRBOX(0.7,0.7)
  400.             IPTR=IEVOLL(I)
  401.             CALL TRCUR(AXE,IPTR)
  402.             CALL TRBOX(1./0.7,1./0.7)
  403. *PM         SEGACT AXE*MOD
  404.           ENDIF
  405.  49     CONTINUE
  406. *
  407.       ENDIF
  408. C     SEGDES MEVOLL
  409.  
  410. *=============================================================
  411. *     On redessine les axes sans grille pour repasser sur d'éventuelles
  412. *     ombres
  413. *=============================================================
  414.       IF(ZREMP2) THEN
  415.         CALL TRBOX(0.7,0.7)
  416.         ZGRIL1=ZGRILL
  417.         ZGRILL=.FALSE.
  418.         CALL DAXES(AXE,ZAXES,IGRIL)
  419.         ZGRILL=ZGRIL1
  420.         CALL TRBOX (1./0.7,1./0.7)
  421.       ENDIF
  422.       RETURN
  423.  
  424. *     L'intervalle entre les bornes est trop faible.
  425. 950   CALL ERREUR (497)
  426.       END
  427.  
  428.  
  429.  
  430.  
  431.  
  432.  
  433.  
  434.  
  435.  

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