C STRINI SOURCE FD218221 26/07/06 21:15:14 12578 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 Cast3M (operateur COUL) * 2) Les couleurs en /c? et /d? qui correspondent aux couleurs de * la palette lorsqu'il y a moins de 16 couleurs demandees * 3) Les couleurs en /e? et /f? qui correspondent aux couleurs de * la palette lorsqu'il y a plus (ou egal) de 16 couleurs 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 REAL*8 ROUG(64),VERT(64),BLEU(64) 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) 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 C Ecriture des codes couleurs de l'operateur COUL en niveaux de gris write (IUPS,1913) write (IUPS,913) 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) C Ecriture des codes couleurs de l'operateur COUL en niveaux RGB write (IUPS,1813) 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) * 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/DES/ISAS/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') C SG 2016/04/20 C Espace de couleurs 1 : couleurs nommees de Cast3M (operateur COUL) C en niveaux de gris 1913 format ('%%Couleurs (niveau de gris) de l''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') C Espace de couleurs 1 : couleurs nommees de Cast3M (operateur COUL) C en niveaux RGB (/DL et /DS deja pris !) 1813 format ('%%Couleurs (rgb) de l''operateur COUL') 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') 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 C Ecriture des codes couleurs pour le trace de champs d'isovaleurs IF (IRESU.EQ.0) THEN C Palette statique des gris (16 teintes) 1000 FORMAT ('%%Palette statique des gris pour les traces') WRITE (IUPS,1000) 1001 FORMAT ('/c',A1,' {',f6.3,' setgray } def') WRITE (IUPS,1001) '1',0.980 WRITE (IUPS,1001) '2',0.965 WRITE (IUPS,1001) '3',0.95 WRITE (IUPS,1001) '4',0.93 WRITE (IUPS,1001) '5',0.91 WRITE (IUPS,1001) '6',0.885 WRITE (IUPS,1001) '7',0.86 WRITE (IUPS,1001) '8',0.83 WRITE (IUPS,1001) '9',0.80 WRITE (IUPS,1001) 'A',0.765 WRITE (IUPS,1001) 'B',0.73 WRITE (IUPS,1001) 'C',0.69 WRITE (IUPS,1001) 'D',0.65 WRITE (IUPS,1001) 'E',0.605 WRITE (IUPS,1001) 'F',0.56 WRITE (IUPS,1001) 'G',0.52 C Palette dynamique des gris 2000 FORMAT ('%%Palette dynamique des gris pour les traces') WRITE (IUPS,2000) 2001 FORMAT ('/e',A1,' {',f6.3,' setgray } def') DO I=1,NISO BW=0.9-I/(2.*NISO) WRITE (IUPS,2001) CTC(I:I),BW ENDDO C Palette statique des couleurs (16 teintes) 3000 FORMAT ('%%Palette statique des couleurs pour les traces') WRITE (IUPS,3000) 3001 FORMAT ('/d',A1,' {',3f7.4,' setrgbcolor } def %') CALL PALET2(IPALET,15,ROUG,VERT,BLEU) DO I=1,15 WRITE (IUPS,3001) CTB(I+1:I+1),ROUG(I),VERT(I),BLEU(I) ENDDO WRITE (IUPS,3001) 'G',0.0000,0.0000,0.0000 C Palette dynamique des couleurs 4000 FORMAT ('%%Palette dynamique des couleurs pour les traces') WRITE (IUPS,4000) 4001 FORMAT ('/f',A1,' {',3f7.4,' setrgbcolor } def') CALL PALET2(IPALET,NISO,ROUG,VERT,BLEU) DO I=1,NISO WRITE (IUPS,4001) CTC(I:I),ROUG(I),VERT(I),BLEU(I) ENDDO 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