C STRINI SOURCE GOUNAND 23/01/20 21:15:03 11563 C INTERFACE POUR GENERATION DE POSTSCRIPT C LES POINTS D'ENTREE EN C SONT POUR LA COULEUR C SUBROUTINE STRINI(NOL,AXAX,AYAY,TITR,HAUTT,VALEU,NCOUMA) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC CCTRACE EXTERNAL LONG DIMENSION XTR(*),YTR(*) CHARACTER*(*) TITR,CARAC,PROMPT,REPLY CHARACTER*(500) LEGEND CHARACTER*(LOCHAI) TITRE CHARACTER*128 CHAINE LOGICAL VALEU,FENE,VALEUR,FENET C SG 2016/11/29 On laisse Postscript faire le clipping C mais au-dela de [ICLIPB,ICLIPH] C il y a erreur de sortie car on écrit au format I4 PARAMETER(ICLIPB=-999,ICLIPH=9999) * SAVE XIOCAD,YIOCAD,VALEUR,FENET,TITRE,LTITRE SAVE XMIN,YMIN,XXAX,YYAX,CLX,XRAP,YRAP,XDEP,YDEP *SG 2016/04/20 * Il y a 3 espaces de couleurs pour les Postscript N&B ou couleur * 1) Les couleurs en /C? et /D? qui correspondent aux couleurs * nommees de Castem (operateur COUL) * 2) Les couleurs en /c? et /d? qui correspondent aux couleurs de * l'echelle (du bleu au rouge) lorsqu'il y a moins de 16 isovaleurs * demandees * 3) Les couleurs en /e? et /f? qui correspondent aux couleurs de * l'echelle (du bleu au rouge) lorsqu'il y a plus de 16 isovaleurs * demandees * iespc correspond a l'espace de couleur courant (1 a 3) * icoul a la couleur dans l'espace de couleur courant * Convention : iespc ou icoul=-3 si non definie * Ceci permet d'emettre des changements de couleur dans le Postscript * uniquement si necessaire save iespc,icoul,initia,ipag,miso,lfont PARAMETER(IUPS=24) c DIMENSION ITB(17) c CHARACTER*17 ctb DIMENSION ITB(32) CHARACTER*32 ctb CHARACTER*64 ctc CHARACTER*6 cha C C SG 2023/01 : les tableaux ci-dessous seraient peut-etre bien dans C le BLOCK DATA car utilisables ailleurs (option.eso, chaips.eso) C PARAMETER (NFONT=4,LMFONT=11) CHARACTER*(LMFONT) TFONT(NFONT) CHARACTER*(LMFONT) MOFONT * Tableaux de correspondance entre la valeur de IOPOTR (CCOPTIO) * et le nom (indice dans TFONT) et la taille (hauteur) de la fonte PARAMETER (NBPOTR=16) INTEGER NOFONT(NBPOTR) INTEGER HAFONT(NBPOTR) data initia/0/ data ipag/1/ c 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 ... data itb/1,5,13,3,9,7,11,15,16,4, 12, 2, 8, 6,10,14,17,18,19,20, > 21,22,23,24,25,26,27,28,29,30,31,1/ data ctb/'0123456789ABCDEFGHIJKMNOPQRTUVWX'/ c itb(0+1)=1 -> /D0 : NOIR c itb(1+1)=5 -> /D4 : BLEU c itb(2+1)=13 -> /DC : ROUG c itb(3+1)=3 -> /D2 : ROSE c ... c itb(7+1)=15 -> /DE : BLAN c itb(8+1)=16 -> /DF : NOIR c ... c itb(15+1)=14 -> /DD : GRIS c itb(16+1)=17 -> /DG : POUR c ... data ctc/'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123 >456789&@'/ data miso/0/ data TFONT(1) /'Courier '/ data TFONT(2) /'CourierBold'/ data TFONT(3) /'Helvetica '/ data TFONT(4) /'Times '/ data NOFONT/1,2,3,4,1,2,3,4,1,2,3,4,1,2,3,4/ data HAFONT/12,12,12,12,14,14,14,14,16,16,16,16,18,18,18,18/ * verification des bornes bornex(xxx)=min(max(xiocad*0.01,xxx),xiocad*0.99) borney(yyy)=min(max(yiocad*0.01,yyy),yiocad*0.99) C JYYY Debut C SG 2016/11/29 On laisse Postscript faire le clipping C mais au-dela de [ICLIPB,ICLIPH] C il y a erreur de sortie car on écrit au format I4 c$$$ Iorncx(xxx)=int((min(max(xiocad*0.01,xxx),xiocad*0.99))/0.004) c$$$ Iorncy(yyy)=int((min(max(yiocad*0.01,yyy),yiocad*0.99))/0.004) * Ma correction Iorncx(xxx)=min(max(nint(xxx/0.004),ICLIPB),ICLIPH) Iorncy(yyy)=min(max(nint(yyy/0.004),ICLIPB),ICLIPH) C JYYY Fin C Taille par defaut de la fonte de caracteres : LFONT = 14 * C====================================================================== C INITIALISATION : STRINI ou CTRINI C====================================================================== ENTRY CTRINI(NOL,AXAX,AYAY,TITR,HAUTT,VALEU,NCOUMA) * on part pour 64 couleurs NCOUMA=64 iespc=-3 icoul=-3 lo=len(titr) TITRE=TITR LTITRE=long(titre) VALEUR=VALEU * INITIALISATION DE POSTSCRIPT CLX=0.3 if (ZHORIZ) then xiocad=diocad yiocad=xiocad*21/29.7 else yiocad=diocad xiocad=yiocad*21/27.7 endif * ECRITURE DU PROLOGUE DU POSTSCRIPT if (ZINIPS) then ZINIPS = .false. c ... on met IPAG à 1 pour recommencer à numéroter correctement ... ipag = 1 initia=1 iespc=-3 icoul=-3 write (IUPS,897) write (IUPS,898) write (IUPS,899) if (ZHORIZ) then write (IUPS,900) else write (IUPS,1900) endif write (IUPS,901) write (IUPS,902) write (IUPS,903) write (IUPS,904) write (IUPS,906) write (IUPS,907) write (IUPS,908) write (IUPS,909) write (IUPS,910) write (IUPS,911) write (IUPS,912) write (IUPS,913) C JYYY Debut write (IUPS,'(A)') '/DL{NP MV {LN}repeat SK } def' write (IUPS,'(A)') '/DS{NP MV {LN}repeat FI } def' write (IUPS,'(A)') '/H0{.1 .1 scale}def' write (IUPS,'(A)') '/H1{10 10 scale}def' write (IUPS,'(A)') '/CX4{0.004 div} def' write (IUPS,'(A)') '/MX{moveto H1} def' write (IUPS,'(A)') '/SX {show H0} def' write (IUPS,'(A)') + '/center {stringwidth pop 2 div neg 0 rmoveto} def' c + '/center {dup stringwidth pop 2 div neg 0 rmoveto} def' write (IUPS,'(A)') + '/right {stringwidth pop neg 0 rmoveto} def' C JYYY Fin write (IUPS,914) write (IUPS,915) write (IUPS,916) write (IUPS,917) write (IUPS,918) write (IUPS,919) write (IUPS,920) write (IUPS,921) write (IUPS,922) write (IUPS,923) write (IUPS,924) write (IUPS,925) write (IUPS,926) write (IUPS,927) write (IUPS,928) write (IUPS,929) write (IUPS,930) write (IUPS,931) write (IUPS,932) write (IUPS,933) write (IUPS,934) write (IUPS,935) write (IUPS,936) write (IUPS,937) write (IUPS,938) write (IUPS,939) write (IUPS,940) write (IUPS,941) write (IUPS,942) write (IUPS,943) write (IUPS,944) write (IUPS,945) write (IUPS,1931) write (IUPS,1932) write (IUPS,1933) write (IUPS,1934) write (IUPS,1935) write (IUPS,1936) write (IUPS,1937) write (IUPS,1938) write (IUPS,1939) write (IUPS,1940) write (IUPS,1941) write (IUPS,1942) write (IUPS,1943) write (IUPS,1944) write (IUPS,1945) write (IUPS,1946) write (IUPS,813) write (IUPS,814) write (IUPS,815) write (IUPS,816) write (IUPS,817) write (IUPS,818) write (IUPS,819) write (IUPS,820) write (IUPS,821) write (IUPS,822) write (IUPS,823) write (IUPS,824) write (IUPS,825) write (IUPS,826) write (IUPS,827) write (IUPS,828) write (IUPS,829) write (IUPS,830) write (IUPS,831) write (IUPS,832) write (IUPS,833) write (IUPS,834) write (IUPS,835) write (IUPS,836) write (IUPS,837) write (IUPS,838) write (IUPS,839) write (IUPS,840) write (IUPS,841) write (IUPS,842) write (IUPS,843) write (IUPS,844) write (IUPS,845) write (IUPS,880) write (IUPS,881) write (IUPS,882) write (IUPS,883) write (IUPS,884) write (IUPS,885) write (IUPS,886) write (IUPS,887) write (IUPS,888) write (IUPS,889) write (IUPS,890) write (IUPS,891) write (IUPS,892) write (IUPS,893) write (IUPS,894) write (IUPS,895) c write (IUPS,947) * bp : choix de la police tq definie dans option.eso C SG Initialisation de toutes les fontes du tableau TFONT do ifont=1,nfont MOFONT=TFONT(ifont) lmf=long(MOFONT) write(IUPS,1844) MOFONT(1:lmf),MOFONT(1:lmf) enddo if (ZHORIZ) then write (IUPS,948) else write (IUPS,1948) endif write (IUPS,949) 897 format ('%!PS-Adobe-1.0') 898 format ('%%Creator: Cast3m - CEA/DEN/DM2S/SEMT') 899 format ('%%BoundingBox: 0 0 593 841') 900 format ('%%Orientation: Landscape') 1900 format ('%%Orientation: Portrait') 901 format('200 dict begin') 902 format ('/StartPage{/sv save def}def') 903 format ('/EndPage{showpage sv restore}def') 904 format ('1 setlinecap 0 setlinejoin') 905 format (I2,' setlinewidth') 906 format ('/CM4 { 0.04 div } def') 907 format ('/NP { newpath } def') 908 format ('/MV { moveto } def') 909 format ('/LN { lineto } def') 910 format ('/SK { stroke } def') 911 format ('/FI { fill } def') 912 format ('/S { show } def') * SG 2016/04/20 * Espace de couleurs 1 correspondent aux couleurs nommees de Castem (operateur COUL) 913 format ('/CN { 1. setgray } def') 914 format ('/C0 { 1. setgray } def') 915 Format ('/C4 { 0.333 setgray } def') 916 format ('/CC { 0.333 setgray } def') 917 format ('/C2 { 0.666 setgray } def') 918 format ('/C8 { 0.333 setgray } def') 919 format ('/C6 { 0.633 setgray } def') 920 format ('/CA { 0.666 setgray } def') 921 format ('/CE { 1.000 setgray } def') 922 format ('/CF { 0.000 setgray } def') 923 format ('/C3 { 0.469 setgray } def') 924 format ('/CB { 0.549 setgray } def') 925 format ('/C1 { 0.560 setgray } def') 926 format ('/C7 { 0.460 setgray } def') 927 format ('/C5 { 0.772 setgray } def') 928 format ('/C9 { 0.534 setgray } def') 929 format ('/CD { 0.827 setgray } def') 930 format ('/CG { 0.501 setgray } def') 931 format ('/CH { 0.296 setgray } def') 932 format ('/CI { 0.321 setgray } def') 933 format ('/CJ { 0.603 setgray } def') 934 format ('/CK { 0.844 setgray } def') 935 format ('/CM { 0.614 setgray } def') 936 format ('/CN { 0.167 setgray } def') 937 format ('/CO { 0.130 setgray } def') 938 format ('/CP { 0.620 setgray } def') 939 format ('/CQ { 0.928 setgray } def') 940 format ('/CR { 0.542 setgray } def') 941 format ('/CT { 0.797 setgray } def') 942 format ('/CU { 0.823 setgray } def') 943 format ('/CV { 0.524 setgray } def') 944 format ('/CW { 0.294 setgray } def') 945 format ('/CX { 0.52 setgray } def') 1931 Format ('/c1 { 0.98 setgray } def') 1932 format ('/c3 { 0.95 setgray } def') 1933 format ('/c5 { 0.91 setgray } def') 1934 format ('/c7 { 0.86 setgray } def') 1935 format ('/c9 { 0.80 setgray } def') 1936 format ('/cB { 0.73 setgray } def') 1937 format ('/cD { 0.65 setgray } def') 1938 format ('/cF { 0.56 setgray } def') 1939 format ('/c2 { 0.965 setgray } def') 1940 format ('/c4 { 0.93 setgray } def') 1941 format ('/c6 { 0.885 setgray } def') 1942 format ('/c8 { 0.83 setgray } def') 1943 format ('/cA { 0.765 setgray } def') 1944 format ('/cC { 0.69 setgray } def') 1945 format ('/cE { 0.605 setgray } def') 1946 format ('/cG { 0.52 setgray } def') c /DL et /DS deja pris ! 813 format ('/DN { 0.0000 0.0000 0.0000 setrgbcolor } def % black') 814 format ('/D0 { 0.0000 0.0000 0.0000 setrgbcolor } def % NOIR') 815 format ('/D4 { 0.0000 0.0000 1.0000 setrgbcolor } def % BLEU') 816 format ('/DC { 1.0000 0.0000 0.0000 setrgbcolor } def % ROUGe') 817 format ('/D2 { 1.0000 0.0000 1.0000 setrgbcolor } def % ROSE') 818 format ('/D8 { 0.0000 1.0000 0.0000 setrgbcolor } def % VERT') 819 format ('/D6 { 0.0000 0.8078 0.8196 setrgbcolor } def % TURQuoi') 820 format ('/DA { 1.0000 1.0000 0.0000 setrgbcolor } def % JAUNe') 821 format ('/DE { 1.0000 1.0000 1.0000 setrgbcolor } def % BLANc') 822 format ('/DF { 0.0000 0.0000 0.0000 setrgbcolor } def % NOIR') 823 format ('/D3 { 0.5804 0.0000 0.8274 setrgbcolor } def % VIOLet') 824 format ('/DB { 1.0000 0.6471 0.0000 setrgbcolor } def % ORANge') 825 format ('/D1 { 0.1176 0.5647 1.0000 setrgbcolor } def % AZUR') 826 format ('/D7 { 0.2353 0.7020 0.4431 setrgbcolor } def % OCEAn') 827 format ('/D5 { 0.5294 0.8078 0.9804 setrgbcolor } def % CYAN') 828 format ('/D9 { 0.6039 0.8039 0.1961 setrgbcolor } def % OLIVe') 829 format ('/DD { 0.7450 0.7450 0.7450 setrgbcolor } def % GRIS ') 830 format ('/DG { 0.8157 0.1255 0.5647 setrgbcolor } def % POURpre') 831 format ('/DH { 0.5451 0.2706 0.0745 setrgbcolor } def % BRUN') 832 format ('/DI { 0.6980 0.1333 0.1333 setrgbcolor } def % BRIQue') 833 format ('/DJ { 1.0000 0.5000 0.3137 setrgbcolor } def % CORAil') 834 format ('/DK { 0.9607 0.8706 0.7019 setrgbcolor } def % BEIGe') 835 format ('/DM { 1.0000 0.8431 0.0000 setrgbcolor } def % OR') 836 format ('/DN { 0.0000 0.0000 0.5000 setrgbcolor } def % MARIne') 837 format ('/DO { 0.0000 0.3921 0.0000 setrgbcolor } def % BOUTeil') 838 format ('/DP { 0.5000 1.0000 0.0000 setrgbcolor } def % LIME') 839 format ('/DQ { 0.9019 0.9019 0.9803 setrgbcolor } def % LAVAnde') 840 format ('/DR { 0.8549 0.6470 0.1254 setrgbcolor } def % BRONze') 841 format ('/DT { 0.9411 0.9019 0.5490 setrgbcolor } def % KAKI') 842 format ('/DU { 1.0000 0.7137 0.7568 setrgbcolor } def % PEAU') 843 format ('/DV { 0.8039 0.5215 0.2470 setrgbcolor } def % CARAmel') 844 format ('/DW { 0.2941 0.0000 0.5882 setrgbcolor } def % INDIgo') 845 format ('/DX { 0.0000 0.0000 0.0000 setrgbcolor } def % pas uti') * Espace de couleurs 2 correspondant aux couleurs de l'echelle (du * bleu au rouge) lorsqu'il y a moins de 16 isovaleurs demandees 880 format ('/d1 { 0.0000 0.0000 1.0000 setrgbcolor } def %') 881 format ('/d3 { 0.0000 0.6078 1.0000 setrgbcolor } def %') 882 format ('/d5 { 0.0000 0.9333 1.0000 setrgbcolor } def %') 883 format ('/d7 { 0.0000 1.0000 0.6078 setrgbcolor } def %') 884 format ('/d9 { 0.7058 1.0000 0.0000 setrgbcolor } def %') 885 format ('/dB { 1.0000 0.9333 0.0000 setrgbcolor } def %') 886 format ('/dD { 1.0000 0.6078 0.0000 setrgbcolor } def %') 887 format ('/dF { 1.0000 0.0000 0.0000 setrgbcolor } def %') 888 format ('/d2 { 0.0000 0.3490 1.0000 setrgbcolor } def %') 889 format ('/d4 { 0.0000 0.7882 1.0000 setrgbcolor } def %') 890 format ('/d6 { 0.0000 1.0000 0.7882 setrgbcolor } def %') 891 format ('/d8 { 0.6078 1.0000 0.0000 setrgbcolor } def %') 892 format ('/dA { 1.0000 1.0000 0.0000 setrgbcolor } def %') 893 format ('/dC { 1.0000 0.7882 0.0000 setrgbcolor } def %') 894 format ('/dE { 1.0000 0.3490 0.0000 setrgbcolor } def %') 895 format ('/dG { 0.0000 0.0000 0.0000 setrgbcolor } def %') c 947 format ('/Courier findfont 9 scalefont setfont') c 947 format ('/Courier findfont',/, c + 'dup length dict begin',/, c + ' {1 index /FID ne {def} {pop pop} ifelse} forall',/, c + ' /Encoding ISOLatin1Encoding def',/, c + ' currentdict',/, c + 'end',/, c + '/Courier-ISOLatin1 exch definefont 14 scalefont setfont') c bp : choix de la police tq definie dans option.eso 1844 format ('/',A,' findfont',/, + 'dup length dict begin',/, + ' {1 index /FID ne {def} {pop pop} ifelse} forall',/, + ' /Encoding ISOLatin1Encoding def',/, + ' currentdict',/, + 'end',/, + '/',A,'-ISOLatin1 exch definefont pop') 1845 format ('/',A,'-ISOLatin1 findfont ',I2,' scalefont setfont') c bp : fin du choix de la police 948 format ('23 CM4 1 CM4 translate 90 rotate') 1948 format ('2 CM4 2 CM4 translate') 949 format ('%%EndProlog') else C backspace IUPS endif write (IUPS,957) ipag,ipag write (IUPS,958) write (IUPS,905) IEPTR LFONT=HAFONT(IOPOTR) MOFONT=TFONT(NOFONT(IOPOTR)) lmf=long(MOFONT) write(IUPS,1845) MOFONT(1:lmf),LFONT write (IUPS,959) 957 format ('%%Page: ',i5,1x,i5) 958 format ('StartPage') 959 format ('H0') RETURN ** C====================================================================== C DEFINITION FENETRE + TITRE : sDFENE ou cDFENE C====================================================================== ENTRY sDFENE(XMI,XXA,YMI,YYA,XR1,XR2,YR1,YR2,FENE) ENTRY cDFENE(XMI,XXA,YMI,YYA,XR1,XR2,YR1,YR2,FENE) * DEFINITION FENETRE XR1=XMI XR2=XXA YR1=YMI YR2=YYA FENET=FENE XMIN=XMI XXAX=XXA YMIN=YMI YYAX=YYA IF (FENET) THEN if (.not.valeur) xiocad=xiocad-5*clx if (valeur) xiocad=xiocad-10*clx endif yiocad=yiocad-2*clx XRAP=xIOCAD/(XXAX-XMIN)*0.95 YRAP=yIOCAD/(YYAX-YMIN)*0.95 rap=min(xrap,yrap) if (fenet) then xrap=rap yrap=rap endif IF (FENET) THEN if (.not.valeur) xiocad=xiocad+5*clx if (valeur) xiocad=xiocad+10*clx endif yiocad=yiocad+2*clx XDEP=-XMIN + (xxax-xmin)*0.02 YDEP=-YMIN + (YYAX-YMIN)*0.02+CLX/YRAP RETURN ** C====================================================================== C ECRITURE TEXTE (ENTETE & VALEURS LEGENDE ...) : sTRLAB ou CTRLAB C====================================================================== ENTRY sTRLAB(XT,YT,CARAC,NCARR,HAUT) * ECRITURE TEXT * ECRIT ENTETE & VALEURS LEGENDE ISOVALEURS if (iespc.ne.1.or.icoul.ne.0) then write (IUPS,fmt='(''CN'')') iespc=1 icoul=0 endif ENTRY cTRLAB(XT,YT,CARAC,NCARR,HAUT) NBC=LONG(CARAC(1:NCARR)) C JYYYY Debut c on commence par se positionner write (IUPS,fmt='(F6.3,'' CX4 '',F6.3,'' CX4 MX '')') # BORNEX((XDEP+XT)*XRAP),BORNEY((YDEP+YT)*YRAP) c c on remplit CHAINE c CHAINE(1:1)='(' c CHAINE(2:NBC+1)=CARAC(1:NBC) c CHAINE(nbc+2:nbc+5)=') SX' c c on ecrit CHAINE c write (iups,970) chaine(1:nbc+5) c 970 format (a) C JYYYY Fin c on traite ensuite le texte (traitement caractere par caractere) CALL CHAIPS(CARAC,NBC) RETURN ** C====================================================================== C CHANGEMENT DE COULEUR : sCHCOU ou cCHCOU C====================================================================== ENTRY sCHCOU(JCOLO) * CHANGEMENT DE COULEUR RETURN ENTRY cCHCOU(JCOLO) c kcoul=itb(mod(jcolo,16)+1) kcoul=itb(mod(jcolo,31)+1) *dbg 777 format ('% cCHCOU ',I2,' kcoul=',I2,' icoul=',I6) *dbg write (IUPS,777) JCOLO,kcoul,icoul if (iespc.ne.1.or.icoul.ne.kcoul) then cha='(''D'//ctb(kcoul:kcoul)//''')' write (IUPS,fmt=cha) iespc=1 icoul=kcoul endif RETURN ** C====================================================================== C CHANGEMENT SEGMENT : sINSEG ou cINSEG --> IGNORE C====================================================================== ENTRY sINSEG(JSEG,IRESS) ENTRY cINSEG(JSEG,IRESS) * CHANGEMENT SEGMENT IGNORE RETURN ** C====================================================================== C tracé de POLYLINE (LIGNES) : sPOLRL ou cPOLRL C====================================================================== ENTRY sPOLRL(NTRSTU,XTR,YTR) * POLYLINE if (iespc.ne.1.or.icoul.ne.0) then write (IUPS,fmt='(''CN'')') iespc=1 icoul=0 endif ENTRY cPOLRL(NTRSTU,XTR,YTR) C JYYY Debut IF ( NTRSTU .LE. 1 ) RETURN write (IUPS,fmt='(40(I4,1X))') # (IORNCX((XTR(I)+XDEP)*XRAP),IORNCY((YTR(I)+YDEP)*YRAP), # I=1,NTRSTU-1) write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DL'')') (NTRSTU-1), # IORNCX((XTR(NTRSTU)+XDEP)*XRAP),IORNCY((YTR(NTRSTU)+YDEP)*YRAP) C JYYY Fin RETURN ** C====================================================================== C tracé de FACETTE : sTRFAC ou cTRFAC C====================================================================== ENTRY sTRFAC(NTRSTU,XTR,YTR,ZN,ICOLE,IEFF) * FACETTE C JYYY Debut IF ( NTRSTU .LE. 1 ) RETURN C JYYY Fin kcoul=itb(icole+1) if (iespc.ne.1.or.icoul.ne.kcoul) then cha='(''C'//ctb(kcoul:kcoul)//''')' write (IUPS,fmt=cha) iespc=1 icoul=kcoul endif goto 100 ENTRY cTRFAC(NTRSTU,XTR,YTR,ZN,ICOLE,IEFF) C JYYY Debut IF ( NTRSTU .LE. 1 ) RETURN C JYYY Fin kcoul=itb(icole+1) if (iespc.ne.1.or.icoul.ne.kcoul) then cha='(''D'//ctb(kcoul:kcoul)//''')' write (IUPS,fmt=cha) iespc=1 icoul=kcoul endif 100 continue C JYYY Debut write (IUPS,fmt='(40(I4,1X))') # (IORNCX((XTR(I)+XDEP)*XRAP),IORNCY((YTR(I)+YDEP)*YRAP), # I=1,NTRSTU-1) write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DS'')') (NTRSTU-1), # IORNCX((XTR(NTRSTU)+XDEP)*XRAP),IORNCY((YTR(NTRSTU)+YDEP)*YRAP) C JYYY Fin IEFF=1 RETURN ** C====================================================================== C tracé de ??? : sTRAIS ou sTRAIS C====================================================================== ENTRY sTRAIS(NP,XTR,YTR,ICOLE) * FACETTE C JYYY Debut IF ( NP .LE. 1 ) RETURN C JYYY Fin if (miso.lt.16) then kcoul=itb(icole+1) if (iespc.ne.2.or.icoul.ne.kcoul) then cha='(''c'//ctb(kcoul:kcoul)//''')' write (IUPS,fmt=cha) iespc=2 icoul=kcoul endif else kcoul=icole if (iespc.ne.3.or.icoul.ne.kcoul) then cha='(''e'//ctc(kcoul:kcoul)//''')' write (IUPS,fmt=cha) iespc=3 icoul=kcoul endif endif goto 101 ENTRY cTRAIS(NP,XTR,YTR,ICOLE) C JYYY Debut IF ( NP .LE. 1 ) RETURN C JYYY Fin if (miso.lt.16) then kcoul=itb(icole+1) if (iespc.ne.2.or.icoul.ne.kcoul) then cha='(''d'//ctb(kcoul:kcoul)//''')' write (IUPS,fmt=cha) iespc=2 icoul=kcoul endif else kcoul=icole if (iespc.ne.3.or.icoul.ne.kcoul) then cha='(''f'//ctc(kcoul:kcoul)//''')' write (IUPS,fmt=cha) iespc=3 icoul=kcoul endif endif 101 continue C JYYY Debut write (IUPS,fmt='(40(I4,1X))') # (IORNCX((XTR(I)+XDEP)*XRAP),IORNCY((YTR(I)+YDEP)*YRAP), # I=1,NP-1) if (np.gt.2) # write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DS'')') (NP-1), # IORNCX((XTR(NP)+XDEP)*XRAP),IORNCY((YTR(NP)+YDEP)*YRAP) if (np.eq.2) # write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DL'')') (NP-1), # IORNCX((XTR(NP)+XDEP)*XRAP),IORNCY((YTR(NP)+YDEP)*YRAP) C JYYY Fin RETURN ** C====================================================================== C DIGITALISATION DE POINT : sTRDIG ou cTRDIG --> IGNORE C====================================================================== ENTRY sTRDIG(XRO,XCOL,ICLE) ENTRY cTRDIG(XRO,XCOL,ICLE) * DIGITALISATION DE POINT IGNORE ICLE=0 RETURN ** C====================================================================== C FIN D'IMPRESSION DE LA PAGE, AFFICHAGE : sTRAFF ou cTRAFF C====================================================================== ENTRY sTRAFF(ICLE) ENTRY cTRAFF(ICLE) c TITRE DU TRACE C On imprime le titre en fin de page pour qu'il soit place au-dessus C des autres traces (donc lisible) : C On trace un fond blanc : C Les coordonnees PS sont calculees pour couvrir le bas de la page C a partir de la BBox et du changt de coordonnees (translate/rotate) C fait a la fin du prologue : IF (ZHORIZ) THEN IGAU = INT(-1./0.04)*10 IDRO = 841*10+IGAU JBAS = INT(23./0.04)*10-593*10 JHAU = LFONT*10 ELSE IGAU = INT(-2./0.04)*10 IDRO = 593*10+IGAU JBAS = INT(-2./0.04)*10 JHAU = LFONT*10 ENDIF C write(6,*) 'IGAU,JBAS,IDRO=',IGAU,JBAS,IDRO write (iups,fmt='(''DE'')') write (IUPS,fmt='(40(I4,1X))') IGAU,JBAS,IDRO,JBAS,IDRO,JHAU write (IUPS,fmt='(I2,1X,I4,1X,I4,'' DS'')') 3,IGAU,JHAU write (iups,fmt='(''D0'')') c On commence par se positionner : write (iups,fmt='(''0. CX4 0. CX4 MX'')') C NBC=LTITRE C XCO=NBC*CLX/XRAP C YCO=0 c On traite ensuite le titre (traitement caractere par caractere) : c Options du common CCTRACE pour impression CHAIPS ANGLE=0.d0 IALIGN=0 CALL CHAIPS(TITRE,LTITRE) * FIN DE DESSIN ipag=ipag+1 write (IUPS,956) 956 format ('EndPage') C write (IUPS,960) C 960 format ('end') iespc=-3 icoul=-3 ICLE=0 RETURN ** C====================================================================== C MENU : sMENU ou cMENU --> IGNORE C====================================================================== ENTRY sMENU(LEGEND,NCASE,LLONG) ENTRY cMENU(LEGEND,NCASE,LLONG) * MENU IGNORE RETURN ** ENTRY sTRANI(ITYPI,NBIMAH) ENTRY cTRANI(ITYPI,NBIMAH) * ANIMATION IGNOREE RETURN ** ENTRY sTRIMA(IMAGI) ENTRY cTRIMA(IMAGI) * IMAGE IGNOREE RETURN ** C====================================================================== C CHANGEMENT DE VIEW C====================================================================== ENTRY sFVALI(IFENI,IRESU,NH,NISO) ENTRY cFVALI(IFENI,IRESU,NH,NISO) * CHANGEMENT DE VIEW PORT * TRACE COULEURS LEGENDE ISOVALEURS * XDEP,YDEP : coin bas gauche de la legende IF (IFENI.EQ.1) THEN XRAP=CLX*10/0.95 YRAP=clx*2/0.95 XDEP=(xiocad-10*clx)/xrap YDEP=-1.323 ENDIF NH=31 MISO=NISO if (ifeni.eq.1) return * Espace de couleurs 3 correspondant aux couleurs de l'echelle (du * bleu au rouge) lorsqu'il y a plus de 16 isovaleurs demandees * definition dynamique des couleurs if (niso.gt.15) then do 10 i=1,niso bw=0.9-i/(2.*niso) write (iups,700) ctc(i:i),bw 700 format('/e',A1,' {',f6.3,' setgray } def') 10 continue do 20 i=1,niso/3 rouge=0 vert=3.*i/niso bleu=1 write (iups,710) ctc(i:i),rouge,vert,bleu 710 format('/f',A1,' {',3f7.4,' setrgbcolor } def') 20 continue do 21 i=niso/3+1,niso/2 rouge=0 vert=1 bleu=(3.*niso-6.*i)/niso write (iups,710) ctc(i:i),rouge,vert,bleu 21 continue do 22 i=niso/2+1,(2*niso)/3 rouge=(6.*i-3.*niso)/niso vert=1 bleu=0 write (iups,710) ctc(i:i),rouge,vert,bleu 22 continue do 23 i=(2*niso)/3+1,niso rouge=1 vert=(3.*niso-3.*i)/niso bleu=0 write (iups,710) ctc(i:i),rouge,vert,bleu 23 continue endif RETURN ** ENTRY sZOOM(IZOOM,XMI,XMA,YMI,YMA) ENTRY cZOOM(IZOOM,XMI,XMA,YMI,YMA) * IGNOREE RETURN ** ENTRY sINIt(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA) ENTRY cINIt(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA) * RETOUR AU DESSIN INITIAL IGNORE RETURN ** ENTRY sCHANG(IRESU,ISORT,ICHANG,JSEG) ENTRY cCHANG(IRESU,ISORT,ICHANG,JSEG) * AFFICHAGE DESAFFICHAGE NUM NOEUDS ELEMENTS QUAL IGNORE RETURN ** ENTRY sTRBOX(HAUTX,HAUTY) ENTRY cTRBOX(HAUTX,HAUTY) * INUTILISE RETURN ** ENTRY sTREFF ENTRY cTREFF * INUTILISE RETURN ** ENTRY sVAL(IRESU,ISORT,NISO) ENTRY cVAL(IRESU,ISORT,NISO) * INUTILISE RETURN ** ENTRY sMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL) ENTRY cMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL) * INUTILISE RETURN ** ** ENTRY sIMPR ENTRY cIMPR * INUTILISE RETURN ** ENTRY sTRTIN ENTRY cTRTIN * INUTILISE RETURN ** ENTRY sFLGI ENTRY cFLGI * INUTILISE RETURN ** ENTRY sTRMES(CARAC) ENTRY cTRMES(CARAC) * INUTILISE RETURN ** ENTRY sTRGET(PROMPT,REPLY) ENTRY cTRGET(PROMPT,REPLY) * INUTILISE RETURN ENTRY sTRMFI ENTRY cTRMFI * INUTILISE RETURN END