C THIS GROUP OF SUBROUTINES SUPPORTS THE COMMON PLOTTING ROUTINES C WHICH ARE USED TO DRIVE THE VARIOUS PLOTTING DEVICES IN A C COMMON MANNER. RATHER THAN ACTUALLY PLOTTING ANYTHING HOWEVER, C THESE ROUTINES CREATE A PLOT FILE RECORDING EACH CALL TO THE C PLOTTING ROUTINES. THIS PLOT FILE MAY BE ACCESSED LATER BY C A TASK WHICH TRANSLATES THEM TO DEVICE SPECIFIC PLOTTING. C EACH RECORD FOLLOWS A FIXED FORMAT: C BYTE 1 = LENGTH OF RECORD IN BYTES, INCLUDING THIS ONE. AT LEAST 2. C BYTE 2 = SUBROUTINE CODE, AS SHOWN BELOW. C THE REST IS THE REAL OR INTEGER PARAMETERS, ARRANGED SO THAT THE C REAL NUMBERS FALL ON DOUBLE WORD BOUNDARIES. C THUS THE FIRST WORD OF EACH RECORD IS 256*CODE + (LENGTH IN BYTES). C EACH SUBROUTINE HAS AN INTEGER CODE AS FOLLOWS: C PLOTS 0 C PLOTF 1 C PLOT 2 C SYMBOL 3 C SYMTYP 4 C NEWPEN 5 C NPLLT 6 C C NOTE: These subroutines may be computer-dependent, since they C encode records as a series of bytes, integers or floats. C They are known to work with PDP-11 and VAX machines. C C David Villeneuve C Division of Physics M23A C National Research Council C Ottawa Ont. K1A 0R6 C 613-993-1288 C C C [PLOTS] C PLOTS IS CALLED TO INITIATE A PLOTTING PAGE. IT WILL ASK THE C USER FOR THE NAME OF A PLOT FILE THE FIRST TIME THROUGH ONLY. C ON SUBSEQUENT CALLS IT DOES NOT PRINT ANYTHING. IT OPENS THE C PLOT FILE, AND RECORDS ITSELF IN A RECORD. THE NAME OF THE C PLOT FILE DEFAULTS TO PLOT.PLT IF THE USER DESIRES. C SUBROUTINE PLOTS INTEGER*2 ICODE LOGICAL SECOND BYTE FILENM(40) COMMON /PFSUBC/ FILENM DATA FILENM /40*0/ DATA SECOND /.FALSE./ !TRUE ON SECOND AND SUBSEQUENT CALLS DATA ICODE /2/ !2 + 0*256 C IF (SECOND) GO TO 100 !SKIP INITIALIZATION ON SUBSEQUENT CALLS C C SEE IF FILENAME ALREADY GIVEN TO PLOTNM C IF (FILENM(1) .EQ. 0) GO TO 40 !NO FILENAME PREVIOUSLY GIVEN C C FILENAME WAS SPECIFIED BY PLOTNM, FIND LENGTH OF NAME AND DON'T ASK FOR NAME C DO 10 J=1,40 IF (FILENM(J) .EQ. 0) GO TO 20 10 CONTINUE 20 LNAME = J-1 GO TO 70 C C SET UP FILE FOR PLOT FILE C 40 WRITE (5,50) 50 FORMAT (' PLOTS -- Enter name of output plot file [PLOT.PLT]: ', $) READ (5,60) LNAME, FILENM 60 FORMAT (Q, 40A1) 70 CALL FDBSET (1, 'NEW') IF (LNAME .LE. 0) CALL ASSIGN (1, 'PLOT.PLT') IF (LNAME .GT. 0) CALL ASSIGN (1, FILENM, LNAME) SECOND = .TRUE. C C WRITE RECORD FOR THIS CALL C 100 WRITE (1) ICODE RETURN END SUBROUTINE PLOTNM (PLOTFI, ICODE) C C Specify the name of the output plot file. C This routine may be called optionally before the first call to PLOTS, C and gives the name of the output plot file. If it is called, then C PLOTS will not prompt for the name of the plot file. This is useful C when the main program wants to supply its own plot file name. C PLOTFI is an ASCIZ string with the full filename, including extension. C ICODE is an integer argument which is not used at this time, and C which should be coded as zero. C BYTE PLOTFI(40), FILENM(40) COMMON /PFSUBC/ FILENM C IF (PLOTFI(1) .EQ. 0) RETURN !NO NAME GIVEN DO 100 J=1,40 !COPY FILENAME INTO COMMON 100 FILENM(J) = PLOTFI(J) RETURN END SUBROUTINE PLOTF INTEGER*2 ICODE DATA ICODE /258/ !2 + 1*256 C C PLOT COMPLETION SUBROUTINE C WRITE (1) ICODE RETURN END SUBROUTINE PLOT (X, Y, IPEN) INTEGER*2 IPEN, ICODE DATA ICODE /524/ !12 + 2*256 C C PEN MOVEMENT SUBROUTINE C WRITE (1) ICODE, IPEN, X, Y RETURN END SUBROUTINE SYMBOL (X, Y, HEIGHT, TEXT, ANGLE, NCHAR) C C CHARACTER PLOTTING SUBROUTINE C CALL SYMBOC (X, Y, HEIGHT, TEXT, ANGLE, NCHAR, -1) !LEFT JUSTIFIED RETURN END SUBROUTINE SYMBOC (X, Y, HEIGHT, TEXT, ANGLE, NCHAR, ICENTR) C C CHARACTER PLOTTING SUBROUTINE, CENTERED C BYTE TEXT(1) INTEGER*2 NCHAR, ICENTR, LEN, ICODE1, ICODE2 DATA ICODE1 /792/ !24 + 3*256 DATA ICODE2 /770/ !2 + 3*256 C IF (NCHAR .EQ. 0) RETURN LEN = 2 IF (NCHAR .LT. 0) GO TO 50 !SPECIAL SYMBOL C C FIND LENGTH OF TEXT C LEN = 0 DO 10 J=1,NCHAR IF (TEXT(J) .EQ. 0) GO TO 20 10 LEN = J 20 IF (LEN .LE. 0) RETURN C C WRITE TWO RECORDS, FIRST WITH ARGUMENTS, SECOND WITH TEXT. C NCHAR IS WRITTEN AT END TO HANDLE -1 AND -2 FOR SPECIAL SYMBOLS. C 50 WRITE (1) ICODE1, LEN, X, Y, HEIGHT, ANGLE, ICENTR, NCHAR WRITE (1) ICODE2, (TEXT(K),K=1,LEN) RETURN END SUBROUTINE NUMBER (X, Y, HEIGHT, FNUM, ANGLE, NDEC) C C DRAWS A DECIMAL NUMBER AT LOCATION X,Y. C C X,Y = POSITION IN INCHES FROM THE CURRENT ORIGIN WHERE LOWER C LEFT CORNER OF FIRST CHARACTER WILL GO. C HEIGHT = HEIGHT IN INCHES OF CHARACTER. C FNUM = REAL NUMBER TO BE WRITTEN. C ANGLE = ANGLE IN DEGREES TO DRAW NUMBER, C MEASURED COUNTERCLOCKWISE FROM POSITIVE X-AXIS. C NDEC = NUMBER OF DECIMAL PLACES AFTER DECIMAL POINT [0:8]. C IF -1, WILL ONLY DRAW INTEGRAL PART, WITHOUT DECIMAL. C BYTE TEXT(15), FMT1(9), FMT2(7) DATA FMT1 / '(', '1', 'P', 'E', '1', '5', '.', '2', ')' / DATA FMT2 / '(', 'F', '1', '5', '.', '2', ')' / C C FLOATING POINT NUMBER C N = MAX0( 0, MIN0( NDEC, 8 ) ) IF (NDEC .LT. 0 .OR. FNUM .EQ. 0 .OR. 1 (ABS(FNUM) .LT. 1.0E4 .AND. ABS(FNUM) .GT. 10.0**(-N))) GO TO 100 FMT1(8) = N + "60 !FORMAT (1PE15.N) ENCODE (15, FMT1, TEXT) FNUM !ENCODE NUMBER INTO TEXT GO TO 200 C C FIXED POINT NUMBER C 100 FMT2(6) = "60 + N !FORMAT (F15.N) ENCODE (15, FMT2, TEXT) FNUM C C DROP LEADING BLANKS C 200 DO 250 J=1,15 IF (TEXT(J) .NE. "40 .AND. TEXT(J) .NE. "44) GO TO 300 250 CONTINUE C C STRIP TRAILING ZEROS AFTER DECIMAL POINT C 300 DO 350 L=15,J,-1 IF (TEXT(L) .NE. "60) GO TO 400 350 CONTINUE 400 IF (TEXT(L) .EQ. "56) L = L-1 !DROP TRAILING DECIMAL C C PLOT THE NUMBER, IN TEXT(J:L) C CALL SYMBOL (X, Y, HEIGHT, TEXT(J), ANGLE, L-J+1) RETURN END SUBROUTINE SYMLEN (TEXT, NCHARS, SIZE, XLEN) C C CALCULATES PLOTTING LENGTH OF THE CHARACTER STRING C OF MAXIMUM LENGTH USING PLOTTING HEIGHT C IN INCHES, AND SETS XLEN TO THE LENGTH IN INCHES. C NOTE THAT THIS IS THE HARDWARE CHARACTER SET VERSION, C SO IT IS NOT VERY ACCURATE. C BYTE TEXT(1) XLEN = 0.0 IF (NCHARS .LE. 0) RETURN DO 10 J=1,NCHARS IF (TEXT(J) .EQ. 0) RETURN XLEN = XLEN + SIZE 10 CONTINUE RETURN END SUBROUTINE SYMTYP (ISYM, SLANT) INTEGER*2 ISYM, ICODE DATA ICODE /1032/ !8 + 4*256 C C CHANGE CHARACTER SET USED BY SYMBOL C WRITE (1) ICODE, ISYM, SLANT RETURN END SUBROUTINE NEWPEN (IPEN) INTEGER*2 IPEN, ICODE DATA ICODE /1284/ !4 + 5*256 C C CHANGE PEN COLOUR C WRITE (1) ICODE, IPEN RETURN END SUBROUTINE NPLLT (ICOL, IR, IG, IB) INTEGER*2 ICOL, IR, IG, IB, ICODE DATA ICODE /1546/ !10 + 6*256 C C NORPAK ROUTINE FOR CHANGING COLOUR - OCCASIONALLY USEFUL. C THIS ROUTINE IS IGNORED BY NON-NORPAK LIBRARIES. C WRITE (1) ICODE, ICOL, IR, IG, IB RETURN END