C XTRINI SOURCE PV090527 25/10/15 21:15:06 12383 C INTERFACE POUR XWINDOW C C C C 1995 option FACE P.PEGON JRC-ISPRA SUBROUTINE XTRINI(NOL,AXAX,AYAY,TITR,HAUTT,VALEU,NCOUMA) IMPLICIT INTEGER(I-N) EXTERNAL LONG -INC PPARAM -INC CCOPTIO -INC CCTRACE CHARACTER*(18) HEGEND(4) CHARACTER*(500) LEGEND CHARACTER*(500) KEGEND EQUIVALENCE(KEGEND,IEGEND) EQUIVALENCE(HEGEND,JEGEND) CHARACTER*(*) TITR,CARAC,PROMPT,REPLY CHARACTER*80 CHAINE,CHMESS CHARACTER*(LOCHAI) TITRS LOGICAL VALEU,FENE,valeus DIMENSION XTR(1),YTR(1) DIMENSION XMAT(3,3) EQUIVALENCE (CHAINE,ICHAIN) EQUIVALENCE (CHmess,ICHmes) save chmess,ichmes,titrs,valeus SAVE KEGEND,KCASE,KLONG SAVE mcouma,miso SAVE iret SAVE IDEFO SAVE DESSIN,DESSIC SAVE NBOPD,NBPD,NBCHRD,LTITRE SAVE IBOPD,IBPD,IBCHRD DATA IBOPD,IBPD/0,0/ SEGMENT DESSIN CHARACTER*(LTITRE) TITRE LOGICAL VALEUR,FENET REAL XMIN,XXAX,YMIN,YYAX REAL OXMIN,OXXAX,OYMIN,OYYAX INTEGER NBOP,NBP,NBCHR INTEGER IOPER(NBOPD),IXINFO(2,NBPD) REAL X(NBPD),Y(NBPD),Z(NBPD) ENDSEGMENT * SEGMENT DESSIC CHARACTER*(NBCHRD) CARACT ENDSEGMENT POINTEUR CESSIN.DESSIN POINTEUR CESSIC.DESSIC * * DECLARATION POUR LGI DIMENSION Q(20),ICOLT(9) -INC CCREEL C+PPf (FACE) DIMENSION ITCODP(6),ITCODM(6) DATA ITCODP/3,1,5,4,6,2/ DATA ITCODM/2,6,1,4,3,5/ C+PPf DATA DESSIN/0/ DATA ICOLT/0,1,2,5,3,6,4,7,8/ DATA HEGEND/' ', > ' Framemaker ', > 'PostScript couleur', > ' PostScript NB '/ DATA MISO/0/ * Pour le lgi verification des bornes C INITIALISATION incr=0 chmess=' ' * OUVERTURE XWINDOW CALL XOPEN(NCOUMA,ICOSC,IOPOLI) * si ncouma = 0 pas de display on tente le lgi mcouma=ncouma TITRS=TITR LTITRE=LONG(TITRS) ltitre=72 IF (DESSIN.EQ.0) THEN NBPD=5000 NBOPD=5000 NBCHRD=5000 SEGINI DESSIN,DESSIC CALL SAVSEG(DESSIN) CALL SAVSEG(DESSIC) ENDIF TITRS=TITR valeus=valeu RETURN ** C====================================================================== ENTRY XDFENE(XMI,XXA,YMI,YYA,XR1,XR2,YR1,YR2,FENE) * DEFINITION FENETRE segact dessin*mod,dessic*mod * reinitialisation du dessin if (mcouma.eq.0) return IBOPD=0 IBPD=0 IBCHRD=0 LTITRE=LONG(TITRS) NBPD=5000 NBOPD=5000 NBCHRD=5000 SEGADJ DESSIN,DESSIC NBOP=0 NBCHR=0 NBP=0 TITRE=TITRS VALEUR=valeus * DEBUT DE DESSIN XR1=XMI XR2=XXA YR1=YMI YR2=YYA FENET=FENE XMIN=XMI XXAX=XXA YMIN=YMI YYAX=YYA OXMIN=XMI OXXAX=XXA OYMIN=YMI OYYAX=YYA RETURN ** C====================================================================== cbp ENTRY XTRLAB(XT,YT,CARAC,NCARR,HAUT,ipoli) cbp : ipoli est le 3 eme argument de xopen c (les 2 premiers étant ncouma et iscreen) ENTRY XTRLAB(XT,YT,CARAC,NCARR,HAUT,IANGLE) * ECRITURE TEXT CODE OPERATION 1 1 POINT DES CARACTERES ncar=long(carac(1:ncarr)) NBOP=NBOP+2 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-1)=1 IOPER(NBOP)=NCAR NBP=NBP+1 IF (NBP.GT.NBPD) THEN NBPD=NBPD+100000 SEGADJ DESSIN ENDIF X(NBP)=XT Y(NBP)=YT Z(NBP)=0 cbp: on stocke ANGLE + IALIGN de INFOTR(1 et 2) dans IXINFO c et on n utilisera pour l instant qu en cas de sortie PS... IXINFO(1,NBP)=INFOTR(1) IXINFO(2,NBP)=INFOTR(2) c if(INFOTR(1).ne.0.or.INFOTR(1).ne.0.) write(6,*) c &'CARAC=',CARAC(1:NCAR),' IXINFO=',IXINFO(1,NBP),IXINFO(2,NBP) NBCHR=NBCHR+NCAR IF (NBCHR.GT.NBCHRD) THEN NBCHRD=NBCHRD+100000 SEGADJ DESSIC ENDIF CARACT(NBCHR-NCAR+1:NBCHR)=CARAC(1:NCAR) RETURN ** C====================================================================== ENTRY XCHCOU(JCOLO) * CHANGEMENT DE COULEUR CODE OPERATION 2 1 ENTIER NBOP=NBOP+2 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-1)=2 IOPER(NBOP)=JCOLO RETURN ** C====================================================================== ENTRY XINSEG(JSEG,IRESS) * CHANGEMENT SEGMENT CODE OPERATION 3 1 ENTIER segact dessin*mod,dessic*mod NBOP=NBOP+2 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-1)=3 IOPER(NBOP)=JSEG RETURN ** C====================================================================== ENTRY XPOLRL(NTRSTU,XTR,YTR) * POLYLINE CODE OPERATION 4 NBDE POINTS POINTS NBOP=NBOP+2 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-1)=4 IOPER(NBOP)=NTRSTU NBP=NBP+NTRSTU IF (NBP.GT.NBPD) THEN NBPD=NBPD+100000 SEGADJ DESSIN ENDIF DO 10 I=1,NTRSTU X(NBP-NTRSTU+I)=XTR(I) Y(NBP-NTRSTU+I)=YTR(I) 10 CONTINUE RETURN ** C====================================================================== ENTRY XTRFAC(NTRSTU,XTR,YTR,ZN,ICOLE,IEFF) * FACETTE CODE OPERATION 5 NBDE POINTS COULEUR POINTS C PPf NBOP=NBOP+3 NBOP=NBOP+4 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF C PPf IOPER(NBOP-2)=5 IOPER(NBOP-3)=5 C PPf IOPER(NBOP-1)=NTRSTU IOPER(NBOP-2)=NTRSTU C PPf IOPER(NBOP)=ICOLE IOPER(NBOP-1)=ICOLE C+PPf ZZN=ABS(ZN/REAL(XPI)*2) IF (ZZN.GT.0.99999)ZZN=0.99999 IZN=INT(6*ZZN)+1 IOPER(NBOP)=ITCODP(IZN) C write (6,*)'ZN, ZZN, IZN, IOPER(NBOP)', ZN, ZZN, IZN, IOPER(NBOP) C+PPf NBP=NBP+NTRSTU IF (NBP.GT.NBPD) THEN NBPD=NBPD+100000 SEGADJ DESSIN ENDIF DO 20 I=1,NTRSTU X(NBP-NTRSTU+I)=XTR(I) Y(NBP-NTRSTU+I)=YTR(I) Z(NBP-NTRSTU+I)=0 20 CONTINUE IEFF=1 * IEFF=0 signifie qu'on ne met pas en noir les traits (cas des iso RETURN ** C====================================================================== ENTRY XTRAIS(NP,XTR,YTR,ICOLE) * FACETTE CODE OPERATION 6 NBDE POINTS POINTS NBOP=NBOP+3 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-2)=6 IOPER(NBOP-1)=NP IOPER(NBOP)=ICOLE NBP=NBP+NP IF (NBP.GT.NBPD) THEN NBPD=NBPD+100000 SEGADJ DESSIN ENDIF DO 30 I=1,NP X(NBP-NP+I)=XTR(I) Y(NBP-NP+I)=YTR(I) Z(NBP-NP+I)=0 30 CONTINUE RETURN ** C====================================================================== * AFFICHAGE DU DESSIN ATTENTE D'EVENEMENT C====================================================================== ENTRY XTRDIG(XRO,XCOL,ICLE) segact dessin*mod,dessic*mod ICLE=0 IRDIG=1 GOTO 35 ENTRY XTRAFF(ICLE) SEGACT DESSIN,DESSIC ICLE=0 IRDIG=0 35 CONTINUE * AFFICHAGE DU DESSIN ATTENTE D'EVENEMENT IDAFF=0 ITYP=0 250 CONTINUE IBOP=IBOPD IBP=IBPD IBCHR=IBCHRD IF (IBOPD.EQ.0) THEN CHAINE(1:LTITRE)=TITRE(1:LTITRE) CALL XRINIT(ICHAIN,VALEUR,LTITRE,MISO) ENDIF CALL XFENET(XMIN,XXAX,YMIN,YYAX,FENET) 99 CONTINUE 100 CONTINUE IBOP=IBOP+1 IF (IBOP.GT.NBOP) GOTO 200 ICOD=IOPER(IBOP) IF (ICOD.EQ.1) THEN IBOP=IBOP+1 NBCAR=IOPER(IBOP) IBP=IBP+1 CHAINE(1:NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR) CALL XRLABL(X(IBP),Y(IBP),ICHAIN,NBCAR) IBCHR=IBCHR+NBCAR ELSEIF (ICOD.EQ.2) THEN IBOP=IBOP+1 ICOUL=IOPER(IBOP) CALL XHCOUL(ICOUL) ELSEIF (ICOD.EQ.3) THEN * OUVERTURE SEGMENT IBOP=IBOP+1 ELSEIF (ICOD.EQ.4) THEN IBOP=IBOP+1 N=IOPER(IBOP) CALL XOLRL(N,X(IBP+1),Y(IBP+1)) IBP=IBP+N ELSEIF (ICOD.EQ.5) THEN IBOP=IBOP+1 N=IOPER(IBOP) IBOP=IBOP+1 ICOL=IOPER(IBOP) CALL XHCOUL(ICOL) C+PPf IBOP=IBOP+1 IZN=IOPER(IBOP) C+PPf C PPf CALL XRFACE(N,X(IBP+1),Y(IBP+1)) CALL XRFACE(N,X(IBP+1),Y(IBP+1),IZN) IBP=IBP+N ELSEIF (ICOD.EQ.6) THEN IBOP=IBOP+1 N=IOPER(IBOP) IBOP=IBOP+1 ICO=IOPER(IBOP) if (ico.gt.1000.or.ico.lt.0) then * write (6,*) '1 - ico incorrect ',ico ico=0 endif C palette des iso if (mcouma.ge.16) ico=ico+100 CALL XHCOUL(ICO) if (N.GT.2) CALL XRAISO(N,X(IBP+1),Y(IBP+1)) if (N.EQ.2) CALL XOLRL(N,X(IBP+1),Y(IBP+1)) IBP=IBP+N ELSEIF (ICOD.EQ.7) THEN IBOP=IBOP+1 IFENJ=IOPER(IBOP) CALL XVALIS(IFENJ,IRESV,NHH) ELSEIF (ICOD.EQ.8) THEN * menu en blanc CALL XHCOUL(7) CALL XENU(IEGEND,KCASE,KLONG) ELSEIF (ICOD.EQ.9) THEN IBOP=IBOP+1 IMAG=IOPER(IBOP) CALL XRIMAG(IMAG) ELSEIF (ICOD.EQ.10) THEN IBOP=IBOP+1 ITYP=IOPER(IBOP) IBOP=IBOP+1 NBIMAG=IOPER(IBOP) CALL XRANIM(ITYP,NBIMAG) *** CALL XRSWAP(IRET) ELSEIF (ICOD.EQ.11) THEN * menu en blanc If(icosc.eq.1) then CALL XHCOUL(7) else CALL XHCOUL(0) endif ENDIF GOTO 100 200 CONTINUE IBPD=IBP IBOPD=IBOP-1 IBCHRD=IBCHR * cas animation et affichage initial. on swappe pour voir qqchose ** IF (ITYP.GT.0.and.iret.eq.0) CALL XRSWAP(IRET) iret=0 ICLE=-2 * on affiche un message eventuel if (chmess.ne.' ') then nbcar=long(chmess) CALL XVALIS(3,IRESV,NHH) CALL XHCOUL(7) CALL XRLABL(0.,0.,ICHmes,NBCAR) endif CALL XRAFF(YRO,YCOL,IRDIG,ICLE) IF (IRDIG.EQ.1) THEN XRO=YRO XCOL=YCOL ENDIF * reaffichage IF (ICLE.EQ.-1) THEN IBPD=0 IBOPD=0 IBCHRD=0 GOTO 250 ENDIF * on invalide le message eventuel chmess=' ' * CLE INACTIVE IF (ICLE.GE.0) THEN IF (KEGEND(ICLE*KLONG+1:(ICLE+1)*KLONG).EQ.' ') ICLE=-2 IF(KEGEND(1+ICLE*KLONG+(klong-8)/2: # (ICLE+1)*KLONG).EQ.'Softcopy') GOTO 700 ENDIF ** IF (ICLE.EQ.7.AND.KCASE.EQ.9) THEN iou=9 ipuo=1+klong*(iou-1) * write(6,*) Kegend(IPUO:IPUO+10) * write(6,*)' icle ' , icle ipuo=1+klong*(iou-1) IF(ICLE.EQ.8.AND.Kegend(ipuo:ipuo+10).eq.' Animation') $ THEN * write(6,*) ' on tente lanimation ' * ANIMATION IDES=0 INCR=1 310 CONTINUE IDES=IDES+INCR IF (IDES.EQ.NBIMAG) INCR=-1 IF (IDES.EQ.1) INCR= 1 IBOP=0 IBP=0 IBCHR=0 ITRAC=0 CALL XFENET(XMIN,XXAX,YMIN,YYAX,FENET) 301 CONTINUE IBOP=IBOP+1 IF (IBOP.GT.NBOP) GOTO 302 ICOD=IOPER(IBOP) IF (ICOD.EQ.1) THEN IBOP=IBOP+1 NBCAR=IOPER(IBOP) IBP=IBP+1 CHAINE(1:NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR) IF (ITRAC.NE.0) CALL XRLABL(X(IBP),Y(IBP),ICHAIN,NBCAR) IBCHR=IBCHR+NBCAR ELSEIF (ICOD.EQ.2) THEN IBOP=IBOP+1 ICOUL=IOPER(IBOP) IF (ITRAC.NE.0) CALL XHCOUL(ICOUL) ELSEIF (ICOD.EQ.3) THEN * OUVERTURE SEGMENT IBOP=IBOP+1 ELSEIF (ICOD.EQ.4) THEN IBOP=IBOP+1 N=IOPER(IBOP) IF (ITRAC.NE.0) CALL XOLRL(N,X(IBP+1),Y(IBP+1)) IBP=IBP+N ELSEIF (ICOD.EQ.5) THEN IBOP=IBOP+1 N=IOPER(IBOP) IBOP=IBOP+1 ICOL=IOPER(IBOP) C+PPf IBOP=IBOP+1 C+PPf IF (ITRAC.NE.0) THEN CALL XHCOUL(ICOL) C+PPf IZN=IOPER(IBOP) C+PPf C PPf CALL XRFACE(N,X(IBP+1),Y(IBP+1)) CALL XRFACE(N,X(IBP+1),Y(IBP+1),IZN) ENDIF IBP=IBP+N ELSEIF (ICOD.EQ.6) THEN IBOP=IBOP+1 N=IOPER(IBOP) IBOP=IBOP+1 ICO=IOPER(IBOP) if (ico.gt.1000.or.ico.lt.0) then * write (6,*) '2 - ico incorrect ',ico ico=0 endif if (mcouma.ge.16) ico=ico+100 IF (ITRAC.NE.0) THEN CALL XHCOUL(ICO) if (N.GT.2) CALL XRAISO(N,X(IBP+1),Y(IBP+1)) if (N.EQ.2) CALL XOLRL(N,X(IBP+1),Y(IBP+1)) ENDIF IBP=IBP+N ELSEIF (ICOD.EQ.7) THEN IBOP=IBOP+1 IFENJ=IOPER(IBOP) IF (ITRAC.NE.0) CALL XVALIS(IFENJ,IRESV,NHH) ELSEIF (ICOD.EQ.8) THEN ELSEIF (ICOD.EQ.9) THEN IBOP=IBOP+1 IMAG=IOPER(IBOP) IF (IDES.EQ.IMAG) ITRAC=1 IF (IDES.NE.IMAG) ITRAC=0 ELSEIF (ICOD.EQ.10) THEN IBOP=IBOP+1 ITYP=IOPER(IBOP) IBOP=IBOP+1 NBIMAG=IOPER(IBOP) ELSEIF (ICOD.EQ.11) THEN ENDIF GOTO 301 302 CONTINUE CALL XRSWAP(IRET) IF (IRET.EQ.0.AND.(ITYP.NE.1.OR.INCR.EQ.1)) GOTO 310 CALL XENU(IEGEND,KCASE,KLONG) GOTO 250 ENDIF if (irdig.eq.0) SEGDES DESSIN,DESSIC RETURN 700 CONTINUE * on propose le choix de la softcopie CALL XHCOUL(7) CALL XENU(JEGEND,4,18) CALL XRAFF(YRO,YCOL,IRDIG,ICLE) if (icle.le.0) goto 700 icle=icle+1 * on signale qu'on a compris l'instruction CALL XVALIS(3,IRESV,NHH) CALL XHCOUL(0) chaine='Softcopie '//hegend(icle) > (1:long(hegend(icle)))//' effectuee' CALL XRLABL(0.,0.,ICHAIN,80) * on repositionne le menu CALL XENU(IEGEND,KCASE,KLONG) C--------------------------------------------------- * impression du dessin (Softcopy) * on reboucle sur la structure du trace IDAFF=0 ITYP=0 750 CONTINUE IBOP=0 IBP=0 IBCHR=0 CHAINE=TITRE(1:LTITRE) if (icle.eq.4) then CALL strini(24,axax,ayay,chaine(1:ltitre),1.5,.true.,ncoumb) CALL sdfene(XMIN,XXAX,YMIN,YYAX,XXR1,XXR2,YYR1,YYR2,FENET) CALL sfvali(0,iresv,nhh,MISO) elseif (icle.eq.3) then CALL ctrini(24,axax,ayay,chaine(1:ltitre),1.5,.true.,ncoumb) CALL cdfene(XMIN,XXAX,YMIN,YYAX,XXR1,XXR2,YYR1,YYR2,FENET) CALL cfvali(0,iresv,nhh,MISO) elseif (icle.eq.2) then CALL mtrini(24,axax,ayay,chaine,1.5,.true.,ncoumb) CALL mdfene(XMIN,XXAX,YMIN,YYAX,XXR1,XXR2,YYR1,YYR2,FENET) endif c boucle sur le objets IBOP 760 CONTINUE IBOP=IBOP+1 IF (IBOP.GT.NBOP) then if (icle.eq.4) then call straff(ibid) elseif (icle.eq.3) then call ctraff(ibid) elseif (icle.eq.2) then call mtraff(ibid) endif GOTO 200 endif ICOD=IOPER(IBOP) c il s'agit d un label IF (ICOD.EQ.1) THEN IBOP=IBOP+1 NBCAR=IOPER(IBOP) IBP=IBP+1 CHAINE(1:NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR) INFOTR(1)=IXINFO(1,IBP) INFOTR(2)=IXINFO(2,IBP) if (icle.eq.4) then CALL strlab(X(IBP),Y(IBP),CHAINE,NBCAR,0.15) elseif (icle.eq.3) then CALL ctrlab(X(IBP),Y(IBP),CHAINE,NBCAR,0.15) elseif (icle.eq.2) then CALL mtrlab(X(IBP),Y(IBP),CHAINE,NBCAR,0.15) endif INFOTR(1)=0 INFOTR(2)=0 IBCHR=IBCHR+NBCAR c il s'agit d une couleur ELSEIF (ICOD.EQ.2) THEN IBOP=IBOP+1 ICOUL=IOPER(IBOP) if (icle.eq.4) then CALL schcou(ICOUL) elseif (icle.eq.3) then CALL cchcou(ICOUL) elseif (icle.eq.2) then CALL mchcou(ICOUL) endif ELSEIF (ICOD.EQ.3) THEN * OUVERTURE SEGMENT IBOP=IBOP+1 ELSEIF (ICOD.EQ.4) THEN IBOP=IBOP+1 N=IOPER(IBOP) if (icle.eq.4) then CALL spolrl(N,X(IBP+1),Y(IBP+1)) elseif (icle.eq.3) then CALL cpolrl(N,X(IBP+1),Y(IBP+1)) elseif (icle.eq.2) then CALL mpolrl(N,X(IBP+1),Y(IBP+1)) endif IBP=IBP+N ELSEIF (ICOD.EQ.5) THEN IBOP=IBOP+1 N=IOPER(IBOP) IBOP=IBOP+1 ICOL=IOPER(IBOP) if (icle.eq.4) then CALL strfac(N,X(IBP+1),Y(IBP+1),Z(IBP+1),icol,ibid) elseif (icle.eq.3) then CALL ctrfac(N,X(IBP+1),Y(IBP+1),Z(IBP+1),icol,ibid) elseif (icle.eq.2) then C+PPf IZN=IOPER(IBOP+1) IZN=ITCODM(IZN) ZZN=(IZN-0.99999)*REAL(XPI)/12 C+PPf C PPf CALL mtrfac(N,X(IBP+1),Y(IBP+1),Z(IBP+1),icol,ibid) CALL mtrfac(N,X(IBP+1),Y(IBP+1),ZZN,icol,ibid) endif C+PPf IBOP=IBOP+1 C+PPf IBP=IBP+N ELSEIF (ICOD.EQ.6) THEN IBOP=IBOP+1 N=IOPER(IBOP) IBOP=IBOP+1 ICO=IOPER(IBOP) if (icle.eq.4) then CALL strais(N,X(IBP+1),Y(IBP+1),ico) elseif (icle.eq.3) then CALL ctrais(N,X(IBP+1),Y(IBP+1),ico) elseif (icle.eq.2) then CALL mtrais(N,X(IBP+1),Y(IBP+1),ico) endif IBP=IBP+N ELSEIF (ICOD.EQ.7) THEN IBOP=IBOP+1 IFENJ=IOPER(IBOP) if (icle.eq.4) then CALL sfvali(IFENJ,IRESV,NHH,miso) elseif (icle.eq.3) then CALL cfvali(IFENJ,IRESV,NHH,miso) elseif (icle.eq.2) then CALL mfvali(IFENJ,IRESV,NHH) endif ELSEIF (ICOD.EQ.8) THEN * pas de menu ELSEIF (ICOD.EQ.9) THEN * pas de nouvelle image IBOP=IBOP+1 ELSEIF (ICOD.EQ.10) THEN IBOP=IBOP+1 ITYP=IOPER(IBOP) IBOP=IBOP+1 NBIMAG=IOPER(IBOP) ELSEIF (ICOD.EQ.11) THEN * menu en blanc ENDIF goto 760 ** C====================================================================== ENTRY XMENU(LEGEND,NCASE,LLONG) * * MENU on sauve le contenu * segact dessin*mod,dessic*mod KCASE=NCASE KLONG=LLONG KEGEND(1:KLONG*KCASE)=LEGEND(1:KLONG*KCASE) * on rajoute une touche PS (certains cas seront a exclure) kcase=kcase+1 KEGEND(1+KLONG*(kcase-1):KLONG*kcase)=' ' KEGEND(1+KLONG*(kcase-1)+(klong-8)/2:KLONG*kcase)='Softcopy' C#MC 05/01/99 utilite ? IDEFOR inconuu... C IDEFO=IDEFOR * ON SE MET DANS LE SEGMENT 0 * CHANGEMENT SEGMENT CODE OPERATION 3 1 ENTIER NBOP=NBOP+2 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-1)=3 IOPER(NBOP)=0 NBOP=NBOP+1 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP)=8 RETURN ** ENTRY XTRANI(ITYPI,NBIMAH) NBOP=NBOP+3 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-2)=10 IOPER(NBOP-1)=ITYPI IOPER(NBOP)=NBIMAH RETURN ** ENTRY XTRIMA(IMAGI) NBOP=NBOP+2 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-1)=9 IOPER(NBOP)=IMAGI RETURN ** ENTRY XFVALI(IFENI,IRESU,NH,NISO) segact dessin*mod,dessic*mod * sauver le nb d'iso MISO=NISO * CHANGEMENT DE VIEW PORT IF (IFENI.EQ.1) THEN NBOP=NBOP+2 IF (NBOP.GT.NBOPD) THEN NBOPD=NBOPD+100000 SEGADJ DESSIN ENDIF IOPER(NBOP-1)=7 IOPER(NBOP)=IFENI ENDIF NH=31 RETURN ** C====================================================================== ENTRY XZOOM(IZOOM,XMI,XMA,YMI,YMA) * mise à jour du cadre * IZOOM=1 zoom * IZOOM=-1 zoom inverse * IZOOM=0 pan segact dessin*mod,dessic*mod if (izoom.eq.1) then XMIN=XMI XXAX=XMA YMIN=YMI YYAX=YMA endif if (izoom.eq.-1) then AXMIN=XMIN-(XMI-XMIN)*(XXAX-XMIN)/(XMA-XMI) AXXAX=AXMIN+(XXAX-XMIN)*(XXAX-XMIN)/(XMA-XMI) XMIN=AXMIN XXAX=AXXAX AYMIN=YMIN-(YMI-YMIN)*(YYAX-YMIN)/(YMA-YMI) AYYAX=AYMIN+(YYAX-YMIN)*(YYAX-YMIN)/(YMA-YMI) YMIN=AYMIN YYAX=AYYAX endif if (izoom.eq.0) then XMIN=XMIN-(XMA-XMI) XXAX=XXAX-(XMA-XMI) YMIN=YMIN-(YMA-YMI) YYAX=YYAX-(YMA-YMI) endif XMI=OXMIN XMA=OXXAX YMI=OYMIN YMA=OYYAX IBPD=0 IBOPD=0 IBCHRD=0 RETURN ** C====================================================================== ENTRY XINI(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA) * RETOUR AU DESSIN INITIAL segact dessin*mod,dessic*mod XMIN=OXMIN XXAX=OXXAX YMIN=OYMIN YYAX=OYYAX ISORT=0 IRESU=2 IBPD=0 IBOPD=0 IBCHRD=0 RETURN ** C====================================================================== ENTRY XCHANG(IRESU,ISORT,ICHANG,JSEG) segact dessin*mod,dessic*mod IDSGT=0 * affichage desaffichage num noeuds elements qual IF (ICHANG.EQ.1) THEN IBON=1 IBOP=0 IBCHR=0 IBP=0 JBOP=0 JBCHR=0 JBP=0 300 CONTINUE IBOP=IBOP+1 IF (IBOP.GT.NBOP) GOTO 350 ICOD=IOPER(IBOP) IF (IBON.EQ.1) THEN JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) IF (ICOD.EQ.1) THEN * xrlabl IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) NBCAR=IOPER(IBOP) CARACT(JBCHR+1:JBCHR+NBCAR)=CARACT(IBCHR+1:IBCHR+NBCAR) IBCHR=IBCHR+NBCAR JBCHR=JBCHR+NBCAR IBP=IBP+1 JBP=JBP+1 X(JBP)=X(IBP) Y(JBP)=Y(IBP) Z(JBP)=Z(IBP) ELSEIF (ICOD.EQ.2) THEN * chcoul IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) ELSEIF (ICOD.EQ.3) THEN * OUVERTURE SEGMENT IBOP=IBOP+1 IF (IOPER(IBOP).EQ.JSEG) THEN IBON=0 * IL FAUDRA REPRENDRE LE DESSIN AU DEBUT IBOPD=0 IBPD=0 IBCHRD=0 * ON NE STOCKE PAS CE CHANGEMENT DE SEGMENT JBOP=JBOP-1 GOTO 300 ELSE JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) ENDIF ELSEIF (ICOD.EQ.4) THEN * polyline IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) N=IOPER(IBOP) DO 305 IIP=1,N IBP=IBP+1 JBP=JBP+1 X(JBP)=X(IBP) Y(JBP)=Y(IBP) Z(JBP)=Z(IBP) 305 CONTINUE ELSEIF (ICOD.EQ.5) THEN * face IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) N=IOPER(IBOP) IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) DO 307 IIP=1,N IBP=IBP+1 JBP=JBP+1 X(JBP)=X(IBP) Y(JBP)=Y(IBP) Z(JBP)=Z(IBP) 307 CONTINUE C+PPf IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) C+PPf ELSEIF (ICOD.EQ.6) THEN * iso IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) N=IOPER(IBOP) IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) DO 309 IIP=1,N IBP=IBP+1 JBP=JBP+1 X(JBP)=X(IBP) Y(JBP)=Y(IBP) Z(JBP)=Z(IBP) IOPER(JBOP)=IOPER(IBOP) 309 CONTINUE ELSEIF (ICOD.EQ.7) THEN * fvalis IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) ELSEIF (ICOD.EQ.8) THEN * menu ELSEIF (ICOD.EQ.9) THEN * changement image IBOP=IBOP+1 JBOP=JBOP+1 IOPER(JBOP)=IOPER(IBOP) ELSEIF (ICOD.EQ.10) THEN * initialisation animation IBOP=IBOP+2 JBOP=JBOP+2 IOPER(JBOP)=IOPER(IBOP) ELSEIF (ICOD.EQ.11) THEN ENDIF ELSE IF (ICOD.EQ.1) THEN * xrlabl IBOP=IBOP+1 NBCAR=IOPER(IBOP) IBCHR=IBCHR+NBCAR IBP=IBP+1 ELSEIF (ICOD.EQ.2) THEN * chcoul IBOP=IBOP+1 ELSEIF (ICOD.EQ.3) THEN * OUVERTURE SEGMENT ON REVIENT EN TETE IBOP=IBOP-1 IBON=1 GOTO 300 ELSEIF (ICOD.EQ.4) THEN * polyline IBOP=IBOP+1 N=IOPER(IBOP) IBP=IBP+N ELSEIF (ICOD.EQ.5) THEN * face IBOP=IBOP+1 N=IOPER(IBOP) IBOP=IBOP+1 C+PPf IBOP=IBOP+1 C+PPf IBP=IBP+N ELSEIF (ICOD.EQ.6) THEN * iso IBOP=IBOP+1 N=IOPER(IBOP) IBOP=IBOP+1 IBP=IBP+N ELSEIF (ICOD.EQ.7) THEN * fvalis IBOP=IBOP+1 ELSEIF (ICOD.EQ.8) THEN * menu ELSEIF (ICOD.EQ.9) THEN * changement image IBOP=IBOP+1 ELSEIF (ICOD.EQ.10) THEN * initialisation animation IBOP=IBOP+2 ELSEIF (ICOD.EQ.11) THEN ENDIF ENDIF GOTO 300 350 CONTINUE NBOP=JBOP NBP=JBP NBCHR=JBCHR ICHANG=0 ISORT=0 RETURN ELSE ISORT=1 IRESU=JSEG ICHANG=1 RETURN ENDIF ** C====================================================================== ENTRY XTRBOX(HAUTX,HAUTY) * INUTILISE RETURN ** C====================================================================== ENTRY XTREFF * INUTILISE RETURN ** C====================================================================== ENTRY XVAL(IRESU,ISORT,ISO) C#MC IF (ISO.NE.0.AND.IDEFO.EQ.0) THEN IF (ISO.NE.0) THEN IRESU=10 ISORT=1 ENDIF RETURN ** C====================================================================== ENTRY XMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL) * INUTILISE RETURN ** ** C====================================================================== ENTRY XIMPR * INUTILISE RETURN ** C====================================================================== ENTRY XTRTIN * INUTILISE RETURN ** C====================================================================== ENTRY XFLGI * INUTILISE RETURN ** C====================================================================== ENTRY XTRMFI * INUTILISE RETURN ** C====================================================================== ENTRY XTRMES(CARAC) CHMESS=CARAC RETURN ** C====================================================================== ENTRY XTRGET(PROMPT,REPLY) segact dessin*mod,dessic*mod LPROMP=LONG(PROMPT) LREPLY=LONG(REPLY) CHAINE=PROMPT CALL XVALIS(3,IRESV,NHH) IF(icosc.eq.1) then ico1=7 else ico1=8 endif CALL XHCOUL(ico1) CALL XRGET(ICHAIN,LPROMP,ICHAIN,LREPLY) REPLY=' ' IF (LREPLY.NE.0) REPLY=CHAINE(1:LREPLY) RETURN ** C====================================================================== ENTRY XRCLIK(KCLICK) CALL XCLIK(KCLICK) END