C CalComp-GKS interface C C This file contains the CalComp plotting routines C PLOTS, PLOT, NEWPEN, SYMBOL and NUMBER C coded in the ANSI X3.9-1978 FORTRAN77 standard full language employing C the ANSI X3.124-1985 GKS (Graphical Kernel System) Level 0b C subroutines. Whereas the original CalComp routines are conformable to C the ANSI X3.10-1966 FORTRAN standard, the dummy argument text of the C subroutine SYMBOL is declared here as C CHARACTER*(*) TEXT C in order to conform to the ANSI X3.9-1978 FORTRAN77 standard. In this C way, the subroutine SYMBOL is not conformal to the original CalComp C specification. C C CalComp configuration: C INTERACTIVE WORKSTATION... Identifier of the interactive C workstation, i.e. the workstation at which the user is C asked to confirm or reset the configuration. The plot C on the interactive worrkstation is not erased before the C user's confirmation. The identifier of the interactive C workstation may be changed only by means of editting the C configuration file. Zero or none identifier leads to the C batch mode in which all plots are made without asking the C user for confirmation. C Note, that in this interface, the workstation identifier, C connection identifier, and workstation type are the same C integer referred in the GKS configuration file kernel.sys. C OPEN WORKSTATIONS... Identifiers of the workstations which are to C be opened for ploting. The list open workstations may be C changed through the interactive workstation before C starting each plot, or by means of editting the C configuration file. C CALCOMP PLOT WINDOW... The dimensions of picture in the CalComp C units. The CalComp plot window is mapped onto the largest C rectangle within the workstation viewport, having the same C aspect ratio as the CalComp plot window. The CalComp plot C window may be reset through the interactive workstation C before starting each plot, or by means of editting the C configuration file. C Note that the workstation viewport is the maximum plot C area of the workstation. C COLOUR REPETITION... If this integer is set to N, colours 2 to N C are periodically repeated representing also colour indices C N+1 to 2*N-1, 2*N to 3*N-2, 3*N-1 to 4*N-3, and so on. C This unimportant option may be set only by means of C editting the configuration file. C 'COLOUR TABLE'... String representing the name of the disk file C containing the colour table. If blank (default), C no colour table is read and 16 default colours 0 to 15, C defined in subroutine PLOTS, are used. Otherwise, the C colours specified in the disk file are redefined or C defined in addition to the default colours. See the C description of the CalComp colour table file below. C C CalComp configuration file 'calcomp.cfg': C When the CalComp configuration is changed, this interface creates C file calcomp.cfg containing the new configuration in the current C directory. As long as the file calcomp.cfg lives in the current C directory, the CalComp configuration is taken from calcomp.cfg. C Thus, to return to the default CalComp configuration, simply C delete calcomp.cfg. C C Error listing file 'calcomp.lst': C File calcomp.lst is created in the current directory in order to C contain the GKS error messages. C C CalComp colour table file: C The file is read by list-directed (free format) input, and C consists of lines defining individual colours. Each line contains C four numbers: C K,R,G,B C K... Index of the colour to be defined. Non-negative integer. C R... Content of the red colour. Real between 0 and 1. C G... Content of the green colour. Real between 0 and 1. C B... Content of the blue colour. Real between 0 and 1. C C Declaration of the common memory storage locations: C ------------------------------------------------------------------ BLOCK DATA PLOTB INCLUDE 'calcomp.inc' END C ------------------------------------------------------------------ C C Date: 1995, May 20 C Coded by Ludek Klimes C C======================================================================= C SUBROUTINE PLOTS(I1,I2,I3) INTEGER I1,I2,I3 C C Input: C I1,I2,I3... Dummy parameters - ignored. C No output. C C Common block /PLOTC/: INCLUDE 'calcomp.inc' C C Subroutines and external functions required: REAL RNUM EXTERNAL PLOTB,RNUM,NEWPEN,NUMBER EXTERNAL GOPKS,GOPWK,GACWK,GCLRWK,GDAWK,GCLWK,GSWKWN,GQOPWK,GQEWK EXTERNAL GQWKCA,GQWKCL,GQDSP,GSCHH,GSCR,GSTXCI,GTX,GINST,GRQST C PLOTB.. Block data subroutine of this file. C RNUM... Auxiliary real function converting a string into the C corresponding number. This file. C NEWPEN,NUMBER... This file. C G*****... GKS standard subroutines. C C Date: 1995, May 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: C CHARACTER*80 STR(1),CTABLE INTEGER LUCFG,LUERR,IERR,LENGTH,IC1,IC2,I,J,K,N,NDEC,IDC,IX,IY PARAMETER (LUCFG=97) PARAMETER (LUERR=98) REAL RX,RY,XMAX,YMAX,XNDC,YNDC REAL X1,X2,X3,X4,X5,X6,X7,Y,YH,HEIGHT,R,G,B REAL RX1,RX2,RY1,RY2 C REAL AUX C C STR... Temporary string storage location. C CTABLE..Name of the file contaning colour table. C LUCFG...Logical unit number of the CalComp configuration file C calcomp.lst. C LUERR...Logical unit number of the error file calcomp.lst. C IERR... Error code. C LENGTH... Length of a string. C IC1,IC2... Text colour indices when writing to the display. C I,J,K,N... Temporary storage locations. C NDEC... Number of decimal places. C IDC... Workstation units (0... metres, 1... relative). C IX,IY...Dimensions of a workstation viewport in pixels. C RX,RY...Dimensions of a workstation viewport in the workstation C units. C XMAX,YMAX... Dimensions of the CalComp plot window in centimeters. C XNDC,YNDC... Dimensions of the CalComp plot window in NDC units. C X1,X2,X3,X4,X5,X6,X7,Y... World coordinates. C YH... Line spacing. C HEIGHT..Character height. C R,G,B,RX1,RX2,RY1,RY2,AUX... Temporary storage locations. C C....................................................................... C C Opening GKS: OPEN(LUERR,FILE='calcomp.lst') WRITE(LUERR,'(A)') 'GKS ERROR MESSAGES:' CALL GOPKS(LUERR,-1) C C Reading CalComp parameters: 1 CONTINUE C Default CalComp parameters IUSER=0 DO 2 I=1,MOPEN IOPEN(I)=0 2 CONTINUE XMAX=29.7 YMAX=21.0 KOLREP=0 CTABLE=' ' OPEN(LUCFG,FILE='calcomp.cfg',STATUS='OLD',IOSTAT=IERR) IF(IERR.EQ.0) THEN C Reading the parameters from the CalComp configuration file READ(LUCFG,*,END=4) IUSER READ(LUCFG,*,END=4) IOPEN READ(LUCFG,*,END=4) XMAX,YMAX READ(LUCFG,*,END=4) KOLREP READ(LUCFG,*,END=4) CTABLE 4 CONTINUE CLOSE(LUCFG) ELSE IUSER=1 IOPEN(1)=1 END IF DO 5 I=1,MOPEN IF(IOPEN(I).LE.0) THEN NOPEN=I-1 GO TO 6 END IF 5 CONTINUE NOPEN=MOPEN 6 CONTINUE IF(IUSER.LE.0) THEN GO TO 20 END IF C C *** beginning of the interactive part *** C C Displaying CalComp parameters: CALL GQOPWK(1,IERR,N,I) IF(IERR.EQ.0.AND.N.EQ.1.AND.IUSER.EQ.I) THEN C Interactive workstation already open CALL GCLRWK(IUSER,1) ELSE IF(IERR.NE.0.OR.N.EQ.0) THEN C Interactive workstation closed CALL GOPWK(IUSER,IUSER,IUSER) CALL GACWK(IUSER) ELSE PAUSE ' CalComp: Error when opening interactive workstation' STOP END IF X1=0.00 X2=0.22 X3=0.50 X4=0.64 X5=0.67 X6=0.82 X7=0.94 YH=0.04 HEIGHT=0.65*YH CALL GSCHH(HEIGHT) Y=1.-YH IC1=1 IC2=5 CALL GSCR(IUSER, 0,0.0,0.6,0.0) CALL GSCR(IUSER,IC1,1.0,1.0,1.0) CALL GSCR(IUSER,IC2,1.0,1.0,0.0) CALL GSTXCI(IC1) CALL GTX(X1,Y,'FORTRAN77 CalComp to GKS conversion software.') Y=Y-2.*YH CALL GTX(X1,Y,'Workstation:') CALL GTX(X2,Y,'Classification:') CALL GTX(X3,Y,'Viewport size:') CALL GTX(X6,Y,'Units:') CALL GTX(X7,Y,'Status:') CALL GQEWK(1,IERR,N,K) IF(IERR.EQ.0) THEN DO 15 J=1,N CALL GQEWK(J,IERR,N,K) IF(IERR.EQ.0) THEN CALL GQWKCA(K,IERR,I) IF(IERR.EQ.0.AND.(I.EQ.0.OR.I.EQ.2.OR.I.EQ.4)) THEN C Workstation is of the category: OUTPUT, OUTIN or MO. Y=Y-YH C (1) Workstation CALL NUMBER(X1,Y,HEIGHT,FLOAT(K),0.,-1) C (2) Classification CALL GQWKCL(K,IERR,I) IF(IERR.EQ.0) THEN IF(I.EQ.0) THEN STR(1)='VECTOR' ELSE IF(I.EQ.1) THEN STR(1)='RASTER' ELSE STR(1)='OTHER' END IF CALL GTX(X2,Y,STR(1)) END IF C (3-6) Viewport size and its units CALL GQDSP(K,IERR,IDC,RX,RY,IX,IY) IF(IERR.EQ.0) THEN IF(IDC.EQ.0) THEN STR(1)='cm' RX=RX*100. RY=RY*100. NDEC=2 ELSE STR(1)=' ' C AUX=AMAX1(XMAX/RX,YMAX/RY) C RX=RX*AUX C RY=RY*AUX IF(RX.LT.0.99995) THEN RX=RX*100. RY=RY*100. NDEC=2 ELSE IF(IX.LT.9999) THEN RX=FLOAT(IX) RY=FLOAT(IY) NDEC=-1 ELSE IF(RX.LT.99.95) THEN NDEC=1 ELSE NDEC=-1 END IF END IF END IF END IF CALL NUMBER(X3,Y,HEIGHT,RX,0.,NDEC) CALL GTX(X4,Y,'*') CALL NUMBER(X5,Y,HEIGHT,RY,0.,NDEC) CALL GTX(X6,Y,STR(1)) END IF C (7) Status STR(1)='CLOSED' DO 14 I=1,NOPEN IF(IOPEN(I).EQ.K) THEN STR(1)='OPEN' END IF 14 CONTINUE CALL GSTXCI(IC2) CALL GTX(X7,Y,STR(1)) CALL GSTXCI(IC1) END IF END IF 15 CONTINUE END IF Y=Y-2.*YH CALL GTX(X1,Y,'CalComp plotting window:') CALL GSTXCI(IC2) CALL NUMBER(X3,Y,HEIGHT,XMAX,0.,2) CALL GSTXCI(IC1) CALL GTX(X4,Y,'*') CALL GSTXCI(IC2) CALL NUMBER(X5,Y,HEIGHT,YMAX,0.,2) CALL GSTXCI(IC1) CALL GTX(X6,Y,'cm') Y=Y-YH CALL GTX(X1,Y,'Colour-table filename:') IF(CTABLE.EQ.' ') THEN CALL GTX(X3,Y,'NONE') ELSE CALL GSTXCI(IC2) CALL GTX(X3,Y,CTABLE) CALL GSTXCI(IC1) END IF Y=Y-2.*YH CALL GTX(X1,Y, * 'Enter a digit to open/close the corresponding workstation,') Y=Y-YH CALL GTX(X1,Y, * 'Enter ''W'' to change the CalComp plotting window,') Y=Y-YH CALL GTX(X1,Y, * 'Enter ''C'' to change the colour-table filename,') Y=Y-YH CALL GTX(X1,Y, * 'Press ''ENTER'' to continue.') Y=Y-2.*YH CALL GTX(X1,Y, * 'After plotting, press ''ENTER'' again to continue.') C C Changing CalComp parameters: CALL GQDSP(IUSER,IERR,IDC,RX,RY,IX,IY) RX1=0.00*RX RX2=1.00*RX RY1=0.01*RY RY2=0.99*RY CALL GINST(IUSER,IUSER,14,'YOUR ANSWER: ', * 1,RX1,RX2,RY1,RY2,80,14,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) IF(LLE('1',STR(1)(14:14)).AND.LLE(STR(1)(14:14),'9')) THEN DO 17 J=1,NOPEN IF(IOPEN(J).EQ.ICHAR(STR(1)(14:14))-ICHAR('0')) THEN NOPEN=NOPEN-1 DO 16 I=J,NOPEN IOPEN(I)=IOPEN(I+1) 16 CONTINUE GO TO 18 END IF 17 CONTINUE NOPEN=NOPEN+1 IOPEN(NOPEN)=ICHAR(STR(1)(14:14))-ICHAR('0') 18 CONTINUE ELSE IF(STR(1)(14:14).EQ.'W'.OR.STR(1)(14:14).EQ.'w') THEN CALL GINST(IUSER,IUSER,33,'ENTER HORIZONTAL DIMENSION: ', * 1,RX1,RX2,RY1,RY2,80,29,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) XMAX=RNUM(STR(1),LENGTH) CALL GINST(IUSER,IUSER,33,'ENTER VERTICAL DIMENSION: ', * 1,RX1,RX2,RY1,RY2,80,27,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) YMAX=RNUM(STR(1),LENGTH) ELSE IF(STR(1)(14:14).EQ.'C'.OR.STR(1)(14:14).EQ.'c') THEN CALL GINST(IUSER,IUSER,33,'ENTER COLOUR TABLE FILENAME: ', * 1,RX1,RX2,RY1,RY2,80,30,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) CTABLE=STR(1)(INDEX(STR(1),':')+2:LEN(STR(1))) ELSE GO TO 20 END IF C C Writing CalComp parameters into the CalComp configuration file: OPEN(LUCFG,FILE='calcomp.cfg') WRITE(LUCFG,*) IUSER, ' / INTERACTIVE WORKSTATION' WRITE(LUCFG,*) (IOPEN(I),I=1,NOPEN),' / OPEN WORKSTATIONS' WRITE(LUCFG,*) XMAX,YMAX, ' / CALCOMP PLOT WINDOW' WRITE(LUCFG,*) KOLREP, ' / COLOUR REPETITION' I=LEN(CTABLE)+1 19 CONTINUE I=I-1 IF(I.GT.1.AND.CTABLE(I:I).EQ.' ') GO TO 19 WRITE(LUCFG,*) '''',CTABLE(1:I), ''' / COLOUR-TABLE FILE' CLOSE(LUCFG) GO TO 1 C C *** end of the interactive part *** C C Opening and activating workstations 20 CONTINUE XNDC=XMAX/AMAX1(XMAX,YMAX) YNDC=YMAX/AMAX1(XMAX,YMAX) DO 27 I=1,NOPEN IF(IOPEN(I).EQ.IUSER) THEN CALL GCLRWK(IOPEN(I),1) ELSE CALL GOPWK(IOPEN(I),IOPEN(I),IOPEN(I)) CALL GACWK(IOPEN(I)) END IF CALL GSWKWN(IOPEN(I),0.,XNDC,0.,YNDC) C C Default colour representation C R20(dB): 1.00 0.90 0.80 0.71 0.63 0.56 0.50 C R40(dB/2): 0.95 0.85 0.75 0.67 0.60 0.53 C IF(IOPEN(I).EQ.IUSER) THEN CALL GSCR(IOPEN(I), 0,1.00,1.00,1.00) CALL GSCR(IOPEN(I), 1,0.00,0.00,0.00) CALL GSCR(IOPEN(I), 2,1.00,0.00,0.00) CALL GSCR(IOPEN(I), 3,0.00,0.90,0.00) CALL GSCR(IOPEN(I), 4,0.00,0.00,1.00) CALL GSCR(IOPEN(I), 5,1.00,0.90,0.00) CALL GSCR(IOPEN(I), 6,0.00,0.80,0.90) CALL GSCR(IOPEN(I), 7,0.90,0.00,0.90) CALL GSCR(IOPEN(I), 8,0.90,0.63,0.50) CALL GSCR(IOPEN(I), 9,0.63,0.63,0.63) CALL GSCR(IOPEN(I),10,0.95,0.00,0.71) CALL GSCR(IOPEN(I),11,0.71,0.85,0.00) CALL GSCR(IOPEN(I),12,0.00,0.63,0.95) CALL GSCR(IOPEN(I),13,0.95,0.63,0.00) CALL GSCR(IOPEN(I),14,0.00,0.85,0.71) CALL GSCR(IOPEN(I),15,0.71,0.00,0.95) 27 CONTINUE IF(IUSER.NE.0) THEN DO 28 I=1,NOPEN IF(IOPEN(I).EQ.IUSER) THEN GO TO 29 END IF 28 CONTINUE C Closing the display CALL GDAWK(IUSER) CALL GCLWK(IUSER) 29 CONTINUE END IF C C Setting coordinate transformation: CALL GSVP(1,0.,XNDC,0.,YNDC) CALL GSWN(1,0.,XMAX,0.,YMAX) CALL GSELNT(1) C C Reading colour table from a disk file: IF(CTABLE.NE.' ') THEN OPEN(LUCFG,FILE=CTABLE,STATUS='OLD',IOSTAT=IERR) IF(IERR.EQ.0) THEN 31 CONTINUE K=-999 READ(LUCFG,*,END=39) K,R,G,B IF(K.LT.0) THEN GO TO 39 END IF DO 32 I=1,NOPEN CALL GSCR(IOPEN(I),K,R,G,B) 32 CONTINUE GO TO 31 39 CONTINUE CLOSE(LUCFG) ELSE PAUSE 'WARNING: COLOUR TABLE FILE NOT FOUND.' END IF END IF C C CalComp plotting initialisation: ICOUNT=0 STARTX=0. STARTY=0. OLDX=0. OLDY=0. KOLOR=0 CALL NEWPEN(1) RETURN END C C----------------------------------------------------------------------- C REAL FUNCTION RNUM(STR,LENGTH) CHARACTER*(*) STR INTEGER LENGTH C C Auxiliary function to PLOTS, converting an input string to the real C number, used in the interactive part of the PLOTS subroutine. C C....................................................................... C C Auxiliary storage locations: INTEGER I REAL AUX1,AUX2,AUX3 C AUX1=0. AUX2=1. AUX3=1. DO 10 I=1,LENGTH IF(LLE('0',STR(I:I)).AND.LLE(STR(I:I),'9')) THEN AUX1=AUX1*10.+FLOAT(ICHAR(STR(I:I))-ICHAR('0')) AUX2=AUX2*AUX3 ELSE IF(STR(I:I).EQ.'.') THEN AUX3=0.1 END IF 10 CONTINUE RNUM=AUX1*AUX2 RETURN END C C======================================================================= C SUBROUTINE PLOT(XPAGE,YPAGE,IPEN) REAL XPAGE,YPAGE INTEGER IPEN C C Input: C XPAGE,YPAGE... Coordinates of a point, in centimetres from the C current reference point (origin), of the position to which C the pen is to be moved. C IPEN... A signed integer which controls pen status (up or down) C and the origin definition: C IPEN=2... The pen is down during movement, thus drawing a C visible line. C IPEN=3... The pen is up during movement. C IPEN=-2 OR -3... A new origin is defined at the terminal C position after the movement is completed as if IPEN were C positive. C IPEN=999... Output device is closed. C No output. C C Common block /PLOTC/: INCLUDE 'calcomp.inc' C C Subroutines and external functions required: EXTERNAL GDAWK,GCLWK,GCLKS,GQDSP,GPL,GINST,GRQST,GESC C G*****... GKS standard subroutines. C C Date: 1993, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: CHARACTER*80 STR(1) INTEGER IERR,LENGTH,I,IDC,IX,IY REAL RX,RY C C IERR... Error code. C LENGTH... Length of a string. C I... Loop variable. C IDC... Workstation units (0... metres, 1... relative). C IX,IY...Dimensions of a workstation viewport in pixels. C RX,RY...Dimensions of a workstation viewport in the workstation C units. C C....................................................................... C C Recording or plotting the polyline: IF(IABS(IPEN).EQ.2) THEN 1 CONTINUE IF(ICOUNT.EQ.0) THEN ICOUNT=1 PX(1)=STARTX+OLDX PY(1)=STARTY+OLDY END IF IF(ICOUNT.LT.MCOUNT) THEN IF(XPAGE.NE.OLDX.OR.YPAGE.NE.OLDY) THEN ICOUNT=ICOUNT+1 PX(ICOUNT)=STARTX+XPAGE PY(ICOUNT)=STARTY+YPAGE END IF ELSE CALL GPL(ICOUNT,PX,PY) ICOUNT=0 GO TO 1 END IF END IF IF(IPEN.NE.2) THEN IF(ICOUNT.GT.0) THEN IF(ICOUNT.EQ.1) THEN ICOUNT=2 PX(2)=PX(1) PY(2)=PY(1) END IF CALL GPL(ICOUNT,PX,PY) ICOUNT=0 END IF END IF C C Moving the origin: IF(IPEN.GE.0) THEN OLDX=XPAGE OLDY=YPAGE ELSE STARTX=STARTX+XPAGE STARTY=STARTY+YPAGE OLDX=0. OLDY=0. END IF C C Closing CalComp: IF(IPEN.GE.999) THEN C Closing workstations DO 91 I=1,NOPEN IF(IOPEN(I).NE.IUSER) THEN C Closing batch workstations (other than the display) CALL GDAWK(IOPEN(I)) CALL GCLWK(IOPEN(I)) END IF 91 CONTINUE DO 92 I=1,NOPEN IF(IOPEN(I).EQ.IUSER) THEN C Prompting to close the display CALL GESC(-1,1,CHAR(7),1,LENGTH,STR) CALL GESC(-1,1,CHAR(7),1,LENGTH,STR) CALL GESC(-1,1,CHAR(7),1,LENGTH,STR) CALL GQDSP(IUSER,IERR,IDC,RX,RY,IX,IY) CALL GINST(IUSER,IUSER,1,' ',1,0.,RX,0.,RY,80,1,1,STR) CALL GRQST(IUSER,IUSER,IERR,LENGTH,STR(1)) CALL GDAWK(IUSER) CALL GCLWK(IUSER) END IF 92 CONTINUE CALL GCLKS END IF RETURN END C C======================================================================= C SUBROUTINE NEWPEN(INP) INTEGER INP C C Input: C INP... Number of the pen or colour index to be selected. C No output. C C Common block /PLOTC/: INCLUDE 'calcomp.inc' C C Subroutines and external functions required: EXTERNAL GSPLCI,GSPMCI,GSTXCI,GPL C G*****... GKS standard subroutines. C C Date: 1993, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage location: INTEGER I C C I... Colour assigned to the input colour index. C C....................................................................... C IF(INP.NE.KOLOR) THEN C C Plotting the recorded polyline: IF(ICOUNT.GT.0) THEN IF(ICOUNT.EQ.1) THEN ICOUNT=2 PX(2)=PX(1) PY(2)=PY(1) END IF CALL GPL(ICOUNT,PX,PY) ICOUNT=0 END IF C C Changing the colour indices C (for KOLREP.GT.1, colours 2 to KOLREP are periodically repeated) IF(KOLREP.GT.1) THEN I=MOD(INP-2,KOLREP-1)+2 ELSE I=INP END IF CALL GSPLCI(I) CALL GSPMCI(I) CALL GSTXCI(I) C KOLOR=INP END IF RETURN END C C======================================================================= C SUBROUTINE SYMBOL(XPAGE,YPAGE,HEIGHT,TEXT,ANGLE,NCHAR) REAL XPAGE,YPAGE,HEIGHT,ANGLE CHARACTER TEXT*(*) INTEGER NCHAR C C Input: C XPAGE,YPAGE... Coordinates, in centimetres, of the lower left-hand C corner of the first character to be produced. C Continuation occurs when XPAGE and YPAGE equals 999. C HEIGHT..Height, in centimetres, of the characters to be plotted. C The character width, including spacing, is normally the C same as the height. C TEXT... String containing the text to be plotted. C ANGLE...Angle, in degrees anticlockwise from the X-axis, at which C the text is to be plotted. C NCHAR...NCHAR.GT.0: number of characters to be drawn. C NCHAR.EQ.0: one character is to be drawn C NCHAR.LT.0: to plot a centred symbol no. ICHAR(TEXT(1:1)). C NCHAR.EQ.-1: the pen is up during the move. C NCHAR.EQ.-2: the pen is down during the move. C No output. C C Common block /PLOTC/: INCLUDE 'calcomp.inc' C C Subroutines and external functions required: EXTERNAL PLOT EXTERNAL GSCHH,GSCHUP,GTX,GSMKSC,GSMK,GPM,GPL C PLOT... This file. C G*****... GKS standard subroutines. C C Date: 1995, May 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL X,Y,UX,UY C C X,Y... Coordinates. C UX,UY...Text path vector. C C....................................................................... C X=XPAGE Y=YPAGE IF(ABS(X).GT.998.) X=OLDX IF(ABS(Y).GT.998.) Y=OLDY IF(NCHAR.EQ.-2) THEN CALL PLOT(X,Y,2) END IF C C Plotting the recorded polyline: IF(ICOUNT.GT.0) THEN IF(ICOUNT.EQ.1) THEN ICOUNT=2 PX(2)=PX(1) PY(2)=PY(1) END IF CALL GPL(ICOUNT,PX,PY) ICOUNT=0 END IF C UX= COS(.0174533*ANGLE) UY= SIN(.0174533*ANGLE) IF(NCHAR.GE.0) THEN C standard call - text: CALL GSCHH(HEIGHT) CALL GSCHUP(-UY,UX) DO 1 I=1,MAX0(NCHAR,1) CALL GTX(STARTX+X,STARTY+Y,TEXT(I:I)) X=X+UX*HEIGHT Y=Y+UY*HEIGHT 1 CONTINUE ELSE C Special call - centred symbol: * CALL GSMKSC(HEIGHT/'NOMINAL MARKER SIZE') CALL GSMK(ICHAR(TEXT(1:1))) PX(1)=STARTX+X PY(1)=STARTY+Y CALL GPM(1,PX,PY) END IF OLDX=X OLDY=Y RETURN END C C======================================================================= C SUBROUTINE NUMBER (XPAGE,YPAGE,HEIGHT,FPN,ANGLE,NDEC) REAL XPAGE,YPAGE,HEIGHT,FPN,ANGLE INTEGER NDEC C C Input: C XPAGE,YPAGE... Coordinates, in centimetres, of the lower left-hand C corner of the first character to be produced. C Continuation occurs when XPAGE and YPAGE equals 999. C HEIGHT..Height, in centimetres, of the characters to be plotted. C The character width, including spacing, is normally the C same as the height. C FPN... Floating point number to be plotted. C ANGLE...Angle, in degrees anticlockwise from the X-axis, at which C the number is to be plotted. C NDEC... Controls the precision of the conversion of the number C FPN. C NDEC.GE.0: number of decimal places to be drawn, after C rounding. C NDEC.EQ.-1: only the integer portion is to be plotted, C after rounding. C NDEC.LE.-2: -NDEC-1 digits are truncated from the integer C portion, after rounding. C The magnitude of NDEC should not exceed 9. C No output. C C Subroutines and external functions required: EXTERNAL SYMBOL C SYMBOL..This file. C C Date: 1993, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER N,ILP,I,J,K REAL X,Y,FPV,SAMEV PARAMETER (SAMEV=999.) C C N... Storage for (possibly modified) NDEC. C ILP... Length of the integer part of the given number. C I... Temporary storage. C J... Loop variable. C K... Digit to plot. C X,Y... Coordinates. C FPV... Storage for FPN and its decimal modules. C C....................................................................... C X=XPAGE Y=YPAGE FPV=FPN N=MIN0(MAX0(-9,NDEC),9) C C Minus sign: IF (FPV.LT.0) THEN CALL SYMBOL (X,Y,HEIGHT,'-',ANGLE,1) X=SAMEV Y=SAMEV END IF C C To guarantee a correct rounding: IF (N.GE.0) THEN FPV=ABS(FPV)+(0.5*0.1**N) ELSE FPV=ABS(FPV)+(0.05*0.1**N) END IF C C Integer part of the given number: I=INT(ALOG10(FPV)+1.0) IF(N.GE.-1) THEN ILP=I ELSE ILP=I+N+1 END IF IF (ILP.LE.0) THEN CALL SYMBOL (X,Y,HEIGHT,'0',ANGLE,1) X=SAMEV Y=SAMEV ELSE DO 60 J=1,ILP K=FPV*10.**(J-I) CALL SYMBOL (X,Y,HEIGHT,CHAR(ICHAR('0')+K),ANGLE,1) FPV=FPV-(FLOAT(K)*10.**(I-J)) X=SAMEV Y=SAMEV 60 CONTINUE END IF C C Decimal places: IF(N.GE.0) THEN CALL SYMBOL (X,Y,HEIGHT,'.',ANGLE,1) DO 70 J=1,N K=FPV*10. CALL SYMBOL(X,Y,HEIGHT,CHAR(ICHAR('0')+K),ANGLE,1) FPV=FPV*10.-FLOAT(K) 70 CONTINUE END IF RETURN END C C======================================================================= C