Télécharger la plaquette Cast3M


fr en

Télécharger strini.eso

Retour à la liste

Numérotation des lignes : 

strini

  1. C STRINI    SOURCE    GOUNAND   23/01/20    21:15:03     11563          
  2. C     INTERFACE POUR GENERATION DE POSTSCRIPT
  3. C     LES POINTS D'ENTREE EN C SONT POUR LA COULEUR
  4. C
  5.       SUBROUTINE STRINI(NOL,AXAX,AYAY,TITR,HAUTT,VALEU,NCOUMA)
  6.       IMPLICIT INTEGER(I-N)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC CCTRACE
  11.       EXTERNAL LONG
  12.       DIMENSION XTR(*),YTR(*)
  13.       CHARACTER*(*) TITR,CARAC,PROMPT,REPLY
  14.       CHARACTER*(500) LEGEND
  15.       CHARACTER*(LOCHAI) TITRE
  16.       CHARACTER*128 CHAINE
  17.       LOGICAL VALEU,FENE,VALEUR,FENET
  18. C SG 2016/11/29 On laisse Postscript faire le clipping
  19. C               mais au-dela de [ICLIPB,ICLIPH]
  20. C               il y a erreur de sortie car on écrit au format I4
  21.       PARAMETER(ICLIPB=-999,ICLIPH=9999)
  22. *
  23.       SAVE XIOCAD,YIOCAD,VALEUR,FENET,TITRE,LTITRE
  24.       SAVE XMIN,YMIN,XXAX,YYAX,CLX,XRAP,YRAP,XDEP,YDEP
  25. *SG 2016/04/20
  26. * Il y a 3 espaces de couleurs pour les Postscript N&B ou couleur
  27. * 1) Les couleurs en /C? et /D? qui correspondent aux couleurs
  28. *    nommees de Castem (operateur COUL)
  29. * 2) Les couleurs en /c? et /d? qui correspondent aux couleurs de
  30. *    l'echelle (du bleu au rouge) lorsqu'il y a moins de 16 isovaleurs
  31. *    demandees
  32. * 3) Les couleurs en /e? et /f? qui correspondent aux couleurs de
  33. *    l'echelle (du bleu au rouge) lorsqu'il y a plus de 16 isovaleurs
  34. *    demandees
  35. * iespc correspond a l'espace de couleur courant (1 a 3)
  36. * icoul a la couleur dans l'espace de couleur courant
  37. * Convention : iespc ou icoul=-3 si non definie
  38. * Ceci permet d'emettre des changements de couleur dans le Postscript
  39. * uniquement si necessaire
  40.       save iespc,icoul,initia,ipag,miso,lfont
  41.       PARAMETER(IUPS=24)
  42. c       DIMENSION ITB(17)
  43. c       CHARACTER*17 ctb
  44.       DIMENSION ITB(32)
  45.       CHARACTER*32 ctb
  46.       CHARACTER*64 ctc
  47.       CHARACTER*6 cha
  48. C
  49. C     SG 2023/01 : les tableaux ci-dessous seraient peut-etre bien dans
  50. C     le BLOCK DATA car utilisables ailleurs (option.eso, chaips.eso)
  51. C
  52.       PARAMETER (NFONT=4,LMFONT=11)
  53.       CHARACTER*(LMFONT) TFONT(NFONT)
  54.       CHARACTER*(LMFONT) MOFONT
  55. *     Tableaux de correspondance entre la valeur de IOPOTR (CCOPTIO)
  56. *     et le nom (indice dans TFONT) et la taille (hauteur) de la fonte
  57.       PARAMETER (NBPOTR=16)
  58.       INTEGER NOFONT(NBPOTR)
  59.       INTEGER HAFONT(NBPOTR)
  60.  
  61.       data  initia/0/
  62.       data ipag/1/
  63. c              1 2  3 4 5 6  7  8  9 10 11 12 13 14 15 16 17 18 ...
  64.       data itb/1,5,13,3,9,7,11,15,16,4, 12, 2, 8, 6,10,14,17,18,19,20,
  65.      >        21,22,23,24,25,26,27,28,29,30,31,1/
  66.       data ctb/'0123456789ABCDEFGHIJKMNOPQRTUVWX'/
  67. c     itb(0+1)=1   ->  /D0 : NOIR
  68. c     itb(1+1)=5   ->  /D4 : BLEU
  69. c     itb(2+1)=13  ->  /DC : ROUG
  70. c     itb(3+1)=3   ->  /D2 : ROSE
  71. c     ...
  72. c     itb(7+1)=15  ->  /DE : BLAN
  73. c     itb(8+1)=16  ->  /DF : NOIR
  74. c     ...
  75. c     itb(15+1)=14 ->  /DD : GRIS
  76. c     itb(16+1)=17 ->  /DG : POUR
  77. c     ...
  78.       data ctc/'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123
  79.      >456789&@'/
  80.       data miso/0/
  81.       data TFONT(1) /'Courier    '/
  82.       data TFONT(2) /'CourierBold'/
  83.       data TFONT(3) /'Helvetica  '/
  84.       data TFONT(4) /'Times      '/
  85.       data NOFONT/1,2,3,4,1,2,3,4,1,2,3,4,1,2,3,4/
  86.       data HAFONT/12,12,12,12,14,14,14,14,16,16,16,16,18,18,18,18/
  87.  
  88. * verification des bornes
  89.       bornex(xxx)=min(max(xiocad*0.01,xxx),xiocad*0.99)
  90.       borney(yyy)=min(max(yiocad*0.01,yyy),yiocad*0.99)
  91. C JYYY Debut
  92. C SG 2016/11/29 On laisse Postscript faire le clipping
  93. C               mais au-dela de [ICLIPB,ICLIPH]
  94. C               il y a erreur de sortie car on écrit au format I4
  95. c$$$      Iorncx(xxx)=int((min(max(xiocad*0.01,xxx),xiocad*0.99))/0.004)
  96. c$$$      Iorncy(yyy)=int((min(max(yiocad*0.01,yyy),yiocad*0.99))/0.004)
  97. * Ma correction
  98.       Iorncx(xxx)=min(max(nint(xxx/0.004),ICLIPB),ICLIPH)
  99.       Iorncy(yyy)=min(max(nint(yyy/0.004),ICLIPB),ICLIPH)
  100. C JYYY Fin
  101.  
  102. C     Taille par defaut de la fonte de caracteres :
  103.       LFONT = 14
  104. *
  105. C======================================================================
  106. C     INITIALISATION : STRINI ou CTRINI
  107. C======================================================================
  108.  
  109.       ENTRY CTRINI(NOL,AXAX,AYAY,TITR,HAUTT,VALEU,NCOUMA)
  110.  
  111. *  on part pour 64 couleurs
  112.       NCOUMA=64
  113.       iespc=-3
  114.       icoul=-3
  115.       lo=len(titr)
  116.       TITRE=TITR
  117.       LTITRE=long(titre)
  118.       VALEUR=VALEU
  119. *  INITIALISATION DE POSTSCRIPT
  120.       CLX=0.3
  121.       if (ZHORIZ) then
  122.          xiocad=diocad
  123.          yiocad=xiocad*21/29.7
  124.       else
  125.          yiocad=diocad
  126.          xiocad=yiocad*21/27.7
  127.       endif
  128.  
  129. *  ECRITURE DU PROLOGUE DU POSTSCRIPT
  130.       if (ZINIPS) then
  131.          ZINIPS = .false.
  132. c  ... on met IPAG à 1 pour recommencer à numéroter correctement ...
  133.          ipag = 1
  134.          initia=1
  135.          iespc=-3
  136.          icoul=-3
  137.          write (IUPS,897)
  138.          write (IUPS,898)
  139.          write (IUPS,899)
  140.          if (ZHORIZ) then
  141.             write (IUPS,900)
  142.          else
  143.             write (IUPS,1900)
  144.          endif
  145.          write (IUPS,901)
  146.          write (IUPS,902)
  147.          write (IUPS,903)
  148.          write (IUPS,904)
  149.          write (IUPS,906)
  150.          write (IUPS,907)
  151.          write (IUPS,908)
  152.          write (IUPS,909)
  153.          write (IUPS,910)
  154.          write (IUPS,911)
  155.          write (IUPS,912)
  156.          write (IUPS,913)
  157. C JYYY Debut
  158.          write (IUPS,'(A)') '/DL{NP MV {LN}repeat SK } def'
  159.          write (IUPS,'(A)') '/DS{NP MV {LN}repeat FI } def'
  160.          write (IUPS,'(A)') '/H0{.1 .1 scale}def'
  161.          write (IUPS,'(A)') '/H1{10 10 scale}def'
  162.          write (IUPS,'(A)') '/CX4{0.004 div} def'
  163.          write (IUPS,'(A)') '/MX{moveto H1} def'
  164.          write (IUPS,'(A)') '/SX {show H0} def'
  165.          write (IUPS,'(A)')
  166.      +        '/center {stringwidth pop 2 div neg 0 rmoveto} def'
  167. c      + '/center {dup stringwidth pop 2 div neg 0 rmoveto} def'
  168.          write (IUPS,'(A)')
  169.      +        '/right {stringwidth pop neg 0 rmoveto} def'
  170. C JYYY Fin
  171.          write (IUPS,914)
  172.          write (IUPS,915)
  173.          write (IUPS,916)
  174.          write (IUPS,917)
  175.          write (IUPS,918)
  176.          write (IUPS,919)
  177.          write (IUPS,920)
  178.          write (IUPS,921)
  179.          write (IUPS,922)
  180.          write (IUPS,923)
  181.          write (IUPS,924)
  182.          write (IUPS,925)
  183.          write (IUPS,926)
  184.          write (IUPS,927)
  185.          write (IUPS,928)
  186.          write (IUPS,929)
  187.          write (IUPS,930)
  188.          write (IUPS,931)
  189.          write (IUPS,932)
  190.          write (IUPS,933)
  191.          write (IUPS,934)
  192.          write (IUPS,935)
  193.          write (IUPS,936)
  194.          write (IUPS,937)
  195.          write (IUPS,938)
  196.          write (IUPS,939)
  197.          write (IUPS,940)
  198.          write (IUPS,941)
  199.          write (IUPS,942)
  200.          write (IUPS,943)
  201.          write (IUPS,944)
  202.          write (IUPS,945)
  203.          write (IUPS,1931)
  204.          write (IUPS,1932)
  205.          write (IUPS,1933)
  206.          write (IUPS,1934)
  207.          write (IUPS,1935)
  208.          write (IUPS,1936)
  209.          write (IUPS,1937)
  210.          write (IUPS,1938)
  211.          write (IUPS,1939)
  212.          write (IUPS,1940)
  213.          write (IUPS,1941)
  214.          write (IUPS,1942)
  215.          write (IUPS,1943)
  216.          write (IUPS,1944)
  217.          write (IUPS,1945)
  218.          write (IUPS,1946)
  219.          write (IUPS,813)
  220.          write (IUPS,814)
  221.          write (IUPS,815)
  222.          write (IUPS,816)
  223.          write (IUPS,817)
  224.          write (IUPS,818)
  225.          write (IUPS,819)
  226.          write (IUPS,820)
  227.          write (IUPS,821)
  228.          write (IUPS,822)
  229.          write (IUPS,823)
  230.          write (IUPS,824)
  231.          write (IUPS,825)
  232.          write (IUPS,826)
  233.          write (IUPS,827)
  234.          write (IUPS,828)
  235.          write (IUPS,829)
  236.          write (IUPS,830)
  237.          write (IUPS,831)
  238.          write (IUPS,832)
  239.          write (IUPS,833)
  240.          write (IUPS,834)
  241.          write (IUPS,835)
  242.          write (IUPS,836)
  243.          write (IUPS,837)
  244.          write (IUPS,838)
  245.          write (IUPS,839)
  246.          write (IUPS,840)
  247.          write (IUPS,841)
  248.          write (IUPS,842)
  249.          write (IUPS,843)
  250.          write (IUPS,844)
  251.          write (IUPS,845)
  252.          write (IUPS,880)
  253.          write (IUPS,881)
  254.          write (IUPS,882)
  255.          write (IUPS,883)
  256.          write (IUPS,884)
  257.          write (IUPS,885)
  258.          write (IUPS,886)
  259.          write (IUPS,887)
  260.          write (IUPS,888)
  261.          write (IUPS,889)
  262.          write (IUPS,890)
  263.          write (IUPS,891)
  264.          write (IUPS,892)
  265.          write (IUPS,893)
  266.          write (IUPS,894)
  267.          write (IUPS,895)
  268. c        write (IUPS,947)
  269. * bp : choix de la police tq definie dans option.eso
  270. C     SG Initialisation de toutes les fontes du tableau TFONT
  271.          do ifont=1,nfont
  272.             MOFONT=TFONT(ifont)
  273.             lmf=long(MOFONT)
  274.             write(IUPS,1844) MOFONT(1:lmf),MOFONT(1:lmf)
  275.          enddo
  276.          if (ZHORIZ) then
  277.             write (IUPS,948)
  278.          else
  279.             write (IUPS,1948)
  280.          endif
  281.          write (IUPS,949)
  282.  897     format ('%!PS-Adobe-1.0')
  283.  898     format ('%%Creator: Cast3m - CEA/DEN/DM2S/SEMT')
  284.  899     format ('%%BoundingBox: 0 0 593 841')
  285.  900     format ('%%Orientation: Landscape')
  286.  1900    format ('%%Orientation: Portrait')
  287.  901     format('200 dict begin')
  288.  902     format ('/StartPage{/sv save def}def')
  289.  903     format ('/EndPage{showpage sv restore}def')
  290.  904     format ('1 setlinecap 0 setlinejoin')
  291.  905     format (I2,' setlinewidth')
  292.  906     format ('/CM4 { 0.04 div } def')
  293.  907     format ('/NP { newpath } def')
  294.  908     format ('/MV { moveto } def')
  295.  909     format ('/LN { lineto } def')
  296.  910     format ('/SK { stroke } def')
  297.  911     format ('/FI { fill   } def')
  298.  912     format ('/S  { show   } def')
  299. * SG 2016/04/20
  300. * Espace de couleurs 1 correspondent aux couleurs nommees de Castem (operateur COUL)
  301.  913     format ('/CN { 1.     setgray } def')
  302.  914     format ('/C0 { 1.     setgray } def')
  303.  915     Format ('/C4 { 0.333  setgray } def')
  304.  916     format ('/CC { 0.333  setgray } def')
  305.  917     format ('/C2 { 0.666  setgray } def')
  306.  918     format ('/C8 { 0.333  setgray } def')
  307.  919     format ('/C6 { 0.633  setgray } def')
  308.  920     format ('/CA { 0.666  setgray } def')
  309.  921     format ('/CE { 1.000  setgray } def')
  310.  922     format ('/CF { 0.000  setgray } def')
  311.  923     format ('/C3 { 0.469  setgray } def')
  312.  924     format ('/CB { 0.549  setgray } def')
  313.  925     format ('/C1 { 0.560  setgray } def')
  314.  926     format ('/C7 { 0.460  setgray } def')
  315.  927     format ('/C5 { 0.772  setgray } def')
  316.  928     format ('/C9 { 0.534  setgray } def')
  317.  929     format ('/CD { 0.827  setgray } def')
  318.  930     format ('/CG { 0.501  setgray } def')
  319.  931     format ('/CH { 0.296  setgray } def')
  320.  932     format ('/CI { 0.321  setgray } def')
  321.  933     format ('/CJ { 0.603  setgray } def')
  322.  934     format ('/CK { 0.844  setgray } def')
  323.  935     format ('/CM { 0.614  setgray } def')
  324.  936     format ('/CN { 0.167  setgray } def')
  325.  937     format ('/CO { 0.130  setgray } def')
  326.  938     format ('/CP { 0.620  setgray } def')
  327.  939     format ('/CQ { 0.928  setgray } def')
  328.  940     format ('/CR { 0.542  setgray } def')
  329.  941     format ('/CT { 0.797  setgray } def')
  330.  942     format ('/CU { 0.823  setgray } def')
  331.  943     format ('/CV { 0.524  setgray } def')
  332.  944     format ('/CW { 0.294  setgray } def')
  333.  945     format ('/CX { 0.52   setgray } def')
  334.  
  335.  1931     Format ('/c1 { 0.98  setgray } def')
  336.  1932     format ('/c3 { 0.95  setgray } def')
  337.  1933     format ('/c5 { 0.91  setgray } def')
  338.  1934     format ('/c7 { 0.86  setgray } def')
  339.  1935     format ('/c9 { 0.80  setgray } def')
  340.  1936     format ('/cB { 0.73  setgray } def')
  341.  1937     format ('/cD { 0.65  setgray } def')
  342.  1938     format ('/cF { 0.56  setgray } def')
  343.  1939     format ('/c2 { 0.965 setgray } def')
  344.  1940     format ('/c4 { 0.93  setgray } def')
  345.  1941     format ('/c6 { 0.885 setgray } def')
  346.  1942     format ('/c8 { 0.83  setgray } def')
  347.  1943     format ('/cA { 0.765 setgray } def')
  348.  1944     format ('/cC { 0.69  setgray } def')
  349.  1945     format ('/cE { 0.605 setgray } def')
  350.  1946     format ('/cG { 0.52  setgray } def')
  351. c   /DL et /DS deja pris !
  352.   813  format ('/DN { 0.0000 0.0000 0.0000 setrgbcolor } def % black')
  353.   814  format ('/D0 { 0.0000 0.0000 0.0000 setrgbcolor } def % NOIR')
  354.   815  format ('/D4 { 0.0000 0.0000 1.0000 setrgbcolor } def % BLEU')
  355.   816  format ('/DC { 1.0000 0.0000 0.0000 setrgbcolor } def % ROUGe')
  356.   817  format ('/D2 { 1.0000 0.0000 1.0000 setrgbcolor } def % ROSE')
  357.   818  format ('/D8 { 0.0000 1.0000 0.0000 setrgbcolor } def % VERT')
  358.   819  format ('/D6 { 0.0000 0.8078 0.8196 setrgbcolor } def % TURQuoi')
  359.   820  format ('/DA { 1.0000 1.0000 0.0000 setrgbcolor } def % JAUNe')
  360.   821  format ('/DE { 1.0000 1.0000 1.0000 setrgbcolor } def % BLANc')
  361.   822  format ('/DF { 0.0000 0.0000 0.0000 setrgbcolor } def % NOIR')
  362.   823  format ('/D3 { 0.5804 0.0000 0.8274 setrgbcolor } def % VIOLet')
  363.   824  format ('/DB { 1.0000 0.6471 0.0000 setrgbcolor } def % ORANge')
  364.   825  format ('/D1 { 0.1176 0.5647 1.0000 setrgbcolor } def % AZUR')
  365.   826  format ('/D7 { 0.2353 0.7020 0.4431 setrgbcolor } def % OCEAn')
  366.   827  format ('/D5 { 0.5294 0.8078 0.9804 setrgbcolor } def % CYAN')
  367.   828  format ('/D9 { 0.6039 0.8039 0.1961 setrgbcolor } def % OLIVe')
  368.   829  format ('/DD { 0.7450 0.7450 0.7450 setrgbcolor } def % GRIS ')
  369.   830  format ('/DG { 0.8157 0.1255 0.5647 setrgbcolor } def % POURpre')
  370.   831  format ('/DH { 0.5451 0.2706 0.0745 setrgbcolor } def % BRUN')
  371.   832  format ('/DI { 0.6980 0.1333 0.1333 setrgbcolor } def % BRIQue')
  372.   833  format ('/DJ { 1.0000 0.5000 0.3137 setrgbcolor } def % CORAil')
  373.   834  format ('/DK { 0.9607 0.8706 0.7019 setrgbcolor } def % BEIGe')
  374.   835  format ('/DM { 1.0000 0.8431 0.0000 setrgbcolor } def % OR')
  375.   836  format ('/DN { 0.0000 0.0000 0.5000 setrgbcolor } def % MARIne')
  376.   837  format ('/DO { 0.0000 0.3921 0.0000 setrgbcolor } def % BOUTeil')
  377.   838  format ('/DP { 0.5000 1.0000 0.0000 setrgbcolor } def % LIME')
  378.   839  format ('/DQ { 0.9019 0.9019 0.9803 setrgbcolor } def % LAVAnde')
  379.   840  format ('/DR { 0.8549 0.6470 0.1254 setrgbcolor } def % BRONze')
  380.   841  format ('/DT { 0.9411 0.9019 0.5490 setrgbcolor } def % KAKI')
  381.   842  format ('/DU { 1.0000 0.7137 0.7568 setrgbcolor } def % PEAU')
  382.   843  format ('/DV { 0.8039 0.5215 0.2470 setrgbcolor } def % CARAmel')
  383.   844  format ('/DW { 0.2941 0.0000 0.5882 setrgbcolor } def % INDIgo')
  384.   845  format ('/DX { 0.0000 0.0000 0.0000 setrgbcolor } def % pas uti')
  385. *  Espace de couleurs 2 correspondant aux couleurs de l'echelle (du
  386. *  bleu au rouge) lorsqu'il y a moins de 16 isovaleurs demandees
  387.   880  format ('/d1 { 0.0000 0.0000 1.0000 setrgbcolor } def %')
  388.   881  format ('/d3 { 0.0000 0.6078 1.0000 setrgbcolor } def %')
  389.   882  format ('/d5 { 0.0000 0.9333 1.0000 setrgbcolor } def %')
  390.   883  format ('/d7 { 0.0000 1.0000 0.6078 setrgbcolor } def %')
  391.   884  format ('/d9 { 0.7058 1.0000 0.0000 setrgbcolor } def %')
  392.   885  format ('/dB { 1.0000 0.9333 0.0000 setrgbcolor } def %')
  393.   886  format ('/dD { 1.0000 0.6078 0.0000 setrgbcolor } def %')
  394.   887  format ('/dF { 1.0000 0.0000 0.0000 setrgbcolor } def %')
  395.   888  format ('/d2 { 0.0000 0.3490 1.0000 setrgbcolor } def %')
  396.   889  format ('/d4 { 0.0000 0.7882 1.0000 setrgbcolor } def %')
  397.   890  format ('/d6 { 0.0000 1.0000 0.7882 setrgbcolor } def %')
  398.   891  format ('/d8 { 0.6078 1.0000 0.0000 setrgbcolor } def %')
  399.   892  format ('/dA { 1.0000 1.0000 0.0000 setrgbcolor } def %')
  400.   893  format ('/dC { 1.0000 0.7882 0.0000 setrgbcolor } def %')
  401.   894  format ('/dE { 1.0000 0.3490 0.0000 setrgbcolor } def %')
  402.   895  format ('/dG { 0.0000 0.0000 0.0000 setrgbcolor } def %')
  403. c 947  format ('/Courier findfont 9 scalefont setfont')
  404. c   947  format ('/Courier findfont',/,
  405. c      +        'dup length dict begin',/,
  406. c      +        '   {1 index /FID ne {def} {pop pop} ifelse} forall',/,
  407. c      +        '   /Encoding ISOLatin1Encoding def',/,
  408. c      +        '   currentdict',/,
  409. c      +        'end',/,
  410. c      +        '/Courier-ISOLatin1 exch definefont 14 scalefont setfont')
  411. c bp : choix de la police tq definie dans option.eso
  412.  1844  format ('/',A,' findfont',/,
  413.      +        'dup length dict begin',/,
  414.      +        '   {1 index /FID ne {def} {pop pop} ifelse} forall',/,
  415.      +        '   /Encoding ISOLatin1Encoding def',/,
  416.      +        '   currentdict',/,
  417.      +        'end',/,
  418.      +         '/',A,'-ISOLatin1 exch definefont pop')
  419.  1845  format ('/',A,'-ISOLatin1 findfont ',I2,' scalefont setfont')
  420. c bp : fin du choix de la police
  421.  948   format ('23 CM4  1 CM4 translate 90 rotate')
  422.  1948  format ('2 CM4  2 CM4 translate')
  423.  949   format ('%%EndProlog')
  424.       else
  425. C        backspace  IUPS
  426.       endif
  427.       write (IUPS,957) ipag,ipag
  428.       write (IUPS,958)
  429.       write (IUPS,905) IEPTR
  430.       LFONT=HAFONT(IOPOTR)
  431.       MOFONT=TFONT(NOFONT(IOPOTR))
  432.       lmf=long(MOFONT)
  433.       write(IUPS,1845) MOFONT(1:lmf),LFONT
  434.       write (IUPS,959)
  435.  957  format ('%%Page: ',i5,1x,i5)
  436.  958  format ('StartPage')
  437.  959  format ('H0')
  438.       RETURN
  439. **
  440.  
  441. C======================================================================
  442. C     DEFINITION FENETRE + TITRE : sDFENE ou cDFENE
  443. C======================================================================
  444.  
  445.       ENTRY sDFENE(XMI,XXA,YMI,YYA,XR1,XR2,YR1,YR2,FENE)
  446.       ENTRY cDFENE(XMI,XXA,YMI,YYA,XR1,XR2,YR1,YR2,FENE)
  447. *  DEFINITION FENETRE
  448.       XR1=XMI
  449.       XR2=XXA
  450.       YR1=YMI
  451.       YR2=YYA
  452.       FENET=FENE
  453.       XMIN=XMI
  454.       XXAX=XXA
  455.       YMIN=YMI
  456.       YYAX=YYA
  457.       IF (FENET) THEN
  458.          if (.not.valeur) xiocad=xiocad-5*clx
  459.          if (valeur) xiocad=xiocad-10*clx
  460.       endif
  461.       yiocad=yiocad-2*clx
  462.       XRAP=xIOCAD/(XXAX-XMIN)*0.95
  463.       YRAP=yIOCAD/(YYAX-YMIN)*0.95
  464.       rap=min(xrap,yrap)
  465.       if (fenet) then
  466.          xrap=rap
  467.          yrap=rap
  468.       endif
  469.       IF (FENET) THEN
  470.          if (.not.valeur) xiocad=xiocad+5*clx
  471.          if (valeur) xiocad=xiocad+10*clx
  472.       endif
  473.       yiocad=yiocad+2*clx
  474.       XDEP=-XMIN + (xxax-xmin)*0.02
  475.       YDEP=-YMIN + (YYAX-YMIN)*0.02+CLX/YRAP
  476.  
  477.       RETURN
  478. **
  479.  
  480. C======================================================================
  481. C     ECRITURE TEXTE (ENTETE & VALEURS LEGENDE ...) : sTRLAB ou CTRLAB
  482. C======================================================================
  483.  
  484.       ENTRY sTRLAB(XT,YT,CARAC,NCARR,HAUT)
  485. *  ECRITURE TEXT
  486. *  ECRIT ENTETE & VALEURS LEGENDE ISOVALEURS
  487.       if (iespc.ne.1.or.icoul.ne.0) then
  488.           write (IUPS,fmt='(''CN'')')
  489.           iespc=1
  490.           icoul=0
  491.       endif
  492.       ENTRY cTRLAB(XT,YT,CARAC,NCARR,HAUT)
  493.       NBC=LONG(CARAC(1:NCARR))
  494. C JYYYY Debut
  495. c     on commence par se positionner
  496.       write (IUPS,fmt='(F6.3,'' CX4 '',F6.3,'' CX4 MX '')')
  497.      # BORNEX((XDEP+XT)*XRAP),BORNEY((YDEP+YT)*YRAP)
  498. c c     on remplit CHAINE
  499. c       CHAINE(1:1)='('
  500. c       CHAINE(2:NBC+1)=CARAC(1:NBC)
  501. c       CHAINE(nbc+2:nbc+5)=') SX'
  502. c c     on ecrit CHAINE
  503. c       write (iups,970) chaine(1:nbc+5)
  504. c  970  format (a)
  505. C JYYYY Fin
  506. c     on traite ensuite le texte (traitement caractere par caractere)
  507.       CALL CHAIPS(CARAC,NBC)
  508.       RETURN
  509. **
  510.  
  511. C======================================================================
  512. C     CHANGEMENT DE COULEUR : sCHCOU ou cCHCOU
  513. C======================================================================
  514.  
  515.       ENTRY sCHCOU(JCOLO)
  516. *  CHANGEMENT DE COULEUR
  517.       RETURN
  518.       ENTRY cCHCOU(JCOLO)
  519. c       kcoul=itb(mod(jcolo,16)+1)
  520.       kcoul=itb(mod(jcolo,31)+1)
  521. *dbg 777  format ('% cCHCOU ',I2,' kcoul=',I2,' icoul=',I6)
  522. *dbg      write (IUPS,777) JCOLO,kcoul,icoul
  523.       if (iespc.ne.1.or.icoul.ne.kcoul) then
  524.           cha='(''D'//ctb(kcoul:kcoul)//''')'
  525.           write (IUPS,fmt=cha)
  526.           iespc=1
  527.           icoul=kcoul
  528.       endif
  529.       RETURN
  530. **
  531.  
  532. C======================================================================
  533. C     CHANGEMENT SEGMENT : sINSEG ou cINSEG  -->  IGNORE
  534. C======================================================================
  535.  
  536.       ENTRY sINSEG(JSEG,IRESS)
  537.       ENTRY cINSEG(JSEG,IRESS)
  538. *  CHANGEMENT SEGMENT       IGNORE
  539.       RETURN
  540. **
  541.  
  542. C======================================================================
  543. C     tracé de POLYLINE (LIGNES) : sPOLRL ou cPOLRL
  544. C======================================================================
  545.  
  546.       ENTRY sPOLRL(NTRSTU,XTR,YTR)
  547. *  POLYLINE
  548.       if (iespc.ne.1.or.icoul.ne.0) then
  549.           write (IUPS,fmt='(''CN'')')
  550.           iespc=1
  551.           icoul=0
  552.       endif
  553.       ENTRY cPOLRL(NTRSTU,XTR,YTR)
  554. C JYYY Debut
  555.       IF ( NTRSTU .LE. 1 ) RETURN
  556.       write (IUPS,fmt='(40(I4,1X))')
  557.      # (IORNCX((XTR(I)+XDEP)*XRAP),IORNCY((YTR(I)+YDEP)*YRAP),
  558.      #  I=1,NTRSTU-1)
  559.       write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DL'')') (NTRSTU-1),
  560.      # IORNCX((XTR(NTRSTU)+XDEP)*XRAP),IORNCY((YTR(NTRSTU)+YDEP)*YRAP)
  561. C JYYY Fin
  562.       RETURN
  563. **
  564.  
  565. C======================================================================
  566. C     tracé de FACETTE : sTRFAC ou cTRFAC
  567. C======================================================================
  568.  
  569.       ENTRY sTRFAC(NTRSTU,XTR,YTR,ZN,ICOLE,IEFF)
  570. *  FACETTE
  571. C JYYY Debut
  572.       IF ( NTRSTU .LE. 1 ) RETURN
  573. C JYYY Fin
  574.       kcoul=itb(icole+1)
  575.       if (iespc.ne.1.or.icoul.ne.kcoul) then
  576.           cha='(''C'//ctb(kcoul:kcoul)//''')'
  577.           write (IUPS,fmt=cha)
  578.           iespc=1
  579.           icoul=kcoul
  580.       endif
  581.       goto 100
  582.       ENTRY cTRFAC(NTRSTU,XTR,YTR,ZN,ICOLE,IEFF)
  583. C JYYY Debut
  584.       IF ( NTRSTU .LE. 1 ) RETURN
  585. C JYYY Fin
  586.       kcoul=itb(icole+1)
  587.       if (iespc.ne.1.or.icoul.ne.kcoul) then
  588.           cha='(''D'//ctb(kcoul:kcoul)//''')'
  589.           write (IUPS,fmt=cha)
  590.           iespc=1
  591.           icoul=kcoul
  592.       endif
  593.  100  continue
  594. C JYYY Debut
  595.       write (IUPS,fmt='(40(I4,1X))')
  596.      # (IORNCX((XTR(I)+XDEP)*XRAP),IORNCY((YTR(I)+YDEP)*YRAP),
  597.      #  I=1,NTRSTU-1)
  598.       write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DS'')') (NTRSTU-1),
  599.      # IORNCX((XTR(NTRSTU)+XDEP)*XRAP),IORNCY((YTR(NTRSTU)+YDEP)*YRAP)
  600. C JYYY Fin
  601.       IEFF=1
  602.       RETURN
  603. **
  604.  
  605. C======================================================================
  606. C     tracé de ??? : sTRAIS ou sTRAIS
  607. C======================================================================
  608.  
  609.       ENTRY sTRAIS(NP,XTR,YTR,ICOLE)
  610. *  FACETTE
  611. C JYYY Debut
  612.       IF ( NP .LE. 1 ) RETURN
  613. C JYYY Fin
  614.       if (miso.lt.16) then
  615.          kcoul=itb(icole+1)
  616.          if (iespc.ne.2.or.icoul.ne.kcoul) then
  617.             cha='(''c'//ctb(kcoul:kcoul)//''')'
  618.             write (IUPS,fmt=cha)
  619.             iespc=2
  620.             icoul=kcoul
  621.          endif
  622.       else
  623.          kcoul=icole
  624.          if (iespc.ne.3.or.icoul.ne.kcoul) then
  625.             cha='(''e'//ctc(kcoul:kcoul)//''')'
  626.             write (IUPS,fmt=cha)
  627.             iespc=3
  628.             icoul=kcoul
  629.          endif
  630.       endif
  631.       goto 101
  632.       ENTRY cTRAIS(NP,XTR,YTR,ICOLE)
  633. C JYYY Debut
  634.       IF ( NP .LE. 1 ) RETURN
  635. C JYYY Fin
  636.       if (miso.lt.16) then
  637.          kcoul=itb(icole+1)
  638.          if (iespc.ne.2.or.icoul.ne.kcoul) then
  639.             cha='(''d'//ctb(kcoul:kcoul)//''')'
  640.             write (IUPS,fmt=cha)
  641.             iespc=2
  642.             icoul=kcoul
  643.          endif
  644.       else
  645.          kcoul=icole
  646.          if (iespc.ne.3.or.icoul.ne.kcoul) then
  647.             cha='(''f'//ctc(kcoul:kcoul)//''')'
  648.             write (IUPS,fmt=cha)
  649.             iespc=3
  650.             icoul=kcoul
  651.          endif
  652.       endif
  653.  101  continue
  654. C JYYY Debut
  655.       write (IUPS,fmt='(40(I4,1X))')
  656.      # (IORNCX((XTR(I)+XDEP)*XRAP),IORNCY((YTR(I)+YDEP)*YRAP),
  657.      #  I=1,NP-1)
  658.       if (np.gt.2)
  659.      # write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DS'')') (NP-1),
  660.      # IORNCX((XTR(NP)+XDEP)*XRAP),IORNCY((YTR(NP)+YDEP)*YRAP)
  661.        if (np.eq.2)
  662.      # write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DL'')') (NP-1),
  663.      # IORNCX((XTR(NP)+XDEP)*XRAP),IORNCY((YTR(NP)+YDEP)*YRAP)
  664. C JYYY Fin
  665.       RETURN
  666. **
  667.  
  668. C======================================================================
  669. C     DIGITALISATION DE POINT : sTRDIG ou cTRDIG --> IGNORE
  670. C======================================================================
  671.  
  672.       ENTRY sTRDIG(XRO,XCOL,ICLE)
  673.       ENTRY cTRDIG(XRO,XCOL,ICLE)
  674. *  DIGITALISATION DE POINT  IGNORE
  675.       ICLE=0
  676.       RETURN
  677. **
  678.  
  679. C======================================================================
  680. C     FIN D'IMPRESSION DE LA PAGE, AFFICHAGE : sTRAFF ou cTRAFF
  681. C======================================================================
  682.  
  683.       ENTRY sTRAFF(ICLE)
  684.       ENTRY cTRAFF(ICLE)
  685.  
  686. c TITRE DU TRACE
  687. C     On imprime le titre en fin de page pour qu'il soit place au-dessus
  688. C     des autres traces (donc lisible) :
  689.  
  690. C     On trace un fond blanc :
  691. C     Les coordonnees PS sont calculees pour couvrir le bas de la page
  692. C     a partir de la BBox et du changt de coordonnees (translate/rotate)
  693. C     fait a la fin du prologue :
  694.       IF (ZHORIZ) THEN
  695.         IGAU = INT(-1./0.04)*10
  696.         IDRO = 841*10+IGAU
  697.         JBAS = INT(23./0.04)*10-593*10
  698.         JHAU = LFONT*10
  699.       ELSE
  700.         IGAU = INT(-2./0.04)*10
  701.         IDRO = 593*10+IGAU
  702.         JBAS = INT(-2./0.04)*10
  703.         JHAU = LFONT*10
  704.       ENDIF
  705. C     write(6,*) 'IGAU,JBAS,IDRO=',IGAU,JBAS,IDRO
  706.       write (iups,fmt='(''DE'')')
  707.       write (IUPS,fmt='(40(I4,1X))') IGAU,JBAS,IDRO,JBAS,IDRO,JHAU
  708.       write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DS'')') 3,IGAU,JHAU
  709.       write (iups,fmt='(''D0'')')
  710.  
  711. c     On commence par se positionner :
  712.       write (iups,fmt='(''0. CX4 0. CX4 MX'')')
  713. C     NBC=LTITRE
  714. C     XCO=NBC*CLX/XRAP
  715. C     YCO=0
  716.  
  717. c     On traite ensuite le titre (traitement caractere par caractere) :
  718. c     Options du common CCTRACE pour impression CHAIPS
  719.       ANGLE=0.d0
  720.       IALIGN=0
  721.       CALL CHAIPS(TITRE,LTITRE)
  722.  
  723. *  FIN DE DESSIN
  724.       ipag=ipag+1
  725.       write (IUPS,956)
  726.  956  format ('EndPage')
  727. C      write (IUPS,960)
  728. C     960  format ('end')
  729.       iespc=-3
  730.       icoul=-3
  731.       ICLE=0
  732.       RETURN
  733. **
  734.  
  735. C======================================================================
  736. C     MENU : sMENU ou cMENU --> IGNORE
  737. C======================================================================
  738.  
  739.       ENTRY sMENU(LEGEND,NCASE,LLONG)
  740.       ENTRY cMENU(LEGEND,NCASE,LLONG)
  741. *  MENU       IGNORE
  742.       RETURN
  743. **
  744.       ENTRY sTRANI(ITYPI,NBIMAH)
  745.       ENTRY cTRANI(ITYPI,NBIMAH)
  746. *  ANIMATION  IGNOREE
  747.       RETURN
  748. **
  749.       ENTRY sTRIMA(IMAGI)
  750.       ENTRY cTRIMA(IMAGI)
  751. *  IMAGE      IGNOREE
  752.       RETURN
  753. **
  754.  
  755. C======================================================================
  756. C     CHANGEMENT DE VIEW
  757. C======================================================================
  758.  
  759.       ENTRY sFVALI(IFENI,IRESU,NH,NISO)
  760.       ENTRY cFVALI(IFENI,IRESU,NH,NISO)
  761. *  CHANGEMENT DE VIEW PORT
  762. *  TRACE COULEURS LEGENDE ISOVALEURS
  763. *  XDEP,YDEP : coin bas gauche de la legende
  764.       IF (IFENI.EQ.1) THEN
  765.          XRAP=CLX*10/0.95
  766.          YRAP=clx*2/0.95
  767.          XDEP=(xiocad-10*clx)/xrap
  768.          YDEP=-1.323
  769.       ENDIF
  770.       NH=31
  771.       MISO=NISO
  772.       if (ifeni.eq.1) return
  773. *  Espace de couleurs 3 correspondant aux couleurs de l'echelle (du
  774. *  bleu au rouge) lorsqu'il y a plus de 16 isovaleurs demandees
  775. *  definition dynamique des couleurs
  776.       if (niso.gt.15) then
  777.          do 10 i=1,niso
  778.             bw=0.9-i/(2.*niso)
  779.             write (iups,700) ctc(i:i),bw
  780.  700        format('/e',A1,' {',f6.3,' setgray } def')
  781.  10      continue
  782.          do 20 i=1,niso/3
  783.             rouge=0
  784.             vert=3.*i/niso
  785.             bleu=1
  786.             write (iups,710) ctc(i:i),rouge,vert,bleu
  787.  710        format('/f',A1,' {',3f7.4,' setrgbcolor } def')
  788.  20      continue
  789.          do 21 i=niso/3+1,niso/2
  790.             rouge=0
  791.             vert=1
  792.             bleu=(3.*niso-6.*i)/niso
  793.             write (iups,710) ctc(i:i),rouge,vert,bleu
  794.  21      continue
  795.          do 22 i=niso/2+1,(2*niso)/3
  796.             rouge=(6.*i-3.*niso)/niso
  797.             vert=1
  798.             bleu=0
  799.             write (iups,710) ctc(i:i),rouge,vert,bleu
  800.  22      continue
  801.          do 23 i=(2*niso)/3+1,niso
  802.             rouge=1
  803.             vert=(3.*niso-3.*i)/niso
  804.             bleu=0
  805.             write (iups,710) ctc(i:i),rouge,vert,bleu
  806.  23      continue
  807.       endif
  808.       RETURN
  809. **
  810.       ENTRY sZOOM(IZOOM,XMI,XMA,YMI,YMA)
  811.       ENTRY cZOOM(IZOOM,XMI,XMA,YMI,YMA)
  812. *  IGNOREE
  813.       RETURN
  814. **
  815.       ENTRY sINIt(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA)
  816.       ENTRY cINIt(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA)
  817. *  RETOUR AU DESSIN INITIAL   IGNORE
  818.       RETURN
  819. **
  820.       ENTRY sCHANG(IRESU,ISORT,ICHANG,JSEG)
  821.       ENTRY cCHANG(IRESU,ISORT,ICHANG,JSEG)
  822. *  AFFICHAGE DESAFFICHAGE NUM NOEUDS ELEMENTS QUAL  IGNORE
  823.        RETURN
  824. **
  825.       ENTRY sTRBOX(HAUTX,HAUTY)
  826.       ENTRY cTRBOX(HAUTX,HAUTY)
  827. *  INUTILISE
  828.       RETURN
  829. **
  830.       ENTRY sTREFF
  831.       ENTRY cTREFF
  832. *  INUTILISE
  833.       RETURN
  834. **
  835.       ENTRY sVAL(IRESU,ISORT,NISO)
  836.       ENTRY cVAL(IRESU,ISORT,NISO)
  837. *  INUTILISE
  838.       RETURN
  839. **
  840.       ENTRY sMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL)
  841.       ENTRY cMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL)
  842. *  INUTILISE
  843.       RETURN
  844. **
  845. **
  846.       ENTRY sIMPR
  847.       ENTRY cIMPR
  848. *  INUTILISE
  849.       RETURN
  850. **
  851.       ENTRY sTRTIN
  852.       ENTRY cTRTIN
  853. *  INUTILISE
  854.       RETURN
  855. **
  856.       ENTRY sFLGI
  857.       ENTRY cFLGI
  858. *  INUTILISE
  859.       RETURN
  860. **
  861.       ENTRY sTRMES(CARAC)
  862.       ENTRY cTRMES(CARAC)
  863. *  INUTILISE
  864.       RETURN
  865. **
  866.       ENTRY sTRGET(PROMPT,REPLY)
  867.       ENTRY cTRGET(PROMPT,REPLY)
  868. *  INUTILISE
  869.       RETURN
  870.       ENTRY sTRMFI
  871.       ENTRY cTRMFI
  872. *  INUTILISE
  873.       RETURN
  874.       END
  875.  
  876.  

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