Télécharger la plaquette Cast3M


fr en

Télécharger daxes.eso

Retour à la liste

Numérotation des lignes : 

daxes

  1. C DAXES     SOURCE    SP204843  23/07/28    21:15:03     11712          
  2.  
  3.       SUBROUTINE DAXES (IPTR,ZAXES,IGRIL)
  4. *
  5. *=============================================================
  6. * Modifications :
  7. *
  8. *   95/02/07 Loca
  9. *     passer les legendes x et y de 12 à 20 caractères:
  10. *     SEGMENT AXE disparait et est appelé en include: -INC TMAXE.
  11. *
  12. *   05 sept. 2007 Maugis
  13. *     Maintien du segment AXE actif en modification
  14. *
  15. *=============================================================
  16. *
  17. * Entrée :
  18. *
  19. *  IPTR  : POINTEUR SUR UN AXE                         (ACTIF)
  20. *  ZAXES : LOGIQUE INDIQUANT DE TRACER LES AXES
  21. *
  22. *=============================================================
  23. *
  24. *  1. TOUTES LES VARIABLES COMMENCANT PAR T SONT EN SIMPLE PRECISION !
  25. *  2. PM: bien qu'aucune de ses variables ne soient modifiées, le
  26. *     segment AXE est tout de même ouvert en modification (?)
  27. *
  28. *=============================================================
  29.       IMPLICIT LOGICAL(Z)
  30.       IMPLICIT INTEGER(I-N)
  31.       IMPLICIT REAL*8 (A-H,O-S,U-Y)
  32.  
  33.       REAL HMIN
  34.  
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC CCTRACE
  39. -INC TMAXE
  40.  
  41.       EXTERNAL LONG
  42.  
  43.       CHARACTER*30 BUFFER
  44.       DIMENSION    TX(5),TY(5),TZ(5),TX2(2),TY2(2),TZ2(2)
  45.       LOGICAL      ZTIRET,ZTRAC,ZDEC1,ZDEC2
  46.  
  47. *=============================================================
  48. *  INITIALISATIONS
  49. *=============================================================
  50.  
  51.       do ii=1,5
  52.        tz(ii)=0.0
  53.       enddo
  54.       do ii=1,2
  55.        tz2(ii)=0.0
  56.       enddo
  57.       AXE=IPTR
  58.       SEGACT AXE*MOD
  59.       HMIN=.2
  60.  
  61.  
  62. *=============================================================
  63. *  TRACE DES AXES + GRADUATIONS
  64. *=============================================================
  65.  
  66. *  TRACE DES AXES ============================================
  67. *  (CADRE DEFINI PAR XINF XSUP YINF YSUP)
  68. *     couleurs definies dans bdata : 0:defaut 7:blanc 8:noir 16:gris
  69.       IF (ICOSC.EQ.2.OR.ICOSC.EQ.3) THEN
  70.          icoul0=8
  71.       ELSE
  72.          icoul0=0
  73.       ENDIF
  74.       CALL CHCOUL(icoul0)
  75.       TX(1)=REAL(XINF)
  76.       TY(1)=REAL(YINF)
  77.       TX(2)=REAL(XINF)
  78.       TY(2)=REAL(YSUP)
  79.       TX(3)=REAL(XSUP)
  80.       TY(3)=REAL(YSUP)
  81.       TX(4)=REAL(XSUP)
  82.       TY(4)=REAL(YINF)
  83.       TX(5)=REAL(XINF)
  84.       TY(5)=REAL(YINF)
  85.       CALL POLRL(5,TX,TY,tz)
  86. *
  87. *  TRACE DES GRADUATIONS SUR L'AXE X  ========================
  88.  
  89. *  TRACE DES GRADUATIONS PRINCIPALES
  90.       TDELTY=REAL(ABS(YSUP-YINF))/75.
  91.       TX(1) =REAL(XINF)
  92.       TY(1) =REAL(YINF)
  93.       TY(2) =REAL(YINF)+TDELTY
  94.       TY2(1)=REAL(YSUP)
  95.       TY2(2)=REAL(YSUP)-TDELTY
  96.       DO 1 I=2,INX+1
  97.         TX(1)=TX(1)+REAL(XINT)
  98.         IF ((TX(1)+0.001*REAL(XINT)).GE.XSUP) GOTO 1
  99.         TX(2)=TX(1)
  100.         CALL POLRL(2,TX,TY2,tz)
  101.         CALL POLRL(2,TX,TY,tz)
  102.   1   CONTINUE
  103.  
  104. *  TRACE DES GRADUATIONS NON LINEAIRES SI AXE X EN LOG
  105. c       IF (ZLOGX) THEN
  106.       IF (ZLOGX .and. INX.le.20) THEN
  107.         DO 2 J=2,8,2
  108.           TX(1) =REAL(XINF)+LOG10(REAL(J))*XINT
  109.           TY(1) =REAL(YINF)
  110.           TY(2) =REAL(YINF)+TDELTY
  111.           TY2(1)=REAL(YSUP)
  112.           TY2(2)=REAL(YSUP)-TDELTY
  113.           DO 3 I=1,INX
  114.             TX(2)=TX(1)
  115.             CALL POLRL(2,TX,TY2,tz)
  116.             CALL POLRL(2,TX,TY,tz)
  117.             TX(1)=TX(1)+REAL(XINT)
  118.   3       CONTINUE
  119.   2     CONTINUE
  120.       ENDIF
  121. *
  122. *  TRACE DES GRADUATIONS SUR L'AXE Y ========================
  123. *
  124. *  TRACE DES GRADUATIONS PRINCIPALES
  125.       TDELTX=REAL(ABS(XSUP-XINF))/70.
  126.       TY(1) =REAL(YINF)
  127.       TX(1) =REAL(XINF)
  128.       TX(2) =REAL(XINF)+TDELTX
  129.       TX2(1)=REAL(XSUP)
  130.       TX2(2)=REAL(XSUP)-TDELTX
  131.       DO 4 I=2,INY+1
  132.         TY(1)=TY(1)+REAL(YINT)
  133.         IF ((TY(1)+0.001*REAL(YINT)).GE.YSUP) GOTO 4
  134.         TY(2)=TY(1)
  135.         CALL POLRL(2,TX2,TY,tz)
  136.         CALL POLRL(2,TX,TY,tz)
  137.   4   CONTINUE
  138. *
  139. *  TRACE DES GRADUATIONS NON LINEAIRES SI AXE Y EN LOG
  140. c       IF (ZLOGY) THEN
  141.       IF (ZLOGY .and. INY.le.20) THEN
  142.         DO 5 J=2,8,2
  143.           TY(1) =REAL(YINF)+LOG10(REAL(J))*YINT
  144.           TX(1) =REAL(XINF)
  145.           TX(2) =REAL(XINF)+TDELTX
  146.           TX2(1)=REAL(XSUP)
  147.           TX2(2)=REAL(XSUP)-TDELTX
  148.           DO 6 I=1,INY
  149.             TY(2)=TY(1)
  150.             CALL POLRL(2,TX2,TY,tz)
  151.             CALL POLRL(2,TX,TY,tz)
  152.             TY(1)=TY(1)+YINT
  153.   6       CONTINUE
  154.   5     CONTINUE
  155.       ENDIF
  156.  
  157. *=============================================================
  158. *  ECRITURE DES XLABEL ET YLABEL (TITX et TITY)
  159. *=============================================================
  160.  
  161. *    J'UTILISE DES COPIES DANS BUFFER CAR AVEC LES APPELS AVEC TITREX
  162. *  TITREY SINON EN TATB SUR LE CRAY JE PAUME UNE LEGENDE EN Y
  163. *
  164. c     TITX ===============================
  165. c       ANGLE=0.d0
  166. c       IALIGN=IPOSX
  167. cbp : on utilise le tableau INFOTR de l include CCTRACE
  168.       INFOTR(1)=0
  169.       INFOTR(2)=IPOSX
  170. cbp2015-10      IF(IPOSX.eq.2) THEN
  171.       IF(IPOSX.ne.1) THEN
  172.         TXX=REAL(.5*(XSUP+XINF))
  173.       ELSE
  174. cbp     on va se mettre avant l eventuel x10^{} de l'axe X
  175. c       + on recule du nombre de caractere (on ne tient pas compte de la
  176. c         police utilisee !!!)
  177.         IF(ZCARRE) THEN
  178.           TXX=REAL(XSUP)-(.017*(XSUP-XINF)*REAL(LONG(TITREX)+3))
  179.         ELSE
  180.           TXX=REAL(XSUP)-(.011*(XSUP-XINF)*REAL(LONG(TITREX)+3))
  181.         ENDIF
  182.       ENDIF
  183.       IF(ZLOGX) THEN
  184.         TYY=REAL(YINF)-.12*(YSUP-YINF)
  185.       ELSE
  186.         TYY=REAL(YINF)-.10*(YSUP-YINF)
  187.       ENDIF
  188.       BUFFER(1:20)=TITREX(1:20)
  189.       CALL TRLABL(TXX,TYY,0.,BUFFER(1:20),20,HMIN)
  190.  
  191. c     TITY ===============================
  192. c       IALIGN=IPOSY
  193.       INFOTR(1)=0
  194.       INFOTR(2)=IPOSY
  195. cbp2015-10      IF(IPOSY.eq.2) THEN
  196.       IF(IPOSY.ne.1) THEN
  197.         TXX=REAL(XINF)-(0.99*BG)
  198.         TYY=REAL(0.5*(YSUP+YINF))
  199. c         ANGLE=90.d0
  200.         INFOTR(1)=90
  201.       ELSE
  202.         TXX=REAL(XINF)-.01*(XSUP-XINF)
  203.         TYY=REAL(YSUP)+.05*(YSUP-YINF)
  204.       ENDIF
  205.       BUFFER(1:20)=TITREY(1:20)
  206.       CALL TRLABL(TXX,TYY,0.,BUFFER(1:20),20,HMIN)
  207. cbp : je n'ai pas compris le 0. ci-dessus; dans le doute je le laisse ...
  208. c     on remet tout a 0
  209. c       ANGLE=0.d0
  210. c       IALIGN=0
  211.       INFOTR(1)=0
  212.       INFOTR(2)=0
  213.  
  214.  
  215. *=============================================================
  216. *  ECRITURE DES VALEURS DE GRADUATION SUR LES AXE
  217. *=============================================================
  218.  
  219. *-------------------------------------------------------------
  220. *  ECRITURE DES VALEURS DE GRADUATION SUR AXE X EN LINEAIRE
  221. *-------------------------------------------------------------
  222.       IF (.NOT.ZLOGX) THEN
  223. *
  224.         CALL LENCHA(MXFMT,LMX)
  225.         IF (LMX.gt.2) THEN
  226.           READ(MXFMT(3:3),FMT='(I1)',IOSTAT=IOS) LFIN
  227.           IF (MXFMT(2:2).eq.'I') THEN
  228.             IP=0
  229.           ELSE
  230.             IP=ICALP(XINF,XSUP)
  231.           ENDIF
  232.         ELSE
  233.           IP=ICALP(XINF,XSUP)
  234.         ENDIF
  235. *
  236. *       Combien de decimales utilise t'on (pour toutes les graduations)?
  237.         GRAD=XINF
  238.         ZDEC2=.true.
  239.         ZDEC1=.true.
  240.         DO I=1,INX+1
  241.           CH=GRAD/10.D0**FLOAT(IP)
  242. *         on commence par arrondir
  243.           CH = DBLE(NINT(100000.D0*CH))/100000.D0
  244. *         les 2 premieres decimales de CH sont elles nulles (<=>KCH2=0)?
  245. *         on l'ecrit comme un INTEGER
  246.           KCH2=INT(100.D0*(CH-DBLE(INT(CH))))
  247.           IF(KCH2.NE.0) ZDEC2=.false.
  248. *         la 1 premieres decimales de CH est elle nulle (<=>KCH1=0)?
  249.           KCH1=KCH2-10*INT(10.D0*(CH-DBLE(INT(CH))))
  250.           IF(KCH1.NE.0) ZDEC1=.false.
  251.           GRAD=GRAD+XINT
  252.         ENDDO
  253. *
  254. *  INITIALISATION DES VALEURS POUR LE TRACE
  255. *
  256.         GRAD=XINF
  257. c         TXX=REAL(XINF)-(.35*BG)
  258. c         TXX=REAL(XINF)-(0.55*BG)
  259. c       on se met au centre et on l'indique a INFOTR(2)
  260.         TXX=REAL(XINF)
  261.         TYY=REAL(YINF)-(.3*BB)
  262.         INFOTR(2)=2
  263.  
  264. *
  265. *  BOUCLE POUR CHAQUE PAS
  266. *
  267.         DO 7 I=1,INX+1
  268.           CH=GRAD/10.D0**FLOAT(IP)
  269. *bp, 2015/12/08: on commence par arrondir pour eviter pb avec des 9.9999
  270.           CH = DBLE(NINT(100000.D0*CH))/100000.D0
  271. *         FORMATTAGE DES VALEURS DE GRADUATION
  272.           BUFFER(1:10)='        '
  273. *        -cas format impose
  274.           IF((LMX.gt.2).and.(MXFMT(1:1).EQ.'(')) THEN
  275.             IF(CH.GE.0.D0.AND.CH.LT.10.D0) THEN
  276.               IDEB=2
  277.             ELSE
  278.               IDEB=1
  279.             ENDIF
  280.             IFIN  = IDEB+LFIN-1
  281.             IF(MXFMT(2:2).eq.'I') THEN
  282.               WRITE (BUFFER(IDEB:IFIN),FMT=MXFMT(1:LMX)) INT(CH)
  283.             ELSE
  284.               WRITE (BUFFER(IDEB:IFIN),FMT=MXFMT(1:LMX)) CH
  285.             ENDIF
  286. *        -cas format automatique
  287. *        -cas format automatique et pas d'exposant
  288. *         depuis modif de icalp, il peut y avoir jusqu'a 4 chiffres
  289.           ELSE
  290. c             write(*,*) 'X:',I,ZDEC2,ZDEC1,CH,(CH.LE.-10.D0)
  291.             IF(ZDEC2) THEN
  292.               IF (CH.LE.-1000.D0) THEN
  293.                 WRITE (BUFFER(1:9),FMT='(I5)') NINT(CH)
  294.               ELSEIF (CH.GT.-1000.D0.AND.CH.LE.-100.D0) THEN
  295.                 WRITE (BUFFER(1:9),FMT='(I4)') NINT(CH)
  296.               ELSEIF (CH.GT.-100.D0.AND.CH.LE.-10.D0) THEN
  297.                 WRITE (BUFFER(1:9),FMT='(I3)') NINT(CH)
  298.               ELSEIF (CH.GT.-10.D0.AND.CH.LT.0.D0) THEN
  299.                 WRITE (BUFFER(1:9),FMT='(I2)') NINT(CH)
  300.               ELSEIF (CH.GE.0.D0.AND.CH.LT.10.D0) THEN
  301.                 WRITE (BUFFER(1:9),FMT='(I1)') NINT(CH)
  302.               ELSEIF (CH.GE.10.D0.AND.CH.LT.100.D0) THEN
  303.                 WRITE (BUFFER(1:9),FMT='(I2)') NINT(CH)
  304.               ELSEIF (CH.GE.100.D0.AND.CH.LT.1000.D0) THEN
  305.                 WRITE (BUFFER(1:9),FMT='(I3)') NINT(CH)
  306.               ELSEIF (CH.GE.1000.D0) THEN
  307.                 WRITE (BUFFER(1:9),FMT='(I4)') NINT(CH)
  308.               ENDIF
  309.             ELSEIF(ZDEC1) THEN
  310.               IF (CH.LE.-1000.D0) THEN
  311.                 WRITE (BUFFER(1:9),FMT='(F7.1)') CH
  312.               ELSEIF (CH.GT.-1000.D0.AND.CH.LE.-100.D0) THEN
  313.                 WRITE (BUFFER(1:9),FMT='(F6.1)') CH
  314.               ELSEIF (CH.GT.-100.D0.AND.CH.LE.-10.D0) THEN
  315.                 WRITE (BUFFER(1:9),FMT='(F5.1)') CH
  316.               ELSEIF (CH.GT.-10.D0.AND.CH.LT.0.D0) THEN
  317.                 WRITE (BUFFER(1:9),FMT='(F4.1)') CH
  318.               ELSEIF (CH.GE.0.D0.AND.CH.LT.10.D0) THEN
  319.                 WRITE (BUFFER(1:9),FMT='(F3.1)') CH
  320.               ELSEIF (CH.GE.10.D0.AND.CH.LT.100.D0) THEN
  321.                 WRITE (BUFFER(1:9),FMT='(F4.1)') CH
  322.               ELSEIF (CH.GE.100.D0.AND.CH.LT.1000.D0) THEN
  323.                 WRITE (BUFFER(1:9),FMT='(F5.1)') CH
  324.               ELSEIF (CH.GE.1000.D0) THEN
  325.                 WRITE (BUFFER(1:9),FMT='(F6.1)') CH
  326.               ENDIF
  327.             ELSE
  328.               IF (CH.LE.-1000.D0) THEN
  329.                 WRITE (BUFFER(1:9),FMT='(F8.2)') CH
  330.               ELSEIF (CH.GT.-1000.D0.AND.CH.LE.-100.D0) THEN
  331.                 WRITE (BUFFER(1:9),FMT='(F7.2)') CH
  332.               ELSEIF (CH.GT.-100.D0.AND.CH.LE.-10.D0) THEN
  333.                 WRITE (BUFFER(1:9),FMT='(F6.2)') CH
  334.               ELSEIF (CH.GT.-10.D0.AND.CH.LT.0.D0) THEN
  335.                 WRITE (BUFFER(1:9),FMT='(F5.2)') CH
  336.               ELSEIF (CH.GE.0.D0.AND.CH.LT.10.D0) THEN
  337.                 WRITE (BUFFER(1:9),FMT='(F4.2)') CH
  338.               ELSEIF (CH.GE.10.D0.AND.CH.LT.100.D0) THEN
  339.                 WRITE (BUFFER(1:9),FMT='(F5.2)') CH
  340.               ELSEIF (CH.GE.100.D0.AND.CH.LT.1000.D0) THEN
  341.                 WRITE (BUFFER(1:9),FMT='(F6.2)') CH
  342.               ELSEIF (CH.GE.1000.D0) THEN
  343.                 WRITE (BUFFER(1:9),FMT='(F7.2)') CH
  344.               ENDIF
  345.             ENDIF
  346.           ENDIF
  347. *         ECRITURE DE LA GRADUATION
  348.           CALL TRLABL (TXX,TYY,0.,BUFFER(1:9),9,HMIN)
  349.           TXX=TXX+REAL(XINT)
  350.           GRAD=GRAD+XINT
  351.  
  352.   7     CONTINUE
  353.  
  354.         INFOTR(2)=0
  355. *
  356. *  ECRITURE DE P APRES FORMATTAGE
  357. *
  358.         IF (IP.NE.0) THEN
  359. c           BUFFER(1:10)='x1.E        '
  360. c           ideb=4
  361.           BUFFER(1:10)='x10^{     '
  362.           ideb=6
  363.           IF (IP.LE.-10) THEN
  364.             ideb2=ideb+3
  365.             WRITE (BUFFER(ideb:ideb+2),FMT='(I3)') IP
  366.           ELSEIF (IP.GT.-10.AND.IP.LT.0) THEN
  367.             ideb2=ideb+2
  368.             WRITE (BUFFER(ideb:ideb+1),FMT='(I2)') IP
  369.           ELSEIF (IP.GE.-10.AND.IP.LT.10) THEN
  370.             ideb2=ideb+1
  371.             WRITE (BUFFER(ideb:ideb),FMT='(I1)') IP
  372.           ELSEIF (IP.GE.10) THEN
  373.             ideb2=ideb+2
  374.             WRITE (BUFFER(ideb:ideb+1),FMT='(I2)') IP
  375.           ENDIF
  376.           BUFFER(ideb2:ideb2)='}'
  377.           TXX=REAL(XINF)-(.35*BG)
  378.           TYY=REAL(YINF-.10*(YSUP-YINF))
  379.           if(ZCARRE) then
  380.             TXX=REAL(XSUP)-(.015*(XSUP-XINF))
  381.           else
  382.             TXX=REAL(XSUP)-(.010*(XSUP-XINF))
  383.           endif
  384.           CALL TRLABL(TXX,TYY,0.,BUFFER(1:10),10,HMIN)
  385.         ENDIF
  386.  
  387. *-------------------------------------------------------------
  388. *  ECRITURE DES VALEURS DE GRADUATION SUR AXE X EN LOG
  389. *-------------------------------------------------------------
  390.       ELSE
  391.         GRAD=XINF
  392. c         TXX=REAL(XINF)-(BG/4.)
  393. c         TXX=REAL(XINF)-((BG+BD)/8.)
  394. c         TXX=REAL(XINF)-(0.15*BG)
  395.         TXX=REAL(XINF)-(0.10*BG)
  396. c         TYY=REAL(YINF)-.06*(YSUP-YINF)
  397.         TYY=REAL(YINF)-.07*(YSUP-YINF)
  398.         DO 8 I=1,INX+1
  399.           IP=INT(GRAD)
  400. c           BUFFER(1:6)='1.E   '
  401. c           ideb=4
  402.           BUFFER(1:10)='10^{     '
  403.           ideb=5
  404.           IF     (IP.LE.-100) THEN
  405.             ideb2=ideb+4
  406.             WRITE (BUFFER(ideb:ideb+3),FMT='(I4)') IP
  407.           ELSEIF (IP.GT.-100 .AND. IP.LE.-10) THEN
  408.             ideb2=ideb+3
  409.             WRITE (BUFFER(ideb:ideb+2),FMT='(I3)') IP
  410.           ELSEIF (IP.GT.-10.AND.IP.LT.0) THEN
  411.             ideb2=ideb+2
  412.             WRITE (BUFFER(ideb:ideb+1),FMT='(I2)') IP
  413.           ELSEIF (IP.GE.-10.AND.IP.LT.10) THEN
  414.             ideb2=ideb+1
  415.             WRITE (BUFFER(ideb:ideb)  ,FMT='(I1)') IP
  416.           ELSEIF (IP.GE.10 .AND. IP.LT.100) THEN
  417.             ideb2=ideb+2
  418.             WRITE (BUFFER(ideb:ideb+1),FMT='(I2)') IP
  419.           ELSEIF (IP.GE.100) THEN
  420.             ideb2=ideb+3
  421.             WRITE (BUFFER(ideb:ideb+2),FMT='(I3)') IP
  422.           ENDIF
  423.           BUFFER(ideb2:ideb2)='}'
  424.           CALL TRLABL(TXX,TYY,0.,BUFFER(1:10),10,HMIN)
  425.           TXX=TXX+XINT
  426.           GRAD=GRAD+XINT
  427.   8     CONTINUE
  428. *
  429.         IF ((XSUP-XINF) .LE. 9.D0) THEN
  430. *  ECRITURE DES VALEURS DE SOUS-GRADUATION SUR AXE X EN LOG
  431. *   UNIQUEMENT SI LA GAMME EST SUR MOINS DE 9 DECADS
  432.           DO 9  J=1,7,2
  433.             IF (J.EQ.1) THEN
  434.               TXX=REAL(XINF)
  435.             ELSE
  436.               TXX=REAL(XINF)+LOG10(REAL(J)-1.0)
  437.             ENDIF
  438.             TXX=TXX - 0.07*REAL(BG)
  439.             TYY=REAL(YINF)-(0.25*BB)
  440.             DO 10 I=1,INX
  441.               JJ=1
  442.               IF (J.GT.1) JJ=J-1
  443.               WRITE (BUFFER(1:1),FMT='(I1)') JJ
  444.               CALL TRLABL(TXX,TYY,0.,BUFFER(1:1),1,HMIN)
  445.               TXX=TXX+REAL(XINT)
  446.               IF ((I.EQ.INX).AND.(J.EQ.1)) THEN
  447.                 JJ=1
  448.                 WRITE (BUFFER(1:1),FMT='(I1)') JJ
  449.                 CALL TRLABL(TXX,TYY,0.,BUFFER(1:1),1,HMIN)
  450.               ENDIF
  451. 10          CONTINUE
  452.  9        CONTINUE
  453.         ENDIF
  454.       ENDIF
  455.  
  456.  
  457. *-------------------------------------------------------------
  458. *  ECRITURE DES VALEURS DE GRADUATION SUR AXE Y EN LINEAIRE
  459. *-------------------------------------------------------------
  460.       IF (.NOT.ZLOGY) THEN
  461. *
  462.         CALL LENCHA(MYFMT,LMY)
  463.         IF (LMY.gt.2) THEN
  464.           READ(MYFMT(3:3),FMT='(I1)',IOSTAT=IOS) LFIN
  465.           IF (MYFMT(2:2).eq.'I') THEN
  466.             IP=0
  467.           ELSE
  468.             IP=ICALP(YINF,YSUP)
  469.           ENDIF
  470.         ELSE
  471.           IP=ICALP(YINF,YSUP)
  472.         ENDIF
  473. *
  474. *       Combien de decimales utilise t'on (pour toutes les graduations)?
  475.         GRAD=YINF
  476.         ZDEC2=.true.
  477.         ZDEC1=.true.
  478.         DO I=1,INY+1
  479.           CH=GRAD/10.D0**FLOAT(IP)
  480. *         on commence par arrondir
  481.           CH = DBLE(NINT(100000.D0*CH))/100000.D0
  482. *         les 2 premieres decimales de CH sont elles nulles (<=>KCH2=0)?
  483. *         on l'ecrit comme un INTEGER
  484.           KCH2=INT(100.D0*(CH-DBLE(INT(CH))))
  485.           IF(KCH2.NE.0) ZDEC2=.false.
  486. *         la 1 premieres decimales de CH est elle nulle (<=>KCH1=0)?
  487.           KCH1=KCH2-10*INT(10.D0*(CH-DBLE(INT(CH))))
  488.           IF(KCH1.NE.0) ZDEC1=.false.
  489.           GRAD=GRAD+YINT
  490.         ENDDO
  491. *
  492. *  INITIALISATION DES VALEURS POUR LE TRACE
  493. *
  494.         GRAD=YINF
  495.         TYY=REAL(YINF)
  496. c       si postscript, on se decale de l'axe de maniere a arriver a ras
  497. c       + on indique qu on veut etre aligne a droite
  498.         IF (IOGRA.ge.7.and.IOGRA.le.9) then
  499.           TXX=REAL(XINF)-(BG*0.10)
  500.           INFOTR(2)=3
  501.         else
  502. c       si pas postscript, on se decale de l'axe de maniere approximative
  503.           TXX=REAL(XINF)-(BG*0.9)
  504.         endif
  505. *
  506. *  BOUCLE POUR CHAQUE PAS
  507. *
  508.         DO 11 I=1,INY+1
  509.           CH=GRAD/10.D0**FLOAT(IP)
  510. *bp, 2015/12/08: on commence par arrondir pour eviter pb avec des 9.9999
  511.           CH = DBLE(NINT(100000.D0*CH))/100000.D0
  512. *         FORMATTAGE DES VALEURS DE GRADUATION
  513.           BUFFER(1:10)='          '
  514. *        -cas format impose
  515.           IF((LMY.gt.2).and.(MYFMT(1:1).EQ.'(')) THEN
  516.             IF(CH.GE.0.D0.AND.CH.LT.10.D0) THEN
  517.               IDEB=2
  518.             ELSE
  519.               IDEB=1
  520.             ENDIF
  521.             IFIN = IDEB+LFIN-1
  522.             IF(MYFMT(2:2).eq.'I') THEN
  523.               WRITE (BUFFER(IDEB:IFIN),FMT=MYFMT(1:LMY)) INT(CH)
  524.             ELSE
  525.               WRITE (BUFFER(IDEB:IFIN),FMT=MYFMT(1:LMY)) CH
  526.             ENDIF
  527. *        -cas format automatique
  528.           ELSE
  529. c             write(*,*) 'Y:',I,ZDEC2,ZDEC1,CH,(CH.LE.-10.D0)
  530.             IF(ZDEC2) THEN
  531.               IF (CH.LE.-1000.D0) THEN
  532.                 WRITE (BUFFER(1:9),FMT='(I5)') NINT(CH)
  533.               ELSEIF (CH.GT.-1000.D0.AND.CH.LE.-100.D0) THEN
  534.                 WRITE (BUFFER(1:9),FMT='(I4)') NINT(CH)
  535.               ELSEIF (CH.GT.-100.D0.AND.CH.LE.-10.D0) THEN
  536.                 WRITE (BUFFER(1:9),FMT='(I3)') NINT(CH)
  537.               ELSEIF (CH.GT.-10.D0.AND.CH.LT.0.D0) THEN
  538.                 WRITE (BUFFER(1:9),FMT='(I2)') NINT(CH)
  539.               ELSEIF (CH.GE.0.D0.AND.CH.LT.10.D0) THEN
  540.                 WRITE (BUFFER(1:9),FMT='(I1)') NINT(CH)
  541.               ELSEIF (CH.GE.10.D0.AND.CH.LT.100.D0) THEN
  542.                 WRITE (BUFFER(1:9),FMT='(I2)') NINT(CH)
  543.               ELSEIF (CH.GE.100.D0.AND.CH.LT.1000.D0) THEN
  544.                 WRITE (BUFFER(1:9),FMT='(I3)') NINT(CH)
  545.               ELSEIF (CH.GE.1000.D0) THEN
  546.                 WRITE (BUFFER(1:9),FMT='(I4)') NINT(CH)
  547.               ENDIF
  548.             ELSEIF(ZDEC1) THEN
  549.               IF (CH.LE.-1000.D0) THEN
  550.                 WRITE (BUFFER(1:9),FMT='(F7.1)') CH
  551.               ELSEIF (CH.GT.-1000.D0.AND.CH.LE.-100.D0) THEN
  552.                 WRITE (BUFFER(1:9),FMT='(F6.1)') CH
  553.               ELSEIF (CH.GT.-100.D0.AND.CH.LE.-10.D0) THEN
  554.                 WRITE (BUFFER(1:9),FMT='(F5.1)') CH
  555.               ELSEIF (CH.GT.-10.D0.AND.CH.LT.0.D0) THEN
  556.                 WRITE (BUFFER(1:9),FMT='(F4.1)') CH
  557.               ELSEIF (CH.GE.0.D0.AND.CH.LT.10.D0) THEN
  558.                 WRITE (BUFFER(1:9),FMT='(F3.1)') CH
  559.               ELSEIF (CH.GE.10.D0.AND.CH.LT.100.D0) THEN
  560.                 WRITE (BUFFER(1:9),FMT='(F4.1)') CH
  561.               ELSEIF (CH.GE.100.D0.AND.CH.LT.1000.D0) THEN
  562.                 WRITE (BUFFER(1:9),FMT='(F5.1)') CH
  563.               ELSEIF (CH.GE.1000.D0) THEN
  564.                 WRITE (BUFFER(1:9),FMT='(F6.1)') CH
  565.               ENDIF
  566.             ELSE
  567.               IF (CH.LE.-1000.D0) THEN
  568.                 WRITE (BUFFER(1:9),FMT='(F8.2)') CH
  569.               ELSEIF (CH.GT.-1000.D0.AND.CH.LE.-100.D0) THEN
  570.                 WRITE (BUFFER(1:9),FMT='(F7.2)') CH
  571.               ELSEIF (CH.GT.-100.D0.AND.CH.LE.-10.D0) THEN
  572.                 WRITE (BUFFER(1:9),FMT='(F6.2)') CH
  573.               ELSEIF (CH.GT.-10.D0.AND.CH.LT.0.D0) THEN
  574.                 WRITE (BUFFER(1:9),FMT='(F5.2)') CH
  575.               ELSEIF (CH.GE.0.D0.AND.CH.LT.10.D0) THEN
  576.                 WRITE (BUFFER(1:9),FMT='(F4.2)') CH
  577.               ELSEIF (CH.GE.10.D0.AND.CH.LT.100.D0) THEN
  578.                 WRITE (BUFFER(1:9),FMT='(F5.2)') CH
  579.               ELSEIF (CH.GE.100.D0.AND.CH.LT.1000.D0) THEN
  580.                 WRITE (BUFFER(1:9),FMT='(F6.2)') CH
  581.               ELSEIF (CH.GE.1000.D0) THEN
  582.                 WRITE (BUFFER(1:9),FMT='(F7.2)') CH
  583.               ENDIF
  584.             ENDIF
  585.           ENDIF
  586. *         ECRITURE DE LA GRADUATION
  587.           CALL TRLABL (TXX,TYY,0.,BUFFER(1:9),9,HMIN)
  588.           TYY=TYY+REAL(YINT)
  589.           GRAD=GRAD+YINT
  590.  11     CONTINUE
  591.  
  592.         INFOTR(2)=0
  593. *
  594. *  ECRITURE APRES FORMATTAGE DE P
  595. *
  596.         IF (IP.NE.0) THEN
  597. c           BUFFER(1:10)='x1.E        '
  598. c           ideb=5
  599.           BUFFER(1:10)='x10^{     '
  600.           ideb=6
  601.           IF (IP.LE.-10) THEN
  602.             ideb2=ideb+3
  603.             WRITE (BUFFER(ideb:ideb+2),FMT='(I3)') IP
  604.           ELSEIF (IP.GT.-10.AND.IP.LT.0) THEN
  605.             ideb2=ideb+2
  606.             WRITE (BUFFER(ideb:ideb+1),FMT='(I2)') IP
  607.           ELSEIF (IP.GE.-10.AND.IP.LT.10) THEN
  608.             ideb2=ideb+1
  609.             WRITE (BUFFER(ideb:ideb),FMT='(I1)') IP
  610.           ELSEIF (IP.GE.10) THEN
  611.             ideb2=ideb+2
  612.             WRITE (BUFFER(ideb:ideb+1),FMT='(I2)') IP
  613.           ENDIF
  614.           BUFFER(ideb2:ideb2)='}'
  615.           TXX=REAL(XINF)-(BG*0.9)
  616.           TYY=REAL((YSUP)+.05*(YSUP-YINF))
  617.           CALL TRLABL(TXX,TYY,0.,BUFFER(1:10),10,HMIN)
  618.         ENDIF
  619. *
  620. *-------------------------------------------------------------
  621. *  ECRITURE DES VALEURS DE GRADUATION SUR AXE Y EN LOG
  622. *-------------------------------------------------------------
  623.       ELSE
  624.         GRAD=YINF
  625. c         TXX=REAL(XINF)-(BG*0.99)
  626. c         TXX=REAL(XINF)-(BG*0.8)
  627.         IF ((YSUP-YINF).LE.6.D0) THEN
  628.           TXX=REAL(XINF)-(BG*0.82)
  629.         ELSE
  630.           TXX=REAL(XINF)-(BG*0.77)
  631.         ENDIF
  632.         TYY=REAL(YINF)
  633.         DO 12 I=1,INY+1
  634. cbpessai *        on saute 1 sur 2 si plus de 20
  635. cbpessai          if(INY.LE.20.or.MOD(I,2).ne.0) then
  636.           IP=INT(GRAD)
  637. c           BUFFER(1:3)='1.E'
  638. c           ideb=4
  639.           BUFFER(1:10)='10^{     '
  640.           ideb=5
  641.           IF     (IP.LE.-100) THEN
  642.             ideb2=ideb+4
  643.             WRITE (BUFFER(ideb:ideb+3),FMT='(I4)') IP
  644.           ELSEIF (IP.GT.-100 .AND. IP.LE.-10) THEN
  645.             ideb2=ideb+3
  646.             WRITE (BUFFER(ideb:ideb+2),FMT='(I3)') IP
  647.           ELSEIF (IP.GT.-10.AND.IP.LT.0) THEN
  648.             ideb2=ideb+2
  649.             WRITE (BUFFER(ideb:ideb+1),FMT='(I2)') IP
  650.           ELSEIF (IP.GE.-10.AND.IP.LT.10) THEN
  651.             ideb2=ideb+1
  652.             WRITE (BUFFER(ideb:ideb)  ,FMT='(I1)') IP
  653.           ELSEIF (IP.GE.10 .AND. IP.LT.100) THEN
  654.             ideb2=ideb+2
  655.             WRITE (BUFFER(ideb:ideb+1),FMT='(I2)') IP
  656.           ELSEIF (IP.GE.100) THEN
  657.             ideb2=ideb+3
  658.             WRITE (BUFFER(ideb:ideb+2),FMT='(I3)') IP
  659.           ENDIF
  660.           BUFFER(ideb2:ideb2)='}'
  661.           CALL TRLABL(TXX,TYY,0.,BUFFER(1:10),10,HMIN)
  662.           TYY=TYY+REAL(YINT)
  663.           GRAD=GRAD+YINT
  664.  12     CONTINUE
  665. *
  666.         IF ((YSUP-YINF) .LE. 6.D0) THEN
  667. *  ECRITURE DES VALEURS DE SOUS-GRADUATION SUR AXE Y EN LOG
  668. *   UNIQUEMENT SI LA GAMME EST SUR MOINS DE 6 DECADS
  669.           DO 13 J=1,7,2
  670.             IF (J.EQ.1) THEN
  671.               TYY=REAL(YINF)
  672.             ELSE
  673.               TYY=REAL(YINF)+LOG10(REAL(J)-1.0)
  674.             ENDIF
  675.             TYY=TYY - real(BB)/30.0
  676.             TXX=REAL(XINF)-REAL(0.2*BG)
  677.             DO 14 I=1,INY
  678.               JJ=1
  679.               IF (J.GT.1) JJ=J-1
  680.               WRITE(BUFFER(1:1),FMT='(I1)') JJ
  681.               CALL TRLABL(TXX,TYY,0.,BUFFER(1:1),1,HMIN)
  682.               TYY=TYY+YINT
  683.               IF ((I.EQ.INY).AND.(J.EQ.1)) THEN
  684.                 JJ=1
  685.                 WRITE(BUFFER(1:1),FMT='(I1)') JJ
  686.                 CALL TRLABL(TXX,TYY,0.,BUFFER(1:1),1,HMIN)
  687.               ENDIF
  688.  14         CONTINUE
  689.  13       CONTINUE
  690.         ENDIF
  691.       ENDIF
  692.  
  693.  
  694. *=============================================================
  695. *  TRACE DE GRILLE
  696. *=============================================================
  697.       IF (ZGRILL) THEN
  698. c       grille en gris ?
  699.         icoul1=icoul0
  700.         if(IGRIL.lt.0) then
  701.           icoul1=15
  702.           CALL CHCOUL(icoul1)
  703.         endif
  704.  
  705. c       bp faut-il faire des pointillés?
  706.         IGRILA= abs(IGRIL)
  707.         ZTIRET=(IGRILA.gt.1)
  708.         IGRIL1= IGRILA-1
  709.         DXEVL = XSUP-XINF
  710.         DL    = DXEVL/100.D0
  711.         ZTRAC =.TRUE.
  712.  
  713. *       trace grille secondaire (nonlineaire) si axe x en log
  714. *       (en pointillés gris)
  715.         IF (ZLOGX) THEN
  716.           CALL CHCOUL(15)
  717.           GRAD=XINF
  718.           DO 151 I=1,INX
  719.             TX1=REAL(GRAD+FLOAT(I-1)*XINT)
  720. *           trace grille non lineaire si axe x en log (pointillés gris)
  721.             DO 155 J=2,9,1
  722.                 TX(1)=TX1+LOG10(REAL(J))*XINT
  723.                 TX(2)=TX(1)
  724.                 TY(1)=REAL(YINF)
  725.                 TY(2)=REAL(YSUP)
  726.                 CALL TRSEG (IPTR,TX,TY,.true.,5,DL,ZTRAC)
  727.  155        CONTINUE
  728.  151      CONTINUE
  729.           CALL CHCOUL(icoul1)
  730.         ENDIF
  731.  
  732. c       grille des x
  733.         IF (INX.GT.1)THEN
  734.           GRAD=XINF
  735.           DO 15 I=1,INX
  736.             TX(1)=REAL(GRAD+FLOAT(I)*XINT)
  737.             IF ((TX(1)+0.001*XINT).GE.XSUP) GOTO 15
  738.             TX(2)=TX(1)
  739.             TY(1)=REAL(YINF)
  740.             TY(2)=REAL(YSUP)
  741. c             CALL POLRL (2,TX,TY,tz)
  742.             CALL TRSEG (IPTR,TX,TY,ZTIRET,IGRIL1,DL,ZTRAC)
  743.  15       CONTINUE
  744.         ENDIF
  745.  
  746. *       trace grille secondaire (nonlineaire) si axe y en log
  747. *       (en pointillés gris)
  748.         IF (ZLOGY) THEN
  749.           CALL CHCOUL(15)
  750.           GRAD=YINF
  751.           DO 161 I=1,INY
  752.             TY1=REAL(GRAD+FLOAT(I-1)*YINT)
  753. *           trace grille non lineaire si axe y en log (pointillés gris)
  754.             DO 165 J=2,9,1
  755.                 TX(1)=REAL(XINF)
  756.                 TX(2)=REAL(XSUP)
  757.                 TY(1)=TY1+LOG10(REAL(J))*YINT
  758.                 TY(2)=TY(1)
  759.                 CALL TRSEG(IPTR,TX,TY,.true.,5,DL,ZTRAC)
  760.  165        CONTINUE
  761.  161      CONTINUE
  762.           CALL CHCOUL(icoul1)
  763.         ENDIF
  764.  
  765. c       grille des y
  766.         IF (INY.GT.1)THEN
  767.           GRAD=YINF
  768.           DO 16 I=1,INY
  769.             TX(1)=REAL(XINF)
  770.             TX(2)=REAL(XSUP)
  771.             TY(1)=REAL(GRAD+FLOAT(I)*YINT)
  772.             IF ((TY(1)+0.001*YINT).GE.YSUP) GOTO 16
  773.             TY(2)=TY(1)
  774. c             CALL POLRL (2,TX,TY,tz)
  775.             CALL TRSEG (IPTR,TX,TY,ZTIRET,IGRIL1,DL,ZTRAC)
  776.  16       CONTINUE
  777.         ENDIF
  778.  
  779. c       on remet la couleur des axes
  780.         CALL CHCOUL(icoul0)
  781.  
  782.       ENDIF
  783.  
  784.  
  785. *=============================================================
  786. *  TRACE DES AXES Ox et Oy, UNIQUEMENT EN LINEAIRE
  787. *=============================================================
  788. *
  789.       IF (ZAXES) THEN
  790.         IF (.NOT.ZLOGX.AND.XINF*XSUP.LE.0.D0) THEN
  791.           TX(1)=0.
  792.           TX(2)=0.
  793.           TY(1)=REAL(YINF)
  794.           TY(2)=REAL(YSUP)+3.*TDELTY
  795.           CALL POLRL (2,TX,TY,tz)
  796.           TX(1)=-0.5*TDELTX
  797.           TX(3)=0.5*TDELTX
  798.           TY(1)=TY(2)-TDELTY
  799.           TY(3)=TY(1)
  800.           CALL POLRL (3,TX,TY,tz)
  801. *          BUFFER(1:2)='Oy'
  802. *          TXX=TDELTX
  803. *          TYY=REAL(YSUP)+2.*TDELTY
  804. *          CALL TRLABL(TXX,TYY,0.,BUFFER(1:2),2,HMIN)
  805.         ENDIF
  806.         IF (.NOT.ZLOGY.AND.YINF*YSUP.LE.0.D0) THEN
  807.           TX(1)=REAL(XINF)
  808.           TX(2)=REAL(XSUP)+3.*TDELTX
  809.           TY(1)=0.
  810.           TY(2)=0.
  811.           CALL POLRL (2,TX,TY,tz)
  812.           TY(1)=0.5*TDELTY
  813.           TY(3)=-0.5*TDELTY
  814.           TX(1)=TX(2)-TDELTX
  815.           TX(3)=TX(1)
  816.           CALL POLRL (3,TX,TY,tz)
  817. *          BUFFER(1:2)='Ox'
  818. *          TXX=REAL(XSUP)+3.*TDELTX
  819. *          TYY=-2.*TDELTY
  820. *          CALL TRLABL(TXX,TYY,0.,BUFFER(1:2),2,HMIN)
  821.         ENDIF
  822.       ENDIF
  823. *
  824. *PM   SEGDES AXE
  825. *
  826.       END
  827.  
  828.  
  829.  
  830.  
  831.  
  832.  
  833.  
  834.  
  835.  
  836.  
  837.  
  838.  
  839.  
  840.  
  841.  
  842.  
  843.  

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