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

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