1C*TXDRIV -- driver for TeX PK Font output 2C+ 3 SUBROUTINE TXDRIV (IFUNC, RBUF, NBUF, CHR, LCHR) 4 IMPLICIT NONE 5 SAVE 6 INTEGER IFUNC, NBUF, LCHR 7 REAL RBUF(*) 8 CHARACTER*(*) CHR 9C 10C PGPLOT driver for PGPLOT TeX PK Font Output files 11C (produces output files 'pgplot.300pk' and 'pgplot.tfm'), 12C {the 300 is dots/per inch and might be different if a 13C different resolution is used}). 14C 15C Device type code: /TX 16C 17C Supported device: PK Font files for TeX on a Vax or on MIPS. 18C 19C Default file names: 'pgplot.RESpk', 'pgplot.tfm' where the 20C "res" is a default value of 300 but may be set to something 21C else. If "res"=300, then the default file names would be 22C 'pgplot.300pk' and 'pgplot.tfm'. 23C If more than 15 font characters are produced, then the file 24C names become 'pgplot_2.300pk' and 'pgplot_2.tfm' ,etcetera 25C for each set of 15 characters output (i.e.- for each PK 26C font produced). 27C 28C Default view surface dimensions: 2.8 inches x 2.8 inches 29C (but may be overridden by the logicals PGPLOT_TX_YINCHES, 30C and PGPLOT_TX_XINCHES 31C { $DEFINE PGPLOT_TX_XINCHES "5.0" 32C $DEFINE PGPLOT_TX_YINCHES "4.5" 33C would provide a "view" surface of 5.0 inches horizontally 34C by 4.5 inches vertically.}). 35C { setenv PGPLOT_TX_XINCHES "5.0" 36C setenv PGPLOT_TX_YINCHES "4.5" 37C would be the equivalent UNIX command. Everywhere 38C you see the command $DEFINE... use the command 39C setenv... under UNIX}. 40C 41C Driver Size (H x V) inches 42C ------ ------------ 43C TX01 2.80 x 2.80 44C 45C 46C 47C 48C Resolution: 300 dots per inch Horizontal and Vertical 49C (made be overridden by the logicals 50C PGPLOT_TX_XRESOL and PGPLOT_TX_YRESOL 51C { $DEFINE PGPLOT_TX_XRESOL "78.0" 52C $DEFINE PGPLOT_TX_YRESOL "78.0" 53C will produce a font at 78 dots per inch 54C resolution. This would be good for a 55C Vaxstation 2000 workstation.}). 56C The default 300 dots per inch is good for a 57C laser printer such as a QMS1200 LaserGrafix 58C or an HP2000 LaserJet. 59C-- 60C 61C+ 62C 63C Color capability: Color indices 0 (erase, white) 64C and 1 (black) are supported. It is not possible to 65C change color representation. 66C 67C Output Orientation: Portrait. (Can be overridden by the 68C logical PGPLOT_TX_ORIENT 69C { $DEFINE PGPLOT_TX_ORIENT "LANDSCAPE"}). 70C 71C Input capability: None. 72C 73C File formats: TeX PK Font file format, and TeX 74C TFM file format. The files are output as 75C FORTRAN, DIRECT ACCESS, UNFORMATTED, 76C 512 BYTE RECORDS so that we can have 77C compatability with the VAX and our 78C UNIX machine. {A raw bitmap copy is 79C also possible if you define the logical 80C PGPLOT_TX_BITFILE . 81C $ DEFINE PGPLOT_TX_BITFILE "MINIMAL" 82C will produce a file copy of the portion 83C of the bitmap which is within the minimal 84C bounding box of the character. 85C $ DEFINE PGPLOT_TX_BITFILE "ALL" will produce 86C a file copy of the complete bitmap of the 87C graphics character.} 88C 89C Obtaining hardcopy: Use the command DUMP to view the 90C output files, or run TeX and include the 91C character of this new font and DVI the output 92C and print the resulting binary file to the 93C correct printer (with PASSALL, NOFEED, or 94C whatever is required for printing binary 95C output to your specific printer). Also, the 96C PKTYPE and TFTOPL TeX debugging programs will 97C allow you to view your output font 98C characteristics. 99C 100C ---------------------------------------------------------------------- 101C 102C---------------------------------------------------------------------- 103C 104C+ 105C TeX Example: Assume you have produced a graph into a 106C PK Font and that the output file names are 'pgplot.300pk' 107C and 'pgplot.tfm' then the following lines in your TeX code 108C would include the graph corresponding to the letter "A" 109C of the TeX PK font "PGPLOT" in the middle of your paper: 110C 111C \font\myfntname=pgplot 112C This is sentence one of the TeX file. 113C Now I will include the character. 114C \centerline{\myfntname A } 115C This is the last sentence. 116C \bye 117C 118C Of course, you must tell TeX and the DVI driver where 119C to find your fonts. On our VAX, we have defined a 120C search list so that if you define the logical 121C TEX_USER_FONTS to be your directory where you keep your 122C fonts, then TeX and the DVI driver will find the 123C 'pgplot.tfm' file and the 'pgplot.300pk' file. So, 124C $DEFINE TEX_USER_FONTS SYS$USERDISK:[USERNAME.FONTS] 125C would cause TeX and the DVI driver to search the normal 126C search path and also the directory 127C SYS$USERDISK:[USERNAME.FONTS] for any fonts that you 128C specified in your TeX file. {Here is an exception for 129C the UNIX. Our UNIX TeX and DVI programs will look in your 130C current directory automatically for the fonts and then 131C will check the system library if it cannot find the 132C fonts in your directory. So you CANNOT setenv 133C TEX_USER_FONTS on our UNIX system...}. 134C 135C Notes: 136C You must change the resolution for different output 137C devices (our DVI driver, DVIHP, for our HP2000 LaserJet 138C would use a resolution of 300 dots per inch; while our 139C DVI driver for the Vaxstation 2000 workstation would 140C need a resolution of 78 dots per inch. The 'pgplot.tfm' 141C file would of course be the same in both cases, but the 142C DVI drivers would look for 'pgplot.300pk' and 'pgplot.78pk' 143C respectively). If you produce an image which is too large 144C (by defining logicals PGPLOT_TX_XINCHES and PGPLOT_TX_YINCHES) 145C then some DVI drivers will leave the page blank where the 146C graph of the character belongs (can sometimes use \hsize and 147C \vsize to help with this). Finally, if your device driver 148C only works with PXL files (like our PRINTRONIX DVI driver), 149C then you may want to run the PKTOPX program to convert 150C the PK Font into a PXL Font which your device driver needs. 151C ----------------------------------------------------------------------- 152C------------------------------------------------------------------------- 153C 154C+ 155C 156C 157C The above example for LaTeX would be: 158C 159C This is the first sentence. 160C Now I will include the character as a figure. 161C \begin{figure} 162C \newfont{\myfntname}{pgplot} 163C \centerline{\myfntname A} 164C \caption{Letter A of PGPLOT font} 165C \end{figure} 166C This is the last sentence. 167C 168C And you would need to define TEX_USER_FONTS on the Vax 169C as before {but again, not under UNIX}. 170C --------------------------------------------------------------------- 171C 172C Version 1.2 - 24-SEP-1989 - Bob Forrest, Electrical Engineering Dept. 173C Texas A&M University; College Station,Texas 77843 174C bitnet: FORREST@TAMVXEE 175C internet: forrest@ee.tamu.edu 176C ---------------------------------------------------------------------- 177C---------------------------------------------------------------------- 178C 179C *** Note: SAVE statement is required in this routine, TXDRIV, and 180C *** in routines GRTX11 and GRTX12. The values of some of 181C *** the variables in each of these 3 routines are required 182C *** upon entry to remain the same as the last time the routine was 183C *** executed. 184C 185C *** PORTABILITY NOTES: ...search for the word "portability" 186C *** or the word "PORTABILITY" 187C -- ... -- 188C Note: {The Vax uses bytes with values from -128 to 127. I therefore 189C use integers for my calculations, and then output the resulting 190C values as a byte by calling two routines which buffer the output 191C up until 512 bytes have been buffered and then writes this 1 record, 192C resets the buffer count and starts buffering again, and also the 193C routine recieves the integer value in the range 0 to 255, 194C then converts the value to the byte value from -128 to 127 and 195C then buffers the byte value for the write to the file. 196C The routines GRTX11 does this for the PK file, and GRTX12 does 197C this for the TFM file. Routines GRTX11 and GRTX12 will definitely 198C haved to be modified if bytes are read and written as NON-SIGNED 199C quantities on a different computer.} 200C Note: {The routine GRTX05 uses an assignment statement SOLBLK='FF'X 201C to set a parameter to have all ones in its bit positions - 202C and SOLWHT='00'X to set a parameter to have all zeros in its bit positions-- 203C this may need to be changed in porting the code to other machines. 204C The variables BITMAP and BUFFER are byte variables and thus 205C use non-standard FORTRAN language in setting and comparing 206C values throughout this driver code. Anywhere that byte variables 207C are used is a suspect in porting this code to other machines.} 208C *** I believe that TeX, etc., uses ASCII internally so that 209C *** the way I have coded the letters will work correctly. 210C *** However, if porting to other machines, keep in mind that 211C *** I have hard-coded the character representations as ASCII values 212C *** specific to a VAX. 213C *** Note: I wrote most of the comments as I was writing these routines. 214C *** There had to be some rewrites on some of the routines, 215C *** such as changing BENCOD from a byte array to an integer 216C *** array, and rewriting the RUN CODING routine. I tried to 217C *** go back and modify the comments that 218C *** I could think of being incorrect. However, I was admittedly 219C *** pressed for time, and may have missed some of the comments, 220C *** I did not go back over the source code line for line. 221C======================================================================= 222C----------------------------------------------------------------------- 223C *** NDEV is an integer parameter containing the number of currently 224C *** supported default device configurations (1, the rest have to be 225C *** gotten by using logicals (or "environment variables"). 226C *** LNWFIL is a logical variable which determines whether a 227C *** a new PK font file and TFM file are to be opened while 228C *** closing the current PK and TFM files. 229C *** INIT is a logical variable which is used to set up the initial 230C *** variables the first time this routine is invoked. INIT is used 231C *** as a flag, the first time we initialize the variables, the next 232C *** time we do not. 233C *** PORTRAIT is a logical array which is used to tell whether the 234C *** output is to be assumed to be in PORTRAIT mode or LANDSCAPE mode. 235C *** BITMAP is an integer which is used to hold an address pointing 236C *** to a dynamically allocated memory array. In later 237C *** routines, BITMAP is a two dimensional array which contains 238C *** a bitmap of the current graph. 239C *** BX is an integer giving the x-direction dimension of the array BITMAP. 240C *** BY is an integer giving the y-direction dimension of the array BITMAP. 241C *** DEVICE is an integer pointing to the current default device selected 242C *** (some of the setup may still be overridden by logicals however). 243C *** IC is an integer variable containing the color index (1=black,0=white) 244C *** to be used on calls to GRTX00 to draw dots, lines, or to clear dots,lines. 245C *** ITMPVR is a temporary integer variable used only intermediately in 246C *** calculations. 247C *** GRGMEM is an integer function used to allocate contiguous bytes 248C *** of memory dynamically at run time. 249C *** GRFMEM is an integer function used free contiguous bytes of 250C *** memory back up. 251C *** LUN is an integer array containing the logical unit numbers of 252C *** the PK file (LUN(1)) and the TFM file (LUN(2)). 253C *** NPICT is an integer used to reference the current picture frame 254C *** being drawn?????. 255C *** PKOUT is an integer variable containing the count on the 256C *** number of PK Font files up through the current one, that 257C *** have (or are) being written. 258C *** CURCHA is an integer variable containing the ASCII value in 259C *** base10 for the current character being encoded as a PK 260C *** Font character. 261C *** IER is an integer array used to obtain the function return values 262C *** for the GRGMEM and GRFMEM functions. 263C *** BC is an integer used to contain the ASCII value for the beginning 264C *** character of the PK Font. 265C *** NPKBYT is an integer variable used to keep a running total on 266C *** the number of bytes written to the PK file. 267C *** MAXX is a real variable which contains the default maximum 268C *** horizontal device coordinate. [0,MAXX(DEVICE)] is the allowed 269C *** default range. 270C *** MAXY is a real variable which contains the default maximum 271C *** vertical device coordinate. [0,MAXY(DEVICE)] is the allowed 272C *** default range. 273C *** RESOLX is a real variable which contains the default resolution in 274C *** dots per inch in the horizontal direction. 275C *** RESOLY is a real variable which contains the default resolution in 276C *** dots per inch in the vertical direction. 277C *** XMAX is a real variable which contains the actual chosen maximum 278C *** horizontal device coordinate (MAXX unless user specifies different). 279C *** YMAX is a real variable which contains the actual chosen maximum 280C *** vertical device coordinate (MAXY unless user specifies different). 281C *** TMPRES is a real variable used only for temporary calculations. 282C *** TMPMXX is a real variable used only for temporary calculations. 283C *** TMPMXY is a real variable used only for temporary calculations. 284C *** DEFNAM is a character variable used to contain the default 285C *** file name prefix. 286C *** MODE is a temporary character variable used for checking the 287C *** values of logical variabels (or "environment variables"). 288C *** MSG is a temporary character variable used in string operations. 289C *** PKFILE is a character variable used to contain the PK file name. 290C *** TFMFIL is a character variable used to contain the TFM file name. 291C *** DEFPK is a character variable used to contain the default PK 292C *** file name. 293C *** TFMDEF is a character variable used to contain the default TFM 294C *** file name. 295C *** CTMPST is a temporary character variable used in string operations. 296C *** BITFIL is a character variable used to contain the BITMAP file 297C *** name. 298C *** DEFBIT is a character variable used to contain the default BITMAP 299C *** file name. 300C *** CHINFO is an integer array used to contain information about each PK 301C *** font character. CHINFO is output as part of the TFM file. 302C *** WIDTH is an integer array used to contain information about each PK 303C *** font character. WIDTH is a table containing the width of each 304C *** of the PK font characters. WIDTH is output to the TFM file. 305C *** HEIGHT is an integer array used to contain information about each PK 306C *** font character. HEIGHT is a table containing the height of each 307C *** of the PK font characters. HEIGHT is output to the TFM file. 308C *** IXBXLL, IYBXLL is the lower left corner of the minimal bounding 309C *** box of the graphics character (which is found in the RUN CODE routine). 310C *** IXBXUR, IYBXUR is the upper right corner of the minimal bounding 311C *** box of the graphics character (which is found in the RUN CODE routine). 312C *** CHBITD is a character variable used to contain the requested 313C *** type of BITMAP DUMP if one is requested -- possible values 314C *** are 'MINIMAL' and 'ALL'. 315C *** LBUSED is a logical used to determine whether the BITMAP has been 316C *** written to or not (in case PGPAGE or PGADVANCE are called before 317C *** actually drawing anything in the BITMAP array). 318C----------------------------------------------------------------------- 319C This is the number of currently 320C installed devices. 321 INTEGER*4 NDEV 322 PARAMETER (NDEV = 1) 323C 324 LOGICAL LBITFO, LNEWFL, INIT, PORTRAIT(NDEV), LBUSED 325 INTEGER*4 BITMAP, BX,BY,DEVICE,I,J,K,IC,ITMPVR 326 INTEGER*4 PKOUT,CURCHA,JTMP1,JTMP2,NPICT,LUN(2),SS_NORMAL 327C 328 INTEGER*4 GRFMEM, GRGMEM 329C 330 INTEGER*4 IER, BC, NPKBYT,IXBXLL,IYBXLL,IXBXUR,IYBXUR 331 REAL*4 MAXX(NDEV),MAXY(NDEV),RESOLX(NDEV),RESOLY(NDEV) 332 REAL*4 XBUF(4), XMAX, YMAX , TMPRES, TMPMXX, TMPMXY 333 CHARACTER DEFNAM*6,MODE*20,MSG*10,CHBITD*7 334 CHARACTER PKFILE*80,TFMFIL*80,DEFPK*80,DEFTFM*80,CTMPST*80 335 CHARACTER BITFIL*80,DEFBIT*80,CHTMPS*80 336 BYTE BYTVAL 337C *** PARAMETER (DEFNAM = 'PGPLOT') 338C *** Use lower case instead for unix... 339 PARAMETER (DEFNAM = 'pgplot') 340 PARAMETER (SS_NORMAL = 1) 341 PARAMETER (BC=65) 342C *** BC could be chosen to be a different value here (and it 343C *** would be changed throught the TeX PK font driver routines). 344C *** Note: 0<=BC<256 is required. BC is the beginning ASCII 345C *** value of the PK font, A=65base10. If you want some other 346C *** character as first, then change the value of BC. 347C *** These TeX PK Font driver routines were designed to only 348C *** have 15 characters per font, but the driver is capable of 349C *** producing several fonts. The Characters codes reset to 350C *** begin with BC for each font. 351 INTEGER CHINFO(BC:BC+14,4),WIDTH(0:15,4),HEIGHT(0:15,4),IWHITE 352 PARAMETER(IWHITE='00'X) 353C Set up initialization for first call. 354 DATA INIT /.TRUE./ 355C Set the default color to black(=1). 356 DATA IC /1/ 357C Set the bitmap to not used. 358 DATA LBUSED /.FALSE./ 359C These are the NDEV sets of 360C device characteristics. 361 DATA PORTRAIT /.TRUE./ 362 DATA MAXX / 855.0/ 363 DATA MAXY / 855.0/ 364 DATA RESOLX / 300.0/ 365 DATA RESOLY / 300.0/ 366C----------------------------------------------------------------------- 367 IF (INIT) THEN 368 DEVICE=1 369C *** Check the logicals (or "Environment variables") beginning 370C *** with "PGPLOT_" for overriding the defaults listed above. 371 CALL GRGENV ('TX_XRESOL', MODE, I) 372 READ(UNIT=MODE,FMT=*,ERR=1,END=1) TMPRES 373 IF(TMPRES.LE.0.0 .AND. MODE.NE.' ') 374 2 CALL GRWARN('PGPLOT_TX_XRESOL ' 375 3 //'has been defined to be < 0.0 dots per inch. ' 376 4 //' **** IGNORING and continuing... *** ') 377 IF(TMPRES.GT.0.0) RESOLX(DEVICE)=TMPRES 3781 CALL GRGENV ('TX_YRESOL', MODE, I) 379 READ(UNIT=MODE,FMT=*,ERR=2,END=2) TMPRES 380 IF(TMPRES.LE.0.0 .AND. MODE.NE.' ') 381 2 CALL GRWARN('PGPLOT_TX_YRESOL ' 382 3 //'has been defined to be <= 0.0 dots per inch. ' 383 4 //' **** IGNORING and continuing... *** ') 384 IF(TMPRES.GT.0.0) RESOLY(DEVICE)=TMPRES 3852 CALL GRGENV ('TX_XINCHES', MODE, I) 386 READ(UNIT=MODE,FMT=*,ERR=3,END=3) TMPMXX 387 IF(TMPMXX.GT.22.0) THEN 388 CALL GRWARN('******-- PGPLOT_TX_XINCHES > 22.0 **** --- ' 389 2 //' This may not work correctly. The design ' 390 3 //'size specified in the PGPLOT TX Driver ' 391 4 //' (TeX PK Font output) allows a range from ' 392 5 //' a little less than 1/11 of an inch to ' 393 6 //' a little more thant 22 inches. ' 394 7 //' You will probably have to modify the ' 395 8 //'source code in order to produce output ' 396 9 //'larger than 22 inches. ') 397 ENDIF 398 IF(TMPMXX.LT.1.0/11.0 .AND. TMPMXX.GT.0.0) THEN 399 CALL GRWARN('******-- PGPLOT_TX_XINCHES < 1.0/11.0 **** -' 400 2 //'-- This may not work correctly. The design ' 401 3 //'size specified allows a range from ' 402 4 //' a little less than 1/11 of an inch to a ' 403 5 //' a little more than 22 inches. ' 404 6 //' You will probably have to modify the ' 405 7 //'source code in order to produce output ' 406 8 //'less than 1/11 inches. ') 407 ENDIF 408 IF(TMPMXX.LE.0.0 .AND. MODE.NE.' ') 409 2 CALL GRWARN('PGPLOT_TX_XINCHES ' 410 3 //'has been defined to be <= 0.0 inches ' 411 4 //' **** IGNORING and continuing... *** ') 412 IF(TMPMXX.GT.0.0) MAXX(DEVICE)=TMPMXX*RESOLX(DEVICE) 4133 CALL GRGENV ('TX_YINCHES', MODE, I) 414 READ(UNIT=MODE,FMT=*,ERR=4,END=4) TMPMXY 415 IF(TMPMXY.GT.22.0) THEN 416 CALL GRWARN('******-- PGPLOT_TX_YINCHES > 22.0 **** --- ' 417 2 //' This may not work correctly. The design ' 418 3 //'size specified allows a range from ' 419 4 //' a little less than 1/11 of an inch to a ' 420 5 //' a little more than 22 inches. ' 421 6 //' You will probably have to modify the ' 422 7 //'source code in order to produce output ' 423 8 //'greater than 22 inches. ') 424 ENDIF 425 IF(TMPMXY.GT.0.0 .AND. TMPMXY.LT.1.0/11.0) THEN 426 CALL GRWARN('******-- PGPLOT_TX_YINCHES < 1.0/11.0 **** -' 427 2 //'-- This may not work correctly. The design ' 428 3 //'size specified allows a range from ' 429 4 //' a little less than 1/11 of an inch to a ' 430 5 //' a little more than 22 inches. ' 431 6 //' You will probably have to modify the ' 432 7 //'source code in order to produce output ' 433 8 //'less than 1/11 inches. ') 434 ENDIF 435 IF(TMPMXY.LE.0.0 .AND. MODE.NE.' ') 436 2 CALL GRWARN('PGPLOT_TX_YINCHES ' 437 3 //'has been defined to be <= 0.0 inches ' 438 4 //' **** IGNORING and continuing... *** ') 439 IF(TMPMXY.GT.0.0) MAXY(DEVICE)=TMPMXY*RESOLY(DEVICE) 4404 CALL GRGENV ('TX_ORIENT', MODE, I) 441 IF(MODE(1:8).EQ.'PORTRAIT') THEN 442 PORTRAIT(DEVICE)=.TRUE. 443 CALL GRWARN('PGPLOT_TX_ORIENT ''''PORTRAIT'''' has ' 444 2 //'been specified.') 445 ENDIF 446 IF(MODE(1:9).EQ.'LANDSCAPE') THEN 447 PORTRAIT(DEVICE)=.FALSE. 448 CALL GRWARN('PGPLOT_TX_ORIENT ''''LANDSCAPE'''' has ' 449 2 //'been specified.') 450 ENDIF 451 CALL GRGENV ('TX_BITFILE', MODE, I) 452 LBITFO=.FALSE. 453 CHBITD=' ' 454 IF(MODE(1:7).EQ.'MINIMUM' .OR. MODE(1:3).EQ.'ALL')THEN 455 LBITFO=.TRUE. 456 CHBITD=MODE 457 ENDIF 458C *** Set INIT to be .FALSE. so that the above checks on 459C *** environment variables will only occur the first time 460C *** that TXDRIV is called. 461 INIT = .FALSE. 462 ENDIF 463C Branch on opcode. 464 GOTO ( 10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 465 1 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 466 2 210, 220, 230, 240, 250, 260), IFUNC 467C Signal an error. 468 900 WRITE (MSG, '(I10)') IFUNC 469 CALL GRWARN ('Unimplemented function in TeX PK Font' 470 1 //' device driver: '// MSG) 471 NBUF = -1 472 RETURN 473C 474C--- IFUNC = 1, Return device name ------------------------------------- 475C 476 10 CONTINUE 477C *** This is the name seen when a "?" is entered by the user for 478C *** the desired output device for PGPLOT. 479 CHR='TX (TeX PK Font generation)' 480 LCHR=LEN(CHR) 481 NBUF = 0 482 RETURN 483C 484C--- IFUNC = 2, Return physical min and max for plot device, and range 485C of color indices --------------------------------------- 486C 487 20 CONTINUE 488C *** Negative one implies that the physical maximums are unlimited for 489C *** this device. PGPLOT requires the minimums to be ZERO. 490 RBUF(1) = 0.0 491 RBUF(2) = -1 492 RBUF(3) = 0.0 493 RBUF(4) = -1 494 RBUF(5) = 0.0 495 RBUF(6) = 1.0 496 NBUF = 6 497 LCHR = 0 498 RETURN 499C 500C--- IFUNC = 3, Return device resolution ------------------------------- 501C 502 30 CONTINUE 503C *** This give the device resolution in dots per inch in the 504C *** horizontal and vertical directions. 505 RBUF(1) = RESOLX(DEVICE) 506 RBUF(2) = RESOLY(DEVICE) 507 RBUF(3) = 1.0 508 NBUF = 3 509 LCHR = 0 510 RETURN 511C 512C--- IFUNC = 4, Return misc device info -------------------------------- 513C (This device is Hardcopy, No cursor, No dashed lines, No area fill, 514C no thick lines) 515C 516 40 CONTINUE 517 CHR = 'HNNNNNNNNN' 518 NBUF = 0 519 LCHR = 10 520 RETURN 521C 522C--- IFUNC = 5, Return default file name ------------------------------- 523C 524 50 CONTINUE 525C *** This returns the default prefix for the filenames of TXDRIV. 526 CHR = DEFNAM 527 NBUF = 0 528 LCHR = LEN(DEFNAM) 529 RETURN 530C 531C--- IFUNC = 6, Return default physical size of plot ------------------- 532C 533 60 CONTINUE 534C *** These defaults are in device coordinate values. 535 RBUF(1) = 0.0 536 RBUF(2) = MAXX(DEVICE) 537 RBUF(3) = 0.0 538 RBUF(4) = MAXY(DEVICE) 539 NBUF = 4 540 LCHR = 0 541 RETURN 542C 543C--- IFUNC = 7, Return misc defaults ----------------------------------- 544C 545 70 CONTINUE 546C *** Has to do with character fonts that PGPLOT reads in. 547 IF (RESOLX(DEVICE) .GE. 300.0) THEN 548 RBUF(1) = 3.0 549 ELSE IF (RESOLX(DEVICE) .GE. 150.0) THEN 550 RBUF(1) = 2.0 551 ELSE 552 RBUF(1) = 1.0 553 END IF 554 NBUF = 1 555 LCHR = 0 556 RETURN 557C 558C--- IFUNC = 8, Select plot -------------------------------------------- 559C This will be a possible future enhancement to 560C have several devices open at one time... 561C 562 80 CONTINUE 563 RETURN 564C 565C--- IFUNC = 9, Open workstation --------------------------------------- 566C 567 90 CONTINUE 568C Assume success. 569 RBUF(2) = 1.0 570C 571C 572C *** Set up the default file name for the TeX PK Font file. 573 ITMPVR=INT(RESOLX(DEVICE)) 574 WRITE(UNIT=MSG,FMT='(I10)') ITMPVR 575 DO 91, I=10,1, -1 576 IF(MSG(1:1).EQ.' ') THEN 577 MSG(1:1)=MSG(2:2) 578 MSG(2:2)=MSG(3:3) 579 MSG(3:3)=MSG(4:4) 580 MSG(4:4)=MSG(5:5) 581 MSG(5:5)=MSG(6:6) 582 MSG(6:6)=MSG(7:7) 583 MSG(7:7)=MSG(8:8) 584 MSG(8:8)=MSG(9:9) 585 MSG(9:9)=MSG(10:10) 586 ELSE 587 GOTO 92 588 ENDIF 58991 CONTINUE 59092 CONTINUE 591 DEFPK=DEFNAM//'.'//MSG(1:I)//'pk' 592C *** 593C *** 594C *** 595C *** Set up the default file name for the TeX TFM file. 596 DEFTFM=DEFNAM//'.tfm' 597C *** Set up the default file name for the raw unformatted BITMAP file. 598 DEFBIT=DEFNAM//'.bitmap' 599C *** 600C *** 601C *** Remove the '.' and any remaining characters after the '.' 602C *** from the file name. We will append the resolution and PK to 603C *** the PK Font output file, and TFM to the TFM file, and 604C *** BITMAP to the raw unformatted bitmap file. 605C 606C *** Store CHR(1:LCHR) in a temporary string, CTMPST to work with. 607 CTMPST=CHR(1:LCHR) 608 DO 94, K=LCHR,1, -1 609C *** Check for ending period on Vax. 610 IF(CTMPST(K:K).EQ.'.') THEN 611 DO 93, J=K,LCHR 612 CTMPST(J:J)=' ' 61393 CONTINUE 614 GOTO 95 615C *** Check for logical name on Vax. 616 ELSE IF(CTMPST(K:K).EQ.':') THEN 617 GOTO 95 618C *** Check for end of directory name on Vax. 619 ELSE IF(CTMPST(K:K).EQ.']') THEN 620 GOTO 95 621C *** Check for end of directory name on Unix. 622 ELSE IF(CTMPST(K:K).EQ.'/') THEN 623 GOTO 95 624 ENDIF 62594 CONTINUE 62695 CONTINUE 627C *** 628C *** Now, find the end of the string. 629 DO 96, K=LCHR,1, -1 630 IF(CTMPST(K:K).NE.' ') GOTO 97 63196 CONTINUE 63297 CONTINUE 633 IF(K.GT.0) THEN 634C *** Set up the requested file names (otherwise, we will set it to the 635C *** DEFAULT NAMES. 636 PKFILE=CTMPST(1:K)//'.'//MSG(1:I)//'pk' 637 TFMFIL=CTMPST(1:K)//'.tfm' 638 BITFIL=CTMPST(1:K)//'.bitmap' 639 ELSE 640 PKFILE=DEFPK 641 TFMFIL=DEFTFM 642 BITFIL=DEFBIT 643 ENDIF 644C *** ---------------------------------------------------------- 645C Obtain a logical unit number 646C for TeX PK Font file. 647 CALL GRGLUN (LUN(1)) 648C Check for an error. 649 IF (LUN(1) .EQ. -1) THEN 650 CALL GRWARN ('Cannot allocate a logical unit for PK File.') 651 RBUF(2) = 0 652 RETURN 653 ELSE 654C Need to return the logical unit 655C number of the file. 656 RBUF(1) = LUN(1) 657 END IF 658C *** 659C 660C OPEN the files. 661C *VMS We will write out 512 bytes at a time. RMS will take 662C care of us when we read the file back in for DVIing it 663C If you have problems, change ACCESS='DIRECT' to 664C ACCESS='SEQUENTIAL' and add RECORDTYPE=FIXED and 665C modify write statements in GRTX11 and GRTX12 to 666C be writes to sequential files. Also, consider 667C using the rewind statement if you do a sequential file. 668 OPEN(UNIT=LUN(1),FILE=PKFILE,ACCESS='DIRECT', 669 2 FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IER, 670 3 DISP='DELETE', 671 4 RECL=128) 672C 673C *** *UNIX Want to open up a file to put "bytes on a disk -- 674C *** with NO segmented record information... 512 bytes 675C *** will be written out at a time. 128*4=512 676C *** OPEN(UNIT=LUN(1),FILE=PKFILE,ACCESS='DIRECT', 677C *** 2 FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IER, 678C *** 3 RECL=128) 679C 680C 681C Check for an error and cleanup if 682C one occurred. 683 IF (IER .NE. 0) THEN 684 CALL GRWARN ('Cannot open output file for TeX PK ' 685 2 //'Font.') 686 RBUF(2) = 0 687 CALL GRFLUN (LUN(1)) 688 RETURN 689 ELSE 690C Get the full file specification 691C and calculate the length of the 692C string 693 INQUIRE (UNIT = LUN(1), NAME = CHR) 694 LCHR = LEN (CHR) 69598 CONTINUE 696 IF (CHR (LCHR:LCHR) .EQ. ' ') THEN 697 LCHR = LCHR - 1 698 GOTO 98 699 END IF 700 END IF 701C *** Initialize some indirect 702C *** file pointer information. 703 CALL GRTX14 704C *** 705C 706C 707C 708C Obtain a logical unit number 709C for TeX TFM file. 710 CALL GRGLUN (LUN(2)) 711C Check for an error. 712 IF (LUN(2) .EQ. -1) THEN 713 CALL GRWARN ('Cannot allocate a logical unit for TFM file.') 714 CLOSE(UNIT=LUN(1)) 715 CALL GRFLUN (LUN(1)) 716 RBUF(2) = 0 717 RETURN 718 END IF 719C 720 IF (LUN(2) .EQ. LUN(1)) THEN 721 CALL GRWARN('ERROR IN PGPLOT LIBRARY GRGLUN FUNCTION. ' 722 2 //'IDENTICAL UNIT NUMBERS WERE RETURNED TO ' 723 3 //'TXDRIV ROUTINE.') 724 CALL GRQUIT('EXITING BACK TO OPERATING SYSTEM FROM TXDRIV.') 725 STOP 726 ENDIF 727C 728 729C *VMS We will write out 512 bytes at a time. RMS will take 730C care of us when we read the file back in for DVIing it 731C If you have problems, change ACCESS='DIRECT' to 732C ACCESS='SEQUENTIAL' and add RECORDTYPE=FIXED and 733C modify write statements in GRTX11 and GRTX12 to 734C be writes to sequential files. Also, 735C consider using the rewind statement if you do sequential 736C files. 737 OPEN(UNIT=LUN(2),FILE=TFMFIL,ACCESS='DIRECT', 738 2 FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IER, 739 3 DISP='DELETE', 740 4 RECL=128) 741C 742C *** *UNIX Want to open up a file to put "bytes on a disk -- 743C *** with NO segmented record information... 512 bytes 744C *** will be written out at a time. 128*4=512 745C *** OPEN(UNIT=LUN(2),FILE=TFMFIL,ACCESS='DIRECT', 746C *** 2 FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IER, 747C *** 3 RECL=128) 748C 749C Check for an error and cleanup if 750C one occurred. 751 IF (IER .NE. 0) THEN 752 CALL GRWARN('Cannot open output file for TeX TFM.') 753 RBUF(2) = 0 754 CLOSE(UNIT=LUN(1)) 755 CALL GRFLUN (LUN(1)) 756 CALL GRFLUN (LUN(2)) 757 RETURN 758 ENDIF 759C *** Initialize some indirect 760C *** file pointer information. 761 CALL GRTX15 762C *** 763C 764C Initialize the plot file. 765C 766C *** Set the character number to 1. 767 CURCHA=1 768C *** Set the PK Font file to 1. 769 PKOUT=1 770C *** Set the number of bytes written to the PK file to 0. 771 NPKBYT=0 772C *** Write the preamble to the PK Font file UNIT=LUN(1). 773 CALL GRTX04 (RESOLX,RESOLY,NDEV,DEVICE,LUN,NPKBYT) 774C *** Set up the TFM file arrays CHINFO, WIDTH, HEIGHT. 775C *** The CHINFO table will remain as set up. The WIDTH and HEIGHT 776C *** tables will be modified for each of the PK Font characters 777C *** as the character is written to the PK file. 778 DO 99, I=0,14 779C *** The width table index is in the first byte. 780 CHINFO(BC+I,1)=I+1 781C *** The height table index is in the first nybble of the 782C *** of the second byte, while the depth table index is in the 783C *** second nybble of the second byte. 784 CHINFO(BC+I,2)=16*(I+1) 785C *** The italic table index is in the first six bits of the 786C *** third byte, while the tag index is in the last two bits 787C *** of the third byte. (Tag=0 means remainder byte 4 is unused). 788 CHINFO(BC+I,3)=0 789C *** This is the remainder byte. It is unused for our purposes. 790 CHINFO(BC+I,4)=0 791C *** Initialize the width table to zero. The width table will be 792C *** modified as each character is written to the PK file. 793 WIDTH(I,1)=0 794 WIDTH(I,2)=0 795 WIDTH(I,3)=0 796 WIDTH(I,4)=0 797C *** Initialize the height table to zero. The height table will be 798C *** modified as each character is written to the PK file. 799 HEIGHT(I,1)=0 800 HEIGHT(I,2)=0 801 HEIGHT(I,3)=0 802 HEIGHT(I,4)=0 80399 CONTINUE 804C *** 805C *** 806C *** 807C 808C Initialize the page counter. 809 NPICT = 0 810 RETURN 811C 812C--- IFUNC = 10, Close workstation ------------------------------------- 813C 814 100 CONTINUE 815C Write out the postamble to 816C the TeX PK file and TeX TFM 817C file and close the files. 818C 819 LNEWFL=.FALSE. 820 CALL GRTX03 (LUN,PKFILE,TFMFIL, 821 2 CURCHA,PKOUT,RESOLX,RESOLY,XMAX,YMAX, 822 3 NDEV,DEVICE,LNEWFL,NPKBYT,CHINFO, 823 4 WIDTH,HEIGHT,BC) 824 825C 826 RETURN 827C 828C--- IFUNC = 11, Begin picture ----------------------------------------- 829C 830 110 CONTINUE 831C Set the bitmap size. 832 XMAX = RBUF(1) 833 YMAX = RBUF(2) 834C Calculate the dimensions of the 835C plot BITMAP. 836 IF (PORTRAIT(DEVICE)) THEN 837 BX = INT (XMAX) / 8 + 1 838 BY = INT (YMAX) + 1 839 ELSE 840 BX = INT (YMAX) / 8 + 1 841 BY = INT (XMAX) + 1 842 END IF 843C Allocate a 2-D array in memory 844C for the BITMAP plot by obtaining 845C BX*BY contiguous bytes of memory. 846 IER = GRGMEM (BX * BY, BITMAP) 847C Check for error and clean up 848C if one was found. 849 IF (IER .NE. SS_NORMAL) THEN 850 CALL GRGMSG (IER) 851 CALL GRQUIT ('Failed to allocate a memory for plot BITMAP.') 852 END IF 853C Increment the page number. 854 NPICT = NPICT + 1 855C start graphics mode. 856C Zero out the plot BITMAP memory array. 857 BYTVAL='00'X 858 CALL GRTX13 (BX*BY, %VAL(BITMAP),BYTVAL) 859C Set up BITMAP as not used. 860 LBUSED=.FALSE. 861 RETURN 862C 863C--- IFUNC = 12, Draw line --------------------------------------------- 864C 865 120 CONTINUE 866C Apply any needed tranformation. 867 IF (PORTRAIT(DEVICE)) THEN 868 DO 125 I = 1, 4 869 XBUF(I) = RBUF(I) 870 125 CONTINUE 871 ELSE 872 XBUF(1) = RBUF(2) 873 XBUF(2) = XMAX - RBUF(1) 874 XBUF(3) = RBUF(4) 875 XBUF(4) = XMAX - RBUF(3) 876 END IF 877C Draw the point into the bitmap. 878 CALL GRTX00 (1, XBUF, IC, BX, BY, %VAL (BITMAP)) 879C If point "drawn" was not an 880C erasure (white), then set 881C BITMAP as having been used. 882 IF(IC.NE.IWHITE) LBUSED=.TRUE. 883 RETURN 884C 885C--- IFUNC = 13, Draw dot ---------------------------------------------- 886C 887 130 CONTINUE 888C Apply any needed tranformation. 889 IF (PORTRAIT(DEVICE)) THEN 890 DO 135 I = 1, 2 891 XBUF(I) = RBUF(I) 892 135 CONTINUE 893 ELSE 894 XBUF(1) = RBUF(2) 895 XBUF(2) = XMAX - RBUF(1) 896 END IF 897C Draw the point into the bitmap. 898 CALL GRTX00 (0, XBUF, IC, BX, BY, %VAL(BITMAP)) 899C If point "drawn" was not an 900C erasure (white), then set 901C BITMAP as having been used. 902 IF(IC.NE.IWHITE) LBUSED=.TRUE. 903 RETURN 904C 905 906C--- IFUNC = 14, End picture ------------------------------------------- 907C 908 140 CONTINUE 909C Need to write out the Font character. 910C *** Encode the current PK Font character and write it out. 911C *** ------------------------------------ 912 DO 141, JTMP2=LEN(PKFILE),2,-1 913 IF(PKFILE(JTMP2:JTMP2).NE.' ') GOTO 142 914141 CONTINUE 915142 CONTINUE 916C *** PORTABILITY NOTE: Might want to use JTMP1=ICHAR('A')+CURCHA-1 917C *** or something equivalent if on an EBCDIC machine... ? 918C *** I think (but I'm not sure) that TeX, etcetera, use ASCII internally. 919C *** I coded this as VaX specific. 920 JTMP1=BC+CURCHA-1 921C IF(ICHAR('A').NE.65) CALL GRWARN('Next message is not correct.' 922C 2 //'it assumes that the ASCII value of A was 65base10.') 923C 924C ---------------- 925C *** *UNIX impossible string concatenation bug workaround. Also works 926C *** under *VMS . 927 CHTMPS=PKFILE 928 CALL GRWARN('Starting to process the image ' 929 2 //'to produce the PK Font '''//CHTMPS(1:JTMP2) 930 3 //''' letter '''//CHAR(JTMP1)//''' from ' 931 4 //'your BITMAP...') 932C ----------------- 933C 934C *** Test to se if BITMAP has been drawn to (used). 935 IF(.NOT. LBUSED) THEN 936 CALL GRWARN('Blank page was submitted for making ' 937 2 //'a character out of. -- ignoring this ' 938 3 //'blank character and continuing.') 939 GOTO 149 940 ENDIF 941C ---------------- 942C *** Time to process the bitmap into a PK Font character. 943C 944 CALL GRTX02 (BX,BY,%VAL(BITMAP),CURCHA, 945 2 RESOLX,RESOLY,XMAX,YMAX,NDEV, 946 3 DEVICE,LUN,NPKBYT,CHINFO, 947 4 WIDTH,HEIGHT,BC,IXBXLL,IYBXLL,IXBXUR,IYBXUR) 948C ---------------- 949C *** PORTABILITY NOTE: Might want to use JTMP1=ICHAR('A')+CURCHA-1 950C *** or something equivalent if on an EBCDIC machine... ? 951C *** I think (but I'm not sure) that TeX, etcetera, use ASCII internally. 952C *** I coded this as VaX specific. 953C IF(ICHAR('A').NE.65) CALL GRWARN('Next message is not correct.' 954C 2 //'it assumes that the ASCII value of A was 65base10.') 955C 956C ---------------- 957C *** Increment the character count. 958C ---------------- 959C *** *UNIX impossible string concatenation bug workaround. Also works 960C *** under *VMS . 961 CHTMPS=PKFILE 962 CALL GRWARN('Finished processing ' 963 2 //'the PK Font '''//CHTMPS(1:JTMP2) 964 3 //''' letter '''//CHAR(JTMP1)//''' from ' 965 4 //'your BITMAP...') 966C ----------------- 967 CURCHA=CURCHA+1 968 IF(CURCHA.GE.16) THEN 969C *** Need to start a new PK Font. We may only have up to 970C *** 15 characters per Font. 971 LNEWFL=.TRUE. 972 CALL GRTX03 (LUN,PKFILE,TFMFIL, 973 2 CURCHA,PKOUT,RESOLX,RESOLY,XMAX,YMAX, 974 3 NDEV,DEVICE,LNEWFL,NPKBYT,CHINFO, 975 4 WIDTH,HEIGHT,BC) 976C *** Set the current character to the first one in the Font. 977 CURCHA=1 978C *** Increment the number of Fonts produced. 979 PKOUT=PKOUT+1 980C *** Reset the TFM arrays CHINFO, WIDTH, HEIGHT for the new Font. 981C *** The CHINFO table will remain as set up. The WIDTH and HEIGHT 982C *** tables will be modified for each of the PK Font characters 983C *** as the character is written to the PK file. 984 DO 143, I=0,14 985C *** The width table index is in the first byte. 986 CHINFO(BC+I,1)=I+1 987C *** The height table index is in the first nybble of the 988C *** of the second byte, while the depth table index is in the 989C *** second nybble of the second byte. 990 CHINFO(BC+I,2)=16*(I+1) 991C *** The italic table index is in the first six bits of the 992C *** third byte, while the tag index is in the last two bits 993C *** of the third byte. (Tag=0 means remainder byte 4 is unused). 994 CHINFO(BC+I,3)=0 995C *** This is the remainder byte. It is unused for our purposes. 996 CHINFO(BC+I,4)=0 997C *** Initialize the width table to zero. The width table will be 998C *** modified as each character is written to the PK file. 999 WIDTH(I,1)=0 1000 WIDTH(I,2)=0 1001 WIDTH(I,3)=0 1002 WIDTH(I,4)=0 1003C *** Initialize the height table to zero. The height table will be 1004C *** modified as each character is written to the PK file. 1005 HEIGHT(I,1)=0 1006 HEIGHT(I,2)=0 1007 HEIGHT(I,3)=0 1008 HEIGHT(I,4)=0 1009143 CONTINUE 1010C *** 1011C *** 1012C *** 1013 ENDIF 1014C *** 1015C *** 1016 IF(LBITFO.EQ..TRUE.) THEN 1017C *** Dump the bitmap out to a file. 1018 CALL GRWARN('Writing out a copy of BITMAP ' 1019 2 //'as you requested by PGPLOT_TX_BITFILE ' 1020 3 //' logical.') 1021 CALL GRTX01 (BX, BY, %VAL (BITMAP),BITFIL, 1022 2 CHBITD,IXBXLL,IYBXLL,IXBXUR,IYBXUR, 1023 3 LUN,PKOUT,CURCHA) 1024 ENDIF 1025C 1026149 CONTINUE 1027C Deallocate the memory for the 1028C BITMAP plot array. 1029 IER = GRFMEM (BX * BY, BITMAP) 1030C Check for an error. 1031 IF (IER .NE. SS_NORMAL) THEN 1032 CALL GRGMSG (IER) 1033 CALL GRWARN('Failed to deallocate memory for plot BITMAP.') 1034 END IF 1035 RETURN 1036C 1037C--- IFUNC = 15, Select color index ------------------------------------ 1038C 1039 150 CONTINUE 1040C Save the requested color index. 1041 IC = RBUF(1) 1042C If out of range set to black. 1043 IF (IC .LT. 0 .OR. IC .GT. 1) THEN 1044 IC = 1 1045 RBUF(1) = IC 1046 END IF 1047 RETURN 1048C 1049C--- IFUNC = 16, Flush buffer. ----------------------------------------- 1050C (Not implemented: ignored.) 1051C 1052 160 CONTINUE 1053 RETURN 1054C 1055C--- IFUNC = 17, Read cursor. ------------------------------------------ 1056C (Not implemented: should not be called.) 1057C 1058 170 CONTINUE 1059 GOTO 900 1060C 1061C--- IFUNC = 18, Erase alpha screen. ----------------------------------- 1062C (Not implemented: ignored.) 1063C 1064 180 CONTINUE 1065 RETURN 1066C 1067C--- IFUNC = 19, Set line style. --------------------------------------- 1068C (Not implemented: should not be called.) 1069C 1070 190 CONTINUE 1071 GOTO 900 1072C 1073C--- IFUNC = 20, Polygon fill. ----------------------------------------- 1074C (Not implemented: should not be called.) 1075C 1076 200 CONTINUE 1077 GOTO 900 1078C 1079C--- IFUNC = 21, Set color representation. ----------------------------- 1080C (Not implemented: ignored.) 1081C 1082 210 CONTINUE 1083 RETURN 1084C 1085C--- IFUNC = 22, Set line width. --------------------------------------- 1086C (Not implemented: should not be called.) 1087C 1088 220 CONTINUE 1089 GOTO 900 1090C 1091C--- IFUNC = 23, Escape ------------------------------------------------ 1092C (Not implemented: ignored.) 1093C 1094 230 CONTINUE 1095 RETURN 1096C 1097C--- IFUNC = 24, Rectangle fill. --------------------------------------- 1098C (Not implemented: should not be called.) 1099C 1100 240 CONTINUE 1101 GOTO 900 1102C 1103C--- IFUNC = 25, ------------------------------------------------------- 1104C (Not implemented: should not be called.) 1105C 1106 250 CONTINUE 1107 GOTO 900 1108C 1109C--- IFUNC = 26, Line of pixels. --------------------------------------- 1110C (Not implemented: should not be called.) 1111C 1112 260 CONTINUE 1113 GOTO 900 1114C----------------------------------------------------------------------- 1115 END 1116C<FF> 1117C *GRTX00 -- PGPLOT TeX PK Font Driver, draw line in BITMAP 1118C 1119 SUBROUTINE GRTX00 (LINE,RBUF,ICOLOR,IBXDIM, 1120 2 IBYDIM,BITMAP) 1121 IMPLICIT NONE 1122 INTEGER*4 IBXDIM,IBYDIM,ICOLOR,LINE 1123 BYTE BITMAP(0:IBXDIM-1,0:IBYDIM-1) 1124 REAL*4 RBUF(4) 1125C 1126C Draw a straight line segment from absolute pixel coordinates (RBUF(1), 1127C RBUF(2)) to (RBUF(3), RBUF(4)). The line either overwrites (sets to 1128C black) or erases (sets to white) the previous contents of the bitmap, 1129C depending on the current color index. Setting bits is accomplished 1130C with Non-standard Fortran as .OR.; clearing 1131C bits is accomplished with Non-standard Fortran as .AND. .NOT.. 1132C 1133C Arguments: 1134C 1135C LINE I I =0 for dot, =1 for line. 1136C RBUF(1),RBUF(2) I R Starting point of line. 1137C RBUF(3),RBUF(4) I R Ending point of line. 1138C ICOLOR I I =0 for erase, =1 for write (black point). 1139C BITMAP I/O B (address of) the frame buffer. 1140C 1141C----------------------------------------------------------------------- 1142 BYTE QMASK(0 : 7) 1143 INTEGER*4 K,KX,KY,LENGTH 1144 REAL*4 D,XINC,XP,YINC,YP 1145 QMASK(0)='80'X 1146 QMASK(1)='40'X 1147 QMASK(2)='20'X 1148 QMASK(3)='10'X 1149 QMASK(4)='08'X 1150 QMASK(5)='04'X 1151 QMASK(6)='02'X 1152 QMASK(7)='01'X 1153C----------------------------------------------------------------------- 1154 IF (LINE .GT. 0) THEN 1155 D = MAX (ABS (RBUF(3) - RBUF(1)), ABS (RBUF(4) - RBUF(2))) 1156 LENGTH = D 1157 IF (LENGTH .EQ. 0) THEN 1158 XINC = 0.0 1159 YINC = 0.0 1160 ELSE 1161 XINC = (RBUF(3) - RBUF(1)) / D 1162 YINC = (RBUF(4) - RBUF(2)) / D 1163 END IF 1164 ELSE 1165 LENGTH = 0 1166 XINC = 0.0 1167 YINC = 0.0 1168 END IF 1169C *** Round to nearest integer in device coordinates. 1170 XP = RBUF(1) + 0.5 1171 YP = RBUF(2) + 0.5 1172 IF (ICOLOR .NE. 0) THEN 1173 DO 100, K = 0, LENGTH 1174 KX = XP 1175 KY = YP 1176 BITMAP(KX/8,KY)=BITMAP(KX/8,KY) .OR. 1177 1 QMASK(MOD (KX, 8)) 1178 XP = XP + XINC 1179 YP = YP + YINC 1180100 CONTINUE 1181 ELSE 1182 DO 200, K=0,LENGTH 1183 KX = XP 1184 KY = YP 1185 BITMAP(KX/8,KY) = BITMAP(KX/8,KY) 1186 1 .AND. (.NOT. QMASK(MOD (KX, 8))) 1187 XP = XP + XINC 1188 YP = YP + YINC 1189200 CONTINUE 1190 END IF 1191C----------------------------------------------------------------------- 1192 RETURN 1193 END 1194C<FF> 1195C *GRTX01 -- PGPLOT Bitmap File Output driver, copy bitmap to output file 1196C 1197 SUBROUTINE GRTX01 (IBXDIM,IBYDIM,BITMAP,BITFIL, 1198 2 CHBITD,IXBXLL,IYBXLL,IXBXUR,IYBXUR, 1199 3 LUN,PKOUT,CURCHA) 1200 IMPLICIT NONE 1201 INTEGER IBXDIM,IBYDIM,IBTLUN,IRECLB,LUN(2),PKOUT,CURCHA 1202 INTEGER IXBXLL,IYBXLL,IXBXUR,IYBXUR 1203 BYTE BITMAP(0:IBXDIM-1,0:IBYDIM-1) 1204 CHARACTER*(*) BITFIL,CHBITD 1205C 1206C Arguments: 1207C 1208C BITLFIL the BITMAP file name (or the default BITMAP file name). 1209C IBXDIM,IBYDIM (input) dimensions of BITMAP 1210C BITMAP (input) the bitmap array 1211C IXBXLL,IYBXLL (input) the pixel numbers of the lower left corner of 1212C the minimal bounding box of the graphics character 1213C IXBXUR,IYBXUR (input) the pixle numbers of the upper right corner of 1214C the minimal bounding box of the graphics character 1215C NOTE: IXBXLL<IXBXUR and IYBXLL<IYBXUR . 1216C LUN (input) contains a list of the device numbers already 1217C allocated to enable error checking. 1218C----------------------------------------------------------------------- 1219 INTEGER I,J,IER,ITEMPV,IRECRD,ILENGT 1220 CHARACTER*10 MSG 1221C----------------------------------------------------------------------- 1222C Set up initial record to first record. 1223 IRECRD=1 1224C Set up the file name for output. 1225 WRITE(UNIT=MSG,FMT='(I5)') (PKOUT-1)*15+CURCHA 1226C *** We will used J to keep track of the length of MSG for the 1227C *** file name below. 1228 DO 10, J=5,1,-1 1229 IF(MSG(1:1).EQ.' ') THEN 1230 MSG(1:1)=MSG(2:2) 1231 MSG(2:2)=MSG(3:3) 1232 MSG(3:3)=MSG(4:4) 1233 MSG(4:4)=MSG(5:5) 1234 MSG(5:5)=' ' 1235 ELSE 1236 GOTO 11 1237 ENDIF 123810 CONTINUE 123911 CONTINUE 1240 1241C *** 1242 ILENGT=LEN(BITFIL) 1243 DO 20, I=ILENGT,1,-1 1244 IF(BITFIL(I:I).EQ.'.') GOTO 21 124520 CONTINUE 124621 CONTINUE 1247 IF(I.GT.0) THEN 1248 BITFIL=BITFIL(1:I-1)//'_'//MSG(1:J)//BITFIL(I:ILENGT) 1249 ELSE 1250 CALL GRWARN('PROGRAMMING ERROR IN BITFIL FILE NAME ' 1251 2 //'IN ROUTINE GRTX01. ERROR WAS MADE ' 1252 3 //'BY AUTHOR OF TXDRIVER ROUTINE.') 1253 CALL GRWARN('TRY ANOTHER NAME FOR YOUR FILE NAME.') 1254 CALL GRQUIT('EXITING BACK TO OPERATING SYSTEM FROM ' 1255 2 //'ROUTINE GRTX01.') 1256 STOP 1257 ENDIF 1258C Finished with I,J,and ILENGT... 1259C *** ----------------------- 1260 1261C Allocate file. 1262 CALL GRGLUN(IBTLUN) 1263 IF(IBTLUN.EQ.-1) THEN 1264 CALL GRWARN ('Cannot allocate a logical unit for the' 1265 2 //' BITMAP copy to a file.') 1266 RETURN 1267 ELSE IF (IBTLUN.EQ.LUN(1) .OR. IBTLUN.EQ.LUN(2))THEN 1268 CALL GRWARN('ERROR IN PGPLOT ROUTINE GRGLUN. IDENTICAL ' 1269 2 //'FORTRAN UNIT NUMBERS WERE RETURNED.') 1270 CALL GRQUIT('EXITING BACK TO OPERATING SYSTEM ' 1271 2 //'FROM ROUTINE GRTX01.') 1272 ELSE 1273 IF(CHBITD(1:7).NE.'MINIMAL') THEN 1274C ------------------------------------------------------------------ 1275 IRECLB=IBXDIM/4 1276 IF(FLOAT(IRECLB).LT.(FLOAT(IBXDIM)/4.0))IRECLB=IRECLB+1 1277C *VMS We will write out IRECLB*4 bytes at a time to the file. 1278 OPEN(UNIT=IBTLUN,FILE=BITFIL,ACCESS='DIRECT', 1279 2 FORM='UNFORMATTED',STATUS='NEW', 1280 3 IOSTAT=IER, 1281 4 DISP='DELETE',RECL=IRECLB) 1282C *** *UNIX 1283C *** OPEN(UNIT=IBTLUN,FILE=BITFIL,ACCESS='DIRECT', 1284C *** 2 FORM='UNFORMATTED',STATUS='NEW', 1285C *** 3 IOSTAT=IER,RECL=IRECLB) 1286 IF(IER.NE.0) THEN 1287 CALL GRWARN('Cannot open the file for the BITMAP' 1288 2 //' copy to a file.') 1289 CALL GRFLUN(IBTLUN) 1290 RETURN 1291 ENDIF 1292C 1293C Loop through bitmap 1294C starting at top left and working 1295C down while outputing one horizontal 1296C row for every write statement. 1297 DO 100, J=IBYDIM-1,0,-1 1298C Write out the bitmap row (raster line) 1299 WRITE(IBTLUN,REC=IRECRD,ERR=600) 1300 2 (BITMAP(I,J),I=0,IBXDIM-1) 1301 IRECRD=IRECRD+1 1302100 CONTINUE 1303C Close the Bitmap output file. 1304C *** *VMS 1305 CLOSE(UNIT=IBTLUN,DISP='KEEP',ERR=500) 1306C *** *UNIX 1307C *** CLOSE(UNIT=IBTLUN,ERR=500) 1308C *** 1309C ------------------------------------------------------------------- 1310 ELSE 1311C ------------------------------------------------------------------- 1312 ITEMPV=(IXBXUR/8 - IXBXLL/8 + 1 ) 1313 IRECLB=ITEMPV/4 1314 IF(FLOAT(ITEMPV/4).LT.(FLOAT(ITEMPV)/4.0))IRECLB=IRECLB+1 1315C OPEN the files. 1316C *VMS We will write out ireclb*4 bytes at a time to 1317C the file. 1318 OPEN(UNIT=IBTLUN,FILE=BITFIL,ACCESS='DIRECT', 1319 2 FORM='UNFORMATTED',STATUS='NEW', 1320 3 IOSTAT=IER, 1321 4 DISP='DELETE',RECL=IRECLB) 1322C *** *UNIX 1323C *** OPEN(UNIT=IBTLUN,FILE=BITFIL,ACCESS='DIRECT', 1324C *** 2 FORM='UNFORMATTED',STATUS='NEW', 1325C *** 3 IOSTAT=IER,RECL=IRECLB) 1326 IF(IER.NE.0) THEN 1327 CALL GRWARN('Cannot open the file for the BITMAP' 1328 2 //' copy to a file.') 1329 CALL GRFLUN(IBTLUN) 1330 RETURN 1331 ENDIF 1332C 1333C Loop through the bitmap 1334C starting at top left of the 1335C minimal bounding box of the graphics 1336C character and working down to the 1337C bottom right of the minimal bounding 1338C box of the graphics character 1339C while outputing one horizontal 1340C row for every write statement. 1341 DO 200, J=IYBXUR,IYBXLL,-1 1342C Write out the bitmap row (raster line) 1343 WRITE(IBTLUN,REC=IRECRD,ERR=600) 1344 2 (BITMAP(I,J),I=IXBXLL/8,IXBXUR/8) 1345 IRECRD=IRECRD+1 1346200 CONTINUE 1347C Close the Bitmap output file. 1348C *** *VMS 1349 CLOSE(UNIT=IBTLUN,DISP='KEEP',ERR=500) 1350C *** *UNIX 1351C *** CLOSE(UNIT=IBTLUN,ERR=500) 1352C 1353C----------------------------------------------------------------------- 1354 ENDIF 1355C Free the logical unit back up. 1356300 CONTINUE 1357 CALL GRFLUN(IBTLUN) 1358 ENDIF 1359 RETURN 1360500 CONTINUE 1361 CALL GRWARN('ERROR CLOSING FILE CONTAINING COPY OF THE ' 1362 2 //' BITMAP') 1363 CALL GRQUIT('EXITING BACK TO OPERATING SYSTEM FROM GRTX01') 1364 STOP 1365600 CONTINUE 1366 CALL GRWARN('ERROR WRITING OUT COPY OF THE BITMAP TO A FILE.') 1367 CALL GRWARN('EXITING BACK TO OPERATING SYSTEM FROM GRTX01') 1368 STOP 1369 END 1370C<FF> 1371C *GRTX02 -- PGPLOT Encode current PK Font character and store it. 1372C 1373 SUBROUTINE GRTX02 (IBXDIM,IBYDIM,BITMAP,CURCHA, 1374 2 RESOLX,RESOLY,XMAX,YMAX,NDEV,DEVICE, 1375 3 LUN,NPKBYT,CHINFO,WIDTH,HEIGHT,BC, 1376 4 IXBXLL,IYBXLL,IXBXUR,IYBXUR) 1377C----------------------------------------------------------------------- 1378C *** 1379 IMPLICIT NONE 1380 INTEGER IBXDIM,IBYDIM,NDEV,DEVICE,CURCHA,I 1381 INTEGER LUN(2),NPKBYT,BC,NC,IRCIND,IRPIND 1382 REAL RESOLX(NDEV),RESOLY(NDEV),XMAX,YMAX 1383 BYTE BITMAP(0:IBXDIM-1,0:IBYDIM-1) 1384 INTEGER WIDTH(0:15,4),HEIGHT(0:15,4),CHINFO(BC:BC+14,4) 1385C 1386 INTEGER GRFMEM, GRGMEM 1387C 1388 INTEGER IRUNCD,IRPEAT,BENCOD,IRCDIM,IRPDIM,IBEDIM 1389 INTEGER IXBXLL,IYBXLL,IXBXUR,IYBXUR,IER,SS_NORMAL 1390 INTEGER IBOXDX,IBOXDY,IDYNF(0:14),IDYNFO,IDYNFV 1391 LOGICAL LIBLAK,LTX05E 1392C *** PARAMETER(SS_NORMAL = 1) 1393 SS_NORMAL=1 1394C *** ------------------------------------------------------------- 1395C *** Get the RUN CODE count values of the BITMAP for later ENCODING. 1396C *** First, we need to allocate an array for containing the 1397C *** run code count values {IRUNCD(IRCDIM))}, and an array 1398C *** for containing the repeat counts {IRPEAT(IRPDIM)}. 1399C *** Instead of guessing that the worst case should be no 1400C *** worse than the image changing every other pixel for 1401C *** run code counts, and then allocating that much virtual memory, 1402C *** we first do all of the RUN-CODE calculations without storing 1403C *** the RUN-CODE results, then we allocate the exact amount of 1404C *** of space required for doing the RUN-CODING and then 1405C *** reenter the GRTX05 routine and store the RUN CODE counts 1406C *** as they are calculated the second time. The logical variable 1407C *** LTX05E is used inside of the GRTX05 routine to determine which 1408C *** pass we are on (LTX05E=.FALSE. for the first pass, and 1409C *** LTX05E=.TRUE. for the second pass). 1410C *** PORTABILITY NOTE: {4 bytes in an integer assumed!. The arrays 1411C *** IRUNCD, IRPEAT and BENCOD are 4 byte integers.} 1412C *** 1413C *** Set the dimension of IRUNCD to be 2 and 1414C *** the dimension of IRPEAT to be 2 initially.(We need to 1415C *** have values for IRUNCD and IRPEAT to be dimensioned inside 1416C *** the GRTX05 routine). 1417 IRCDIM=2 1418 IRPDIM=2 1419C 1420 IER = GRGMEM (IRCDIM*4,IRUNCD) 1421 IF(IER.NE.SS_NORMAL) THEN 1422 CALL GRGMSG(IER) 1423 CALL GRQUIT('Failed to allocate a TeX PK Font IRUNCD ' 1424 2 //' RUN CODE count array the 8 bytes.') 1425 END IF 1426C 1427 IER = GRGMEM (IRPDIM*4,IRPEAT) 1428 IF(IER.NE.SS_NORMAL) THEN 1429 CALL GRGMSG(IER) 1430 CALL GRQUIT('Failed to allocate a TeX PK Font IRPEAT' 1431 2 //' repeat count RUN CODE array 8 bytes.') 1432 END IF 1433C *** Call the RUN CODEing routine, GRTX05 to determine the size 1434C *** needed for allocating virtual memory to contain the RUN CODE 1435C *** counts. IRCIND and IRPIND will contain the needed dimension 1436C *** values upon return from routine GRTX05. 1437 LTX05E=.FALSE. 1438 IRCIND=0 1439 IRPIND=0 1440 CALL GRTX05 (BITMAP,IBXDIM,IBYDIM,%VAL(IRUNCD), 1441 2 IRCDIM,%VAL(IRPEAT),IRPDIM,LIBLAK, 1442 3 IXBXLL,IYBXLL,IXBXUR,IYBXUR, 1443 4 LTX05E,IRCIND,IRPIND) 1444C *** Calculate the width of the minimal bounding box for the character. 1445 IBOXDX=IXBXUR-IXBXLL+1 1446 IBOXDY=IYBXUR-IYBXLL+1 1447C *** Now Deallocate the 8 bytes of Virtual memory contained in 1448C *** the IRCUND and IRPEAT arrays and allocate the amount of 1449C *** virtual memory that we really need for calculating the 1450C *** RUN CODE counts. 1451C 1452 IER=GRFMEM (IRPDIM*4,IRPEAT) 1453 IF(IER.NE.SS_NORMAL) THEN 1454 CALL GRGMSG(IER) 1455 CALL GRQUIT('FAILED TO DEALLOCATE IRPEAT ARRAY' 1456 2 //' MEMORY 8 bytes.') 1457 ENDIF 1458C 1459 IER=GRFMEM (IRCDIM*4,IRUNCD) 1460 IF(IER.NE.SS_NORMAL) THEN 1461 CALL GRGMSG(IER) 1462 CALL GRQUIT('FAILED TO DEALLOCATE IRUNCD ARRAY' 1463 2 //' MEMORY 8 bytes.') 1464 ENDIF 1465C *** 1466C *** Now allocate the actual virtual memory space that we need. 1467 IRCDIM=IRCIND-1 1468 IRPDIM=IRPIND-1 1469C *** Add test for 0 allocation... 1470 IF(IRCDIM.EQ.0) THEN 1471 CALL GRQUIT('ERROR in RUN CODING the IMAGE. The size ' 1472 2 //'of the RUN-CODed image is ZERO. Routine GRTX02.') 1473 ENDIF 1474C 1475 IF(IRPDIM.EQ.0) THEN 1476 IRPDIM=1 1477 CALL GRWARN('There were no repeat counts for the ' 1478 2 //'current graphics character.') 1479 ENDIF 1480C 1481 IER = GRGMEM (IRCDIM*4,IRUNCD) 1482 IF(IER.NE.SS_NORMAL) THEN 1483 CALL GRGMSG(IER) 1484 CALL GRQUIT('Failed to allocate a TeX PK Font IRUNCD ' 1485 2 //' RUN CODE count array.') 1486 END IF 1487C 1488 IER = GRGMEM (IRPDIM*4,IRPEAT) 1489 IF(IER.NE.SS_NORMAL) THEN 1490 CALL GRGMSG(IER) 1491 CALL GRQUIT('Failed to allocate a TeX PK Font IRPEAT' 1492 2 //' repeat count RUN CODE array.') 1493 END IF 1494C *** 1495C *** Now call GRTX05 and calculate -- and this time STORE -- the actual 1496C *** RUN CODE counts. 1497 LTX05E=.TRUE. 1498 IRCIND=0 1499 IRPIND=0 1500 CALL GRTX05 (BITMAP,IBXDIM,IBYDIM,%VAL(IRUNCD), 1501 2 IRCDIM,%VAL(IRPEAT),IRPDIM,LIBLAK, 1502 3 IXBXLL,IYBXLL,IXBXUR,IYBXUR, 1503 4 LTX05E,IRCIND,IRPIND) 1504C *** 1505C *** 1506C *** ------------------------------------------------------------- 1507C *** Get the dyn_f value for the current RUN CODE counts for 1508C *** optimal encoding. 1509 CALL GRWARN('Calculating the optimal dyn_f value ' 1510 2 //'for PK ENCODE-ing the character.') 1511 CALL GRTX06(%VAL(IRUNCD),IRCDIM,IBOXDX, 1512 2 IBOXDY,IDYNF,%VAL(IRPEAT), 1513 3 IRPDIM,BITMAP,IBXDIM,IBYDIM) 1514C *** Determine what the optimal dyn_f value is. 1515 IDYNFO=14 1516 IDYNFV=IDYNF(14) 1517 DO 100, I=0,14 1518 IF(IDYNF(I).LT.IDYNFV) THEN 1519 IDYNFO=I 1520 IDYNFV=IDYNF(I) 1521 ENDIF 1522100 CONTINUE 1523C *** The optimal value of dyn_f is contained in IDYNFO. 1524C *** The number of nybbles required for encoding is contained in IDYNFV. 1525C *** ------------------------------------------------------------- 1526C *** ENCODE the RUN CODE counts using the optimal dyn_f. 1527C *** First, we need to allocate enough space for the optimal 1528C *** encoding. IDYNFV contains the number of nybbles required. 1529C *** 1530 IBEDIM=0 1531 IF(MOD(IDYNFV,2).EQ.1) IBEDIM=1 1532 IBEDIM=IBEDIM+INT(IDYNFV/2) 1533C *** Add a test for Zero allocation... 1534 IF(IBEDIM.EQ.0) THEN 1535 CALL GRQUIT('ERROR. The specified allocation for ' 1536 2 //'Encoding the RUN-CODE is ZERO 1537 3 // for the BENCOD array in Routine GRTX02.') 1538 ENDIF 1539C 1540 IER = GRGMEM (IBEDIM*4,BENCOD) 1541 IF(IER.NE.SS_NORMAL) THEN 1542 CALL GRGMSG(IER) 1543 CALL GRQUIT('Failed to allocate a TeX PK Font BENCOD' 1544 2 //' ENCODEing array for RUN COUNT.') 1545 END IF 1546 IF(IDYNFO.EQ.14) THEN 1547 CALL GRWARN('PK ENCODE-ing the character using ' 1548 2 //'the optimal dyn_f=14 -- ') 1549 CALL GRWARN('which means ' 1550 2 //'''raw compressed bitmapping''...') 1551C *** We should encode using raw compressed bitmapping... 1552 CALL GRTX07(BITMAP,IBXDIM,IBYDIM,%VAL(BENCOD), 1553 2 IBEDIM,IXBXLL,IYBXLL,IXBXUR,IYBXUR) 1554 ELSE 1555C *** We should encode using the packed number encoding 1556C *** with the optimal value of dyn_f, IDYNFO. 1557 CALL GRWARN('PK ENCODE-ing the character using ' 1558 2 //'the optimal dyn_f value...') 1559 CALL GRTX08(%VAL(IRUNCD),IRCDIM,IDYNFO, 1560 2 %VAL(IRPEAT),IRPDIM, 1561 3 %VAL(BENCOD),IBEDIM) 1562 ENDIF 1563C *** 1564C *** ------------------------------------------------------------- 1565C *** Write out the current PK character. 1566 CALL GRWARN('Writing out the current PK character...') 1567 NC=CURCHA-1 1568 CALL GRTX09 (IBEDIM,BC,NC,XMAX,RESOLX,NDEV,DEVICE, 1569 2 IXBXLL,IXBXUR,IYBXLL,IYBXUR,IDYNFO, 1570 3 LIBLAK,NPKBYT,LUN,%VAL(BENCOD),HEIGHT, 1571 4 WIDTH,YMAX,RESOLY) 1572C *** ------------------------------------------------------------- 1573C *** Free the memory back up ... 1574C 1575 IER=GRFMEM (IBEDIM*4,BENCOD) 1576 IF(IER.NE.SS_NORMAL) THEN 1577 CALL GRGMSG(IER) 1578 CALL GRQUIT('FAILED TO DEALLOCATE BENCOD ARRAY MEMORY.') 1579 ENDIF 1580C 1581 IER=GRFMEM (IRPDIM*4,IRPEAT) 1582 IF(IER.NE.SS_NORMAL) THEN 1583 CALL GRGMSG(IER) 1584 CALL GRQUIT('FAILED TO DEALLOCATE IRPEAT ARRAY MEMORY.') 1585 ENDIF 1586C 1587 IER=GRFMEM (IRCDIM*4,IRUNCD) 1588 IF(IER.NE.SS_NORMAL) THEN 1589 CALL GRGMSG(IER) 1590 CALL GRQUIT('FAILED TO DEALLOCATE IRUNCD ARRAY MEMORY.') 1591 ENDIF 1592C *** 1593C----------------------------------------------------------------------- 1594 RETURN 1595 END 1596C<FF> 1597C *GRTX03 -- PGPLOT Close the current Font, and possibly start new one. 1598C 1599 SUBROUTINE GRTX03 (LUN,PKFILE,TFMFIL, 1600 2 CURCHA,PKOUT,RESOLX,RESOLY,XMAX, 1601 3 YMAX,NDEV,DEVICE,LNEWFL,NPKBYT, 1602 4 CHINFO,WIDTH,HEIGHT,BC) 1603C---------------------------------------------------------------------- 1604C *** 1605C *** 1606C *** If LNEWFL=.TRUE. then close the current PK Font and start a 1607C *** new one. IF LNEWFL=.FALSE. then just close the current PK Font 1608C *** file. In either case, write out the Postambles to PK file 1609C *** and to TFM file. IF LNEWFL=.TRUE., then we need to also call 1610C *** GRTX04 to write the Preamble to the new PK file. 1611C *** 1612C *** ------------------------------------------------------------------ 1613C----------------------------------------------------------------------- 1614 IMPLICIT NONE 1615 INTEGER LUN(2),I,J,NPKBYT,NC,CURCHA,PKOUT,NDEV 1616 INTEGER DEVICE,BC,ILENGT,IER 1617 INTEGER BYTOUT,CHINFO(BC:BC+14,4),WIDTH(0:15,4) 1618 INTEGER HEIGHT(0:15,4),JTMP1,JTMP2 1619 LOGICAL LNEWFL 1620 REAL RESOLX(NDEV),RESOLY(NDEV),XMAX,YMAX 1621 CHARACTER*(*) PKFILE,TFMFIL 1622 CHARACTER MSG*5,CHTMPS*80 1623C *** ----------------------------------------------------------- 1624C *** Write the postamble to PK file. 1625 CALL GRWARN('Writing out the postamble and for the ' 1626 2 //'PK file...') 1627C *** 1628C *** The opcode for the PK postamble is 245 base10. 1629 BYTOUT=245 1630 CALL GRTX11(LUN(1),BYTOUT) 1631 NPKBYT=NPKBYT+1 1632C *** Now we need enough no-operation codes to finish filling this block. 1633C *** So, we need to get to a multiple of 512. 1634C *** The preamble required 33 bytes. We have written NPKBYT bytes 1635C *** of character information thus far (includes the preamble 1636C *** and postamble opcode). The postamble requires 1 byte plus enough 1637C *** bytes to finish filling the 512 byte record block on a Vax. 1638C *** We need to have NPKBYT a multiple of 512 after we are finished. 1639C *** We will finish filling the block with no-op's (that is, no-operation 1640C *** opcodes). Note: All the PK format requires is a multiple of 4 (not 1641C *** 512). I chose 512 just to finish filling the current record and block 1642C *** on the Vax. 1643 DO 100, I= 1, 512 1644 IF(MOD(NPKBYT,512).EQ.0) GOTO 120 1645 NPKBYT=NPKBYT+1 1646 BYTOUT=246 1647 CALL GRTX11(LUN(1),BYTOUT) 1648100 CONTINUE 1649120 CONTINUE 1650C *** Now we are ready to close the PK file. 1651 CALL GRWARN('Closing the current PK file...') 1652C *** *VMS 1653 CLOSE(UNIT=LUN(1),ERR=130,DISP='KEEP') 1654C *** *UNIX 1655C *** CLOSE(UNIT=LUN(1),ERR=130) 1656C 1657 GOTO 140 1658C *** ---------- 1659130 CONTINUE 1660 CALL GRWARN('ERROR CLOSING PK FILE IN ROUTINE GRTX03') 1661 CALL GRQUIT('EXITING BACK TO OPERATING SYSTEM. GRTX03') 1662 STOP 1663C *** ------------------------------------------------------- 1664140 CONTINUE 1665C *** Write the whole TFM file. 1666C *** 1667C *** The number of character which have been stored in the PK Font 1668C *** is given by CURCHA-1. NC=0 is for the first character (ascii 1669C *** code BC. So, NC= (CURCHA-1) -1. 1670 NC=CURCHA-2 1671C *** Routine GRTX10 writes the TFM file. 1672 CALL GRWARN('Writing out the TeX Font Metric (TFM) ' 1673 2 //' file...') 1674 CALL GRTX10 (NC, LUN(2),CHINFO,WIDTH,HEIGHT,BC) 1675C *** Now we are ready to close the TFM file. 1676 CALL GRWARN('Closing the current TFM file...') 1677C 1678C *** *VMS 1679 CLOSE(UNIT=LUN(2),ERR=145,DISP='KEEP') 1680C *** *UNIX 1681C *** CLOSE(UNIT=LUN(2),ERR=145) 1682C 1683 GOTO 146 1684C *** ------------ 1685145 CONTINUE 1686 CALL GRWARN('ERROR CLOSING THE TFM FILE.') 1687 CALL GRQUIT('EXITING BACK TO OPERATING SYSTEM FROM GRTX03') 1688 STOP 1689C *** ------------ 1690146 CONTINUE 1691 DO 150, JTMP2=LEN(PKFILE),2,-1 1692 IF(PKFILE(JTMP2:JTMP2).NE.' ') GOTO 151 1693150 CONTINUE 1694151 CONTINUE 1695C *** PORTABILITY NOTE: Might want to use JTMP1=ICHAR('A')+CURCHA-1 1696C *** or something equivalent if on an EBCDIC machine... ? 1697C *** I think (but I'm not sure) that TeX, etcetera, use ASCII internally. 1698C *** I coded this as VaX specific. 1699 JTMP1=BC+CURCHA-2 1700C IF(ICHAR('A').NE.65) CALL GRWARN('Next message is not correct.' 1701C 2 //'it assumes that the ASCII value of A was 65base10.') 1702C --------------------------- 1703C *** *UNIX impossible string concatenation bug workaround. Also works 1704C *** under *VMS . 1705 CHTMPS=PKFILE 1706 CALL GRWARN('Finished the PK Font '''//CHTMPS(1:JTMP2) 1707 2 //''' with letter '''//CHAR(JTMP1)//''' . ') 1708C ------------------------- 1709C 1710C *** 1711C *** Now we need to check if we are to open a new PK Font. 1712 IF(LNEWFL.EQ..TRUE.) THEN 1713C *** We need to open a new PK Font. 1714C *** 1715C *** We need to determine the new file names for the next font 1716C *** because we are out of space on the current font. 1717 WRITE(UNIT=MSG,FMT='(I5)') PKOUT 1718C *** We will used J to keep track of the length of MSG for the 1719C *** two file names below. 1720 DO 200, J=5,1,-1 1721 IF(MSG(1:1).EQ.' ') THEN 1722 MSG(1:1)=MSG(2:2) 1723 MSG(2:2)=MSG(3:3) 1724 MSG(3:3)=MSG(4:4) 1725 MSG(4:4)=MSG(5:5) 1726 MSG(5:5)=' ' 1727 ELSE 1728 GOTO 201 1729 ENDIF 1730200 CONTINUE 1731201 CONTINUE 1732 1733C *** 1734 ILENGT=LEN(PKFILE) 1735 DO 400, I=ILENGT,1,-1 1736 IF(PKFILE(I:I).EQ.'.') GOTO 401 1737400 CONTINUE 1738401 CONTINUE 1739 IF(I.GT.0) THEN 1740 PKFILE=PKFILE(1:I-1)//'_'//MSG(1:J)//PKFILE(I:ILENGT) 1741 ELSE 1742 CALL GRWARN('PROGRAMMING ERROR IN PKFILE FILE NAME ' 1743 2 //'IN ROUTINE GRTX03. ERROR WAS MADE ' 1744 3 //'BY AUTHOR OF TXDRIVER ROUTINE.') 1745 CALL GRWARN('TRY ANOTHER NAME FOR YOUR FILE NAME.') 1746 CALL GRQUIT('EXITING BACK TO OPERATING SYSTEM FROM ' 1747 2 //'ROUTINE GRTX03.') 1748 STOP 1749 ENDIF 1750C *** 1751 ILENGT=LEN(TFMFIL) 1752 DO 600, I=ILENGT,1,-1 1753 IF(TFMFIL(I:I).EQ.'.') GOTO 601 1754600 CONTINUE 1755601 CONTINUE 1756 IF(I.GT.0)THEN 1757 TFMFIL=TFMFIL(1:I-1)//'_'//MSG(1:J)//TFMFIL(I:ILENGT) 1758 ELSE 1759 CALL GRWARN('PROGRAMMING ERROR IN TFMFILE FILE NAME ' 1760 2 //'IN ROUTINE GRTX03. ERROR WAS MADE ' 1761 3 //'BY AUTHOR OF TXDRIVER ROUTINE.') 1762 CALL GRWARN('TRY ANOTHER NAME FOR YOUR FILE NAME.') 1763 CALL GRQUIT('EXITING BACK TO OPERATING SYSTEM FROM ' 1764 2 //'ROUTINE GRTX03.') 1765 STOP 1766 ENDIF 1767C *** 1768C *** Finished with Variable J now. Can set it's value to 1769C *** anything. 1770C *** 1771C *** Open the PK file first. 1772 CALL GRWARN('Opening a new PK file...') 1773C *VMS We will write out 512 bytes at a time. RMS will take 1774C care of us when we read the file back in for DVIing it 1775C If you have problems, change ACCESS='DIRECT' to 1776C ACCESS='SEQUENTIAL' and add RECORDTYPE=FIXED and 1777C modify write statements in GRTX11 and GRTX12 to 1778C be writes to sequential files. Also, consider 1779C using the rewind statement if you use sequential files. 1780 OPEN(UNIT=LUN(1),FILE=PKFILE,ACCESS='DIRECT', 1781 2 FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IER, 1782 3 DISP='DELETE',RECL=128) 1783C 1784C *** *UNIX Want to open up a file to put "bytes on a disk -- 1785C *** with NO segmented record information... 512 bytes 1786C *** will be written out at a time. 128*4=512 1787C *** OPEN(UNIT=LUN(1),FILE=PKFILE,ACCESS='DIRECT', 1788C *** 2 FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IER, 1789C *** 3 RECL=128) 1790C Check for an error and cleanup if 1791C one occurred. 1792 IF (IER .NE. 0) THEN 1793 CALL GRWARN ('Cannot open output PK file for new ' 1794 1 //'TeX PK Font.') 1795 CALL GRQUIT('Failed to open next Tex PK file.') 1796 ENDIF 1797C 1798C *** Initialize some indirect 1799C *** file pointer information. 1800 CALL GRTX14 1801C *** 1802C *** Open the TFM file second. 1803 CALL GRWARN('Opening a new TFM file...') 1804C *VMS We will write out 512 bytes at a time. RMS will take 1805C care of us when we read the file back in for DVIing it 1806C If you have problems, change ACCESS='DIRECT' to 1807C ACCESS='SEQUENTIAL' and add RECORDTYPE=FIXED and 1808C modify write statements in GRTX11 and GRTX12 to 1809C be writes to sequential files. Also, consider using 1810C the rewind statement if you use sequential files. 1811 OPEN(UNIT=LUN(2),FILE=TFMFIL,ACCESS='DIRECT', 1812 2 FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IER, 1813 3 DISP='DELETE',RECL=128) 1814C 1815C *** *UNIX Want to open up a file to put "bytes on a disk -- 1816C *** with NO segmented record information... 512 bytes 1817C *** will be written out at a time. 128*4=512 1818C *** OPEN(UNIT=LUN(2),FILE=TFMFIL,ACCESS='DIRECT', 1819C *** 2 FORM='UNFORMATTED',STATUS='NEW',IOSTAT=IER, 1820C *** 3 RECL=128) 1821C Check for an error and cleanup if 1822C one occurred. 1823 IF (IER .NE. 0) THEN 1824 CALL GRWARN ('Cannot open output TFM file for new ' 1825 1 //'TeX PK Font.') 1826 CALL GRQUIT('Failed to open next Tex TFM file.') 1827 ENDIF 1828C *** Initialize some indirect 1829C *** file pointer information. 1830 CALL GRTX15 1831C *** 1832C *** 1833C 1834C *** 1835C *** We need to write the preamble to the PK file. 1836 CALL GRTX04 (RESOLX,RESOLY,NDEV,DEVICE,LUN,NPKBYT) 1837 ENDIF 1838C *** Finished. We can return now. 1839C----------------------------------------------------------------------- 1840 RETURN 1841 END 1842C<FF> 1843C *GRTX04 -- PGPLOT Write the preamble for PK file. 1844C 1845 SUBROUTINE GRTX04 (RESOLX,RESOLY,NDEV,DEVICE, 1846 2 LUN,NPKBYT) 1847C----------------------------------------------------------------------- 1848C *** GRTX04 1849 IMPLICIT NONE 1850 INTEGER BYTOUT 1851 INTEGER VM1,VM2,VM3,VM4,VP0,VP1,VP2,VP3,NPKBYT 1852 INTEGER LUN(2),NDEV,DEVICE 1853 REAL RVPPP,RHPPP,RESOLX(NDEV),RESOLY(NDEV) 1854 DOUBLE PRECISION VALUE 1855C *** Write the preamble opcode. 1856 BYTOUT=247 1857 CALL GRTX11(LUN(1),BYTOUT) 1858C *** Write out the identification byte of the file. 1859 BYTOUT=89 1860 CALL GRTX11(LUN(1),BYTOUT) 1861C *** Write out the comment of where this file came from. 1862C *** The string will be "PGPLOT PK Font",which has ASCII Hex values of 1863C *** "P"=50,"G"=47,"P"=50,"L"=4C,"O"=4F,"T"=54," "=20, 1864C *** "P"=50,"K"=4B," "=20,"F"=46,"o"=6f,"n"=6E,"t"=74 1865C *** This requires 14 bytes. 1866 BYTOUT=14 1867 CALL GRTX11(LUN(1),BYTOUT) 1868C *** Now the string... 1869 BYTOUT = 5*16 + 0 1870 CALL GRTX11(LUN(1),BYTOUT) 1871 BYTOUT = 4*16 + 7 1872 CALL GRTX11(LUN(1),BYTOUT) 1873 BYTOUT = 5*16 + 0 1874 CALL GRTX11(LUN(1),BYTOUT) 1875 BYTOUT = 4*16 + 12 1876 CALL GRTX11(LUN(1),BYTOUT) 1877 BYTOUT = 4*16 + 15 1878 CALL GRTX11(LUN(1),BYTOUT) 1879 BYTOUT = 5*16 + 4 1880 CALL GRTX11(LUN(1),BYTOUT) 1881 BYTOUT = 2*16 + 0 1882 CALL GRTX11(LUN(1),BYTOUT) 1883 BYTOUT = 5*16 + 0 1884 CALL GRTX11(LUN(1),BYTOUT) 1885 BYTOUT = 4*16 + 11 1886 CALL GRTX11(LUN(1),BYTOUT) 1887 BYTOUT = 2*16 + 0 1888 CALL GRTX11(LUN(1),BYTOUT) 1889 BYTOUT = 4*16 + 6 1890 CALL GRTX11(LUN(1),BYTOUT) 1891 BYTOUT = 6*16 + 15 1892 CALL GRTX11(LUN(1),BYTOUT) 1893 BYTOUT = 6*16 + 14 1894 CALL GRTX11(LUN(1),BYTOUT) 1895 BYTOUT = 7*16 + 4 1896 CALL GRTX11(LUN(1),BYTOUT) 1897C *** 1898C *** 1899C *** Now write out the design size of the file in 1/20 points (a Fix_word). 1900C *** This is to be in 4 bytes. The implied decimal is between byte 1901C *** 19 and 20 (0 is the first byte). This is encoded as coefficients 1902C *** of the power of 16. See PKtoPX.Web, or other WEB files for 1903C *** the documentation of this. 1904C *** The design size is 100.0 Tex Points, which is 06400000 as a Fix_word, 1905C *** 100.0base10=6*16+4 base10=64.0base16 =06400000 Fix_word. 100.0 TeX 1906C *** points is approximately 1.3837 inches. (This will allow output 1907C *** characters from 0.0864813 inches to 22.1382 inches in size.) 1908C *** This value should be changed if a different range is desired. 1909 BYTOUT=6 1910 CALL GRTX11(LUN(1),BYTOUT) 1911 BYTOUT=4*16 1912 CALL GRTX11(LUN(1),BYTOUT) 1913 BYTOUT=0 1914 CALL GRTX11(LUN(1),BYTOUT) 1915 BYTOUT=0 1916 CALL GRTX11(LUN(1),BYTOUT) 1917C *** 1918C *** Now, write out the 4 byte checksum, which must be the same in the 1919C *** TFM file and the PK file. I chose my birthdate 09 28 1963 as the 1920C *** Hex value. 1921 BYTOUT = 0*16 + 9 1922 CALL GRTX11(LUN(1),BYTOUT) 1923 BYTOUT = 2*16 + 8 1924 CALL GRTX11(LUN(1),BYTOUT) 1925 BYTOUT = 1*16 + 9 1926 CALL GRTX11(LUN(1),BYTOUT) 1927 BYTOUT = 6*16 + 3 1928 CALL GRTX11(LUN(1),BYTOUT) 1929C *** 1930C *** Now, write out the 4 byte horizontal ratio of pixels per TeX point, 1931C *** (this is a measure of the dots per inch). The variable RESOLX(DEVICE) 1932C *** contains the dots per inch value. There are horizontally: 1933C *** RESOLX(DEVICE) {pixels/inch}, 2.54 {cm./inch}, 1934C *** 7227.0/254.0 {TeX points/cm.}. So the base10 value of pixels/TeX point is: 1935 RHPPP=RESOLX(DEVICE)/2.54*254.0/7227 1936C *** Now, I must convert this into its base 16 value to place the value 1937C *** multiplied by 2**16 into the 4 bytes. 1938 VALUE=RHPPP 1939 VP3=INT(VALUE/(16.0**3)) 1940 VALUE=VALUE-VP3*16.0**3 1941 VP2=INT(VALUE/(16.0**2)) 1942 VALUE=VALUE-VP2*16.0**2 1943 VP1=INT(VALUE/(16.0**1)) 1944 VALUE=VALUE-VP1*16.0**1 1945 VP0=INT(VALUE) 1946 VALUE=VALUE-VP0 1947 VM1=INT(VALUE/(16.0**(-1))) 1948 VALUE=VALUE-VM1*16.0**(-1) 1949 VM2=INT(VALUE/(16.0**(-2))) 1950 VALUE=VALUE-VM2*16.0**(-2) 1951 VM3=INT(VALUE/(16.0**(-3))) 1952 VALUE=VALUE-VM3*16.0**(-3) 1953 VM4=INT(VALUE/(16.0**(-4))) 1954C *** 1955 BYTOUT = VP3*16 + VP2 1956 CALL GRTX11(LUN(1),BYTOUT) 1957 BYTOUT = VP1*16 + VP0 1958 CALL GRTX11(LUN(1),BYTOUT) 1959 BYTOUT = VM1*16 + VM2 1960 CALL GRTX11(LUN(1),BYTOUT) 1961 BYTOUT = VM3*16 + VM4 1962 CALL GRTX11(LUN(1),BYTOUT) 1963C *** 1964C *** Now, write out the 4 byte vertical ratio of pixels per TeX point, 1965C *** (this is a measure of the dots per inch). The variable RESOLY(DEVICE) 1966C *** contains the dots per inch value. There are vertically: 1967C *** RESOLY(DEVICE) {pixels/inch}, 2.54 {cm./inch}, 1968C *** 7227.0/254.0 {TeX points/cm.}. So the base10 value of pixels/TeX point is: 1969 RVPPP=RESOLY(DEVICE)/2.54*254.0/7227 1970C *** Now, I must convert this into its base 16 value to place the value 1971C *** multiplied by 2**16 into the 4 bytes. 1972 VALUE=RVPPP 1973 VP3=INT(VALUE/(16.0**3)) 1974 VALUE=VALUE-VP3*16.0**3 1975 VP2=INT(VALUE/(16.0**2)) 1976 VALUE=VALUE-VP2*16.0**2 1977 VP1=INT(VALUE/(16.0**1)) 1978 VALUE=VALUE-VP1*16.0**1 1979 VP0=INT(VALUE) 1980 VALUE=VALUE-VP0 1981 VM1=INT(VALUE/(16.0**(-1))) 1982 VALUE=VALUE-VM1*16.0**(-1) 1983 VM2=INT(VALUE/(16.0**(-2))) 1984 VALUE=VALUE-VM2*16.0**(-2) 1985 VM3=INT(VALUE/(16.0**(-3))) 1986 VALUE=VALUE-VM3*16.0**(-3) 1987 VM4=INT(VALUE/(16.0**(-4))) 1988C *** 1989 BYTOUT = VP3*16 + VP2 1990 CALL GRTX11(LUN(1),BYTOUT) 1991 BYTOUT = VP1*16 + VP0 1992 CALL GRTX11(LUN(1),BYTOUT) 1993 BYTOUT = VM1*16 + VM2 1994 CALL GRTX11(LUN(1),BYTOUT) 1995 BYTOUT = VM3*16 + VM4 1996 CALL GRTX11(LUN(1),BYTOUT) 1997C *** 1998C *** There were 33 bytes written to the Preamble for the PK Font. 1999 NPKBYT=33 2000C *** 2001C *** And that finishes the Preamble for the PK font. 2002C----------------------------------------------------------------------- 2003 RETURN 2004 END 2005C<FF> 2006C *GRTX05 -- PGPLOT Calculate RUN CODE count for PK Font character. 2007C 2008 SUBROUTINE GRTX05( BITMAP, IBXDIM, IBYDIM, 2009 2 IRUNCD, IRCDIM, IRPEAT, 2010 3 IRPDIM, LIBLAK, IXBXLL, 2011 4 IYBXLL, IXBXUR, IYBXUR, 2012 5 LTX05E,IRCIND,IRPIND) 2013C----------------------------------------------------------------------- 2014C *** 2015C *** -------------------------------------------------------------- 2016C *** This routine is used to produce RUN CODE for the character 2017C *** contained in the 2-dimensional byte array BITMAP. 2018C *** The algorithm is described in PKtoPX.WEB. The PK Font format 2019C *** was written by Tomas Rokicki in August of 1985. Rokicki was a 2020C *** former Texas A&M student. TeX uses this PK font 2021C *** format for technical typesetting. To get the documentation, 2022C *** WEAVE the PKTOPX.WEB file. TeX the resulting PKTOPX.TEX file. 2023C *** Then run the DVI translator to produce the binary file for 2024C *** printing out to your desired printer. 2025C *** 2026C *** BITMAP is a BYTE input array of size IBXDIM x IBYDIM. 2027C *** IRUNCD is an integer output array of size IRCDIM which will 2028C *** contain the RUN CODE for the character. 2029C *** IRPEAT is an integer output array of size IRPDIM which is used 2030C *** to index the Repeat Counts within the IRUNCD array. 2031C *** The logical variable LTX05E is used to indicate whether this is 2032C *** the first or second invokation of the routine GRTX05. 2033C *** The first invokation calculates the minimum bounding box of the 2034C *** graphics character. 2035C *** IRCIND and IRPEAT are used in the first invokation of routine GRTX05 2036C *** to return the dimensions of IRUNCD and IRPEAT needed to 2037C *** store the RUN CODE counts. 2038C *** On the second invokation of routine GRTX05, IRCIND and IRPIND are 2039C *** just used for indexing into the IRUNCD and IRPEAT arrays for 2040C *** storing RUN CODE information. 2041C *** 2042C *** 2043C *** --------------------------------------------------------------- 2044C *** 2045 IMPLICIT NONE 2046 INTEGER IBXDIM,IBYDIM,IRCDIM,IRPDIM, 2047 2 IRUNCD(IRCDIM), IRPEAT(IRPDIM), IRCIND, IRPIND, 2048 3 ICOL, IROW, ITMPRO, ITMPCO, IRPCNT, IRCSUM, 2049 4 IXBXLL, IYBXLL, IXBXUR, IYBXUR, I, J, K 2050 INTEGER WHITE,IPERCR,IPERCL,IXBBLL,IXBBUR 2051 BYTE BITMAP(0:IBXDIM-1,0:IBYDIM-1),SOLBLK,SOLWHT 2052 LOGICAL LSOLID,LBLACK,LIBLAK,LTX05E 2053 CHARACTER*3 MSG 2054C *** PORTABILITY NOTES: 2055C *** Note: {Vax byte variables are from -128 to 127. 2056C *** ??Parameter statement might need to be modified for SOLBLK=255 2057C *** base10=FFbase16. 2058C *** Assumption is that SOLBLK will be converted correctly by the compiler 2059C *** to the signed quantity on the vax. I definitely want the 2060C *** result to be all ones in the bit positions. The parameter SOLWHT 2061C *** is to have all zeros in the bit positions.} 2062C *** PARAMETER (WHITE=0, SOLBLK='FF'X,SOLWHT='00'X) 2063 WHITE=0 2064 SOLBLK='FF'X 2065 SOLWHT='00'X 2066C *** 2067C *** 2068C *** IRCIND is an integer used as an index into the IRUNCD array. 2069C *** IRPIND is an integer used as an index into the IRPEAT array. 2070C *** ICOL is an integer used to keep up with the current X (column) position 2071C *** within the BITMAP array. 2072C *** IROW is an integer used to keep up with the current Y (row) position 2073C *** within the BITMAP array. 2074C *** ITMPRO is an integer used to keep up with the temporary X (column) 2075C *** position within the BITMAP array. 2076C *** ITMPCO is an integer used to keep up with the temporary Y (row) 2077C *** position within the BITMAP array. 2078C *** IRPCNT is an integer used to keep up with the Repeat Count of the 2079C *** consecutive rows within the BITMAP array (that is, identical 2080C *** consecutive rows). 2081C *** IRCSUM is an integer used to keep up a running sum of the number of 2082C *** consecutive pixels which are of the same color 2083C *** (only black and white colors are allowed --- no shades). 2084C *** IXBXLL is an integer used to contain the Lower Left X coordinate 2085C *** of the minimum bounding box of the character (so that all black 2086C *** pixels are just contained within the box). 2087C *** IYBXLL is an integer used to contain the Lower Left Y coordinate 2088C *** of the minimum bounding box of the character (so that all black 2089C *** pixels are just contained within the box). 2090C *** IXBXUR is an integer used to contain the Upper Right X coordinate 2091C *** of the minimum bounding box of the character (so that all black 2092C *** pixels are just contained within the box). 2093C *** IYBXUR is an integer used to contain the Upper Right Y coordinate 2094C *** of the minimum bounding box of the character (so that all black 2095C *** pixels are just contained within the box). 2096C *** I,J, K are temporary variables used for counting and DO Loop indices. 2097C *** LSOLID is a logical variable used to denote that the row in 2098C *** question is a Solid color (either solid white, or solid black). 2099C *** I used LSOLID as an aid in debugging. It is not very useful otherwise. 2100C *** LBLACK is a logical variable used to contain the current pixel color 2101C *** (.TRUE. represents black, while .FALSE. represents white). 2102C *** LIBLAK is a logical variable used to contain the first pixel color 2103C *** of the miniumum bounded box, which is needed later in an upper routine. 2104C *** 2105C *** --------------------------------------------------------------- 2106C *** --------------------------------------------------------------- 2107C *** 2108C *** 2109C *** 2110C *** 2111C *** 2112C *** 2113 IF(LTX05E.EQ..FALSE.) THEN 2114 CALL GRWARN('There will be 3 passes (scans) over the ' 2115 2 //'graphics character...') 2116C *** Find the minimum bounding box for the character. 2117C *** PGPLOT assumes that lower left corner of character is (0,0). 2118C *** IXBXLL,IXBXUR,IYBXLL,IYBXUR are in PGPLOT coordinates 2119C *** in which (0,0) is lower left. 2120 CALL GRWARN('Starting scan number 1 --- Finding the minimal ' 2121 2 //'bounding box around the graphics character.') 2122C *** Initialize the last written percentage of the image remaining to be 2123C *** scanned to be 100%. 2124 IPERCL=100 2125C *** Set up initial bounds for box to be outisde the bitmap area... 2126C *** loop below will override these. 2127 IXBBUR=-1 2128 IXBXUR=-1 2129 IYBXUR=-1 2130 IXBBLL=(IBXDIM-1) + 1 2131 IXBXLL=(IBXDIM*8-1) + 1 2132 IYBXLL=(IBYDIM-1) + 1 2133 CALL GRWARN('Percentage of image scan remaining:') 2134 CALL GRWARN(' 100% scan remaining ') 2135 DO 100, J=IBYDIM-1,0,-1 2136 DO 90, I=0, IBXDIM-1 2137C *** Write out a message about what percentage of the image remains 2138C *** to be processed. 2139 IPERCR=INT(FLOAT(J)/FLOAT(IBYDIM-1)*100.0) 2140 IF (IPERCR.LT.(IPERCL-15)) THEN 2141 IPERCL=IPERCR 2142 WRITE(UNIT=MSG,FMT='(I3)') IPERCL 2143 CALL GRWARN(' '//MSG(1:3)//'% scan remaining ') 2144 ENDIF 2145C *** 2146C *** 2147 IF(BITMAP(I,J).NE.SOLWHT) THEN 2148C *** We have a black pixel somewhere in that byte. 2149 IF(I.LE.IXBBLL) THEN 2150 IXBBLL = I 2151 DO 50, K= IXBBLL*8,IXBBLL*8+7 2152 IF(((BITMAP(K/8,J).AND.2**(7-MOD(K,8))).NE.WHITE) 2153 2 .AND.(K.LE.IXBXLL)) IXBXLL=K 215450 CONTINUE 2155 ENDIF 2156 IF(I.GE.IXBBUR) THEN 2157 IXBBUR = I 2158 DO 80, K=IXBBUR*8,IXBBUR*8+7 2159 IF(((BITMAP(K/8,J).AND.2**(7-MOD(K,8))).NE.WHITE) 2160 2 .AND.(K.GE.IXBXUR)) IXBXUR=K 216180 CONTINUE 2162 ENDIF 2163 IF(J.LE.IYBXLL) IYBXLL = J 2164 IF(J.GE.IYBXUR) IYBXUR = J 2165 ENDIF 216690 CONTINUE 2167100 CONTINUE 2168C *** 2169C *** Minimum bounding box has been found to be Lower_Left=(IXBXLL,IYBXLL) 2170C *** Upper_Right=(IXBXUR,IYBXUR). So, 0<=IXBXLL<=IXBXUR<=(IBXDIM-1)*8 2171C *** and 0<=IYBXLL<=IYBXUR<=(IBYDIM-1). 2172C *** 2173C *** Add error checking... 2174 IF(IXBXUR.EQ.-1) CALL GRQUIT('ERROR FINDING MINIMAL BOUNDING' 2175 2 //'BOX AROUND CHARACHTER. THE IMAGE WAS OF SOLID' 2176 3 //'COLOR WHITE. ROUTINE GRTX05.') 2177 IF(IYBXUR.EQ.-1) CALL GRQUIT('ERROR FINDING MINIMAL BOUNDING' 2178 2 //'BOX AROUND CHARACHTER. THE IMAGE WAS OF SOLID' 2179 3 //'COLOR WHITE. ROUTINE GRTX05.') 2180 IF(IXBXLL.EQ.(IBXDIM*8-1) + 1) CALL GRQUIT('ERROR FINDING ' 2181 2 //'MINIMAL BOUNDING BOX AROUND CHARACHTER. ' 2182 3 //'THE IMAGE WAS OF SOLID COLOR WHITE. ' 2183 4 //'ROUTINE GRTX05.') 2184 IF(IYBXLL.EQ.(IBYDIM-1) + 1) CALL GRQUIT('ERROR FINDING ' 2185 2 //'MINIMAL BOUNDING BOX AROUND CHARACHTER. ' 2186 3 //'THE IMAGE WAS OF SOLID COLOR WHITE. ' 2187 4 //'ROUTINE GRTX05.') 2188 IF(IXBXLL.GT.IXBXUR) CALL GRQUIT('ERROR IN MINIMAL BOUNDING ' 2189 2 //'BOX CALCULATIONS. Lower row bounds exceeds ' 2190 3 //'upper row bounds. Routine GRTX05.') 2191 IF(IYBXLL.GT.IYBXUR) CALL GRQUIT('ERROR IN MINIMAL BOUNDING ' 2192 2 //'BOX CALCULATIONS. Lower column bounds exceeds ' 2193 3 //'upper column bounds. Routine GRTX05.') 2194 IF(IXBXLL.EQ.IXBXUR) CALL GRWARN('Lower bounds = Upper bounds ' 2195 2 //'for minimal bounding box of character. ' 2196 3 //' Routine GRTX05.') 2197 IF(IYBXLL.EQ.IYBXUR) CALL GRWARN('Lower bounds = Upper bounds ' 2198 2 //'for minimal bounding box of character. ' 2199 3 //' Routine GRTX05.') 2200 ENDIF 2201C *** ------------------------------------------------------------------ 2202C *** ------------------------------------------------------------------ 2203C *** 2204 IF(LTX05E.EQ..FALSE.) THEN 2205 CALL GRWARN ('Minimal bounding box completed.') 2206 CALL GRWARN ('Starting scan number 2 -- determining ' 2207 2 //'the amount of virtual memory needed for ' 2208 3 //'RUN CODING the graphics character.') 2209 ELSE 2210 CALL GRWARN ('Starting scan number 3 -- calculating ' 2211 2 //'and storing RUN CODE counts for later encoding.') 2212C *** Initialize the first repeat count index to be zero in case there 2213C *** are not repeated non-solid rows in the graphics character. 2214C *** Note: IRPEAT must be dimensioned at least 1 in the calling routine. 2215 IRPEAT(1)=0 2216 ENDIF 2217C *** 2218C *** Set up the arrays to be indexed into their first element 2219 IRCIND=1 2220 IRPIND=1 2221C *** Set up the current position as the Upper Left corner of the 2222C *** minimum bounding box. 2223 ICOL=IXBXLL 2224 IROW=IYBXUR 2225C *** Set up the temporary position as the current position. 2226 ITMPRO=IROW 2227 ITMPCO=ICOL 2228C *** Initialize the Repeat count as 0 and the Run Code sum as 0. 2229 IRPCNT=0 2230 IRCSUM=0 2231C *** Set up the logical variables as all .FALSE. 2232 LSOLID=.FALSE. 2233 LBLACK=.FALSE. 2234 LIBLAK=.FALSE. 2235C *** Initialize the last written percentage of the image remaining to be 2236C *** scanned to be 100%. 2237 IPERCL=100 2238C *** 2239C *** 2240C *** ----------------------------------------------------------------- 2241C *** 2242C *** Determine what the color the initial pixel value is. 2243 IF((BITMAP(ICOL/8,IROW).AND.2**(7-MOD(ICOL,8))).NE.WHITE)THEN 2244 LBLACK=.TRUE. 2245 LIBLAK=.TRUE. 2246 ELSE 2247 LBLACK=.FALSE. 2248 LIBLAK=.FALSE. 2249 ENDIF 2250 CALL GRWARN('Percentage of image scan remaining:') 2251 CALL GRWARN(' 100% remaining ') 2252C *** 2253C *** 2254C *** ------------------------------------------------------------------ 2255C *** BEGINNING_OF_ROW: 2256C *** 22572000 CONTINUE 2258C *** 2259C *** 2260C *** 2261C *** Write out a message about what percentage of the image remains 2262C *** to be processed. 2263 IPERCR=INT(FLOAT(IROW-IYBXLL+1)/FLOAT(IYBXUR-IYBXLL+1)*100.0) 2264 IF (IPERCR.LT.(IPERCL-15)) THEN 2265 IPERCL=IPERCR 2266 WRITE(UNIT=MSG,FMT='(I3)') IPERCL 2267 CALL GRWARN(' '//MSG(1:3)//'% remaining ') 2268 ENDIF 2269C *** 2270C *** 2271C *** Let us check and see if the row is a solid of the current color. 2272C *** We will check the "leftover" bits on the left and right of the 2273C *** character first, then if they pass, we will check the bytes in between. 2274C *** Initialize LSOLID=.FALSE. so that "jump_out" to label 6000 will 2275C *** be correct if we do not have a solid row. 2276 LSOLID=.FALSE. 2277 ITMPRO=IROW 2278 ITMPCO=IXBXLL-1 22792200 ITMPCO=ITMPCO+1 2280C *** If we are on an a byte boundary, we have finished checking the 2281C *** left "leftover" bits. Go check the right "leftover" bits. 2282 IF(MOD(ITMPCO,8).EQ.0) GOTO 2210 2283C *** See if the current pixel is the correct color for solid color row. 2284 IF(LBLACK.EQ..TRUE.) THEN 2285 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2286 2 .NE.WHITE) THEN 2287 GOTO 2200 2288 ELSE 2289 GOTO 6000 2290 ENDIF 2291 ELSE 2292 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2293 2 .EQ.WHITE) THEN 2294 GOTO 2200 2295 ELSE 2296 GOTO 6000 2297 ENDIF 2298 ENDIF 2299C *** 2300C *** 2301C *** 23022210 CONTINUE 2303C *** 2304C *** Checking the right "leftover" bits now for solid color row. 2305 J=IROW 2306 I=IXBXUR+1 23072220 I=I-1 2308C *** If we are on an a byte boundary, we have finished checking the 2309C *** right "leftover" bits. Go check the bytes in between. 2310 IF(MOD(I,8).EQ.7) GOTO 2240 2311C *** See if the current pixel is the correct color for solid color row. 2312 IF(LBLACK.EQ..TRUE.) THEN 2313 IF((BITMAP(I/8,J).AND.2**(7-MOD(I,8))) 2314 2 .NE.WHITE) THEN 2315 GOTO 2220 2316 ELSE 2317 GOTO 6000 2318 ENDIF 2319 ELSE 2320 IF((BITMAP(I/8,J).AND.2**(7-MOD(I,8))) 2321 2 .EQ.WHITE) THEN 2322 GOTO 2220 2323 ELSE 2324 GOTO 6000 2325 ENDIF 2326 ENDIF 2327C *** 2328C *** 2329C *** 2330C *** 2331C *** 23322240 CONTINUE 2333C *** 2334C *** Both the left and right "leftover" bits checked out to be solid 2335C *** color of the current color type. Now need to check the 2336C *** bytes in between to see if they are also solid color of the 2337C *** current type. 2338 DO 2250, K=ITMPCO,I,8 2339 IF(LBLACK.EQ..TRUE.) THEN 2340 IF(BITMAP(K/8,J).NE.SOLBLK) GOTO 6000 2341 ELSE 2342 IF(BITMAP(K/8,J).NE.SOLWHT) GOTO 6000 2343 ENDIF 23442250 CONTINUE 2345C *** 2346C *** We have a row which is of solid color. 2347 LSOLID=.TRUE. 2348C *** 2349C *** 2350C *** 2351C *** 2352C *** 2353C *** --------------------------------------------------------------- 2354C *** 2355C *** 2356C *** Calculate the # of consecutive rows which are repeats of the current 2357C *** row. Set IRPCNT=#repeated_consecutive_rows. 2358C *** 2359 IRPCNT=0 23602400 J=IROW-IRPCNT-1 2361C *** Need to make sure that we do not go out of the bounding box. 2362 IF(J.LT.IYBXLL) GOTO 8000 2363C *** Do a loop comparing the bytes across two rows. Since the bits 2364C *** outside of the minimum bounding box are white (0), we do not 2365C *** have to worry about them -- they will compare okay. 2366C *** There are 8 bits to a byte, so there are 8 pixels to a byte. 2367C *** We can step by 8 pixels to do our check. 2368 DO 2420, I=IXBXLL, IXBXUR, 8 2369 IF(BITMAP(I/8,IROW).NE.BITMAP(I/8,J)) GOTO 2450 23702420 CONTINUE 2371C *** We have found another repeated consecutive row. 2372 IRPCNT=IRPCNT+1 2373C *** Go back and check if the next row down is also a repeated row. 2374 GOTO 2400 2375C *** 2376C *** 2377C *** 2378C *** 23792450 CONTINUE 2380C *** We have found all of the consecutive repeated rows. 2381C *** 2382C *** ------------------------------------------------------------------ 2383C *** 2384C *** Need to determine whether a transition occurs at the first 2385C *** pixel of the first non-repeated solid row. 2386 ITMPRO=IROW-IRPCNT-1 2387 ITMPCO=IXBXLL 2388 IF(LBLACK.EQ..TRUE.) THEN 2389 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2390 2 .NE.WHITE) GOTO 2800 2391 ELSE 2392 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2393 2 .EQ.WHITE) GOTO 2800 2394 ENDIF 2395C *** 2396C *** ---------------------------------------------------------------- 2397C *** 23982500 CONTINUE 2399C *** 2400C *** 2401C *** We now have a solid (possibly repeated) row for which the 2402C *** first non-solid row has a transition at the first pixel of 2403C *** the minimum bounded box. 2404C *** 2405C *** Get the sum of the solid row pixels including the repeated solid 2406C *** row pixels. 2407 IRCSUM=IRCSUM+(IXBXUR-IXBXLL+1)*(1+IRPCNT) 2408C *** 2409C *** Store this sum for later Encoding. 2410 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 2411 IRCIND=IRCIND+1 2412C *** 2413C *** Update the current position. 2414 IROW=IROW-IRPCNT-1 2415 ICOL=IXBXLL 2416C *** 2417C *** Change current color. 2418 LBLACK=.NOT.LBLACK 2419C *** 2420C *** Reset the counters. 2421 IRCSUM=0 2422 IRPCNT=0 2423C *** 2424C *** We are now at the beginning of a new row. GOTO BEGINING_OF_ROW. 2425 GOTO 2000 2426C *** 2427C *** ----------------------------------------------------------------- 2428C *** 24292800 CONTINUE 2430C *** 2431C *** 2432C *** We have a solid (possibly with repeat solid rows), which 2433C *** does not have a transition at the first non-solid row 2434C *** first pixel of the minimum bounding box. 2435C *** 2436C *** Get the sum of the pixels for the solid and solid repeated rows. 2437 IRCSUM=IRCSUM+(IXBXUR-IXBXLL+1)*(1+IRPCNT) 2438C *** 2439C *** Update the position to the beginning of the first non-solid row. 2440 IROW=IROW-IRPCNT-1 2441 ICOL=IXBXLL 2442C *** Find the transition point, (ITMPRO,ITMPCO). 2443 ITMPRO=IROW 2444 DO 2810, ITMPCO=IXBXLL+1,IXBXUR 2445 IF(LBLACK.EQ..TRUE.) THEN 2446 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2447 2 .EQ.WHITE) GOTO 2820 2448 ELSE 2449 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2450 2 .NE.WHITE) GOTO 2820 2451 ENDIF 24522810 CONTINUE 2453C *** 24542820 CONTINUE 2455C *** We now have ITMPRO, ITMPCO where the transition occurs. 2456C *** Add the number of pixels on the current row until the transition 2457C *** occurs to the previous calculated value for the solid (possibly 2458C *** repeated) rows. 2459 IRCSUM=IRCSUM+(ITMPCO-ICOL) 2460C *** Store this run code sum. 2461 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 2462 IRCIND=IRCIND+1 2463C *** Update the current position to be the point of transition. 2464 IROW=ITMPRO 2465 ICOL=ITMPCO 2466C *** Change the current color. 2467 LBLACK=.NOT.LBLACK 2468C *** Reset the counters. 2469 IRPCNT=0 2470 IRCSUM=0 2471C *** 2472C *** 2473C *** -------------------------------------------------------------- 2474C *** 24753000 CONTINUE 2476C *** 2477C *** MIDDLE_REPEAT: 2478C *** 2479C *** We are now in the middle of a new row. There may or may not 2480C *** be repeated consecutive rows below the current one. 2481C *** Also, the remaining part of the current row may be solid. 2482C *** 2483C *** --------------------------------------------------------------- 2484C *** 2485C *** Write out a message about what percentage of the image remains 2486C *** to be processed. 2487 IPERCR=INT(FLOAT(IROW-IYBXLL+1)/FLOAT(IYBXUR-IYBXLL+1)*100.0) 2488 IF (IPERCR.LT.(IPERCL-15)) THEN 2489 IPERCL=IPERCR 2490 WRITE(UNIT=MSG,FMT='(I3)') IPERCL 2491 CALL GRWARN(' '//MSG(1:3)//'% remaining ') 2492 ENDIF 2493C *** 2494C *** 2495C *** --------------------------------------------------------------- 2496C *** 2497C *** Calculate the # of consecutive rows which are repeats of the current 2498C *** row. Set IRPCNT=#repeated_consecutive_rows. 2499C *** 2500 IRPCNT=0 25013100 J=IROW-IRPCNT-1 2502C *** Need to make sure that we do not go out of the bounding box. 2503 IF(J.LT.IYBXLL) GOTO 3200 2504C *** Do a loop comparing the bytes across two rows. Since the bits 2505C *** outside of the minimum bounding box are white (0), we do not 2506C *** have to worry about them -- they will compare okay. 2507C *** There are 8 bits to a byte, so there are 8 pixels to a byte. 2508C *** We can step by 8 pixels to do our check. 2509 DO 3120, I=IXBXLL, IXBXUR, 8 2510 IF(BITMAP(I/8,IROW).NE.BITMAP(I/8,J)) GOTO 3150 25113120 CONTINUE 2512C *** We have found another repeated consecutive row. 2513 IRPCNT=IRPCNT+1 2514C *** Go back and check if the next row down is also a repeated row. 2515 GOTO 3100 2516C *** 2517C *** 2518C *** 2519C *** 25203150 CONTINUE 2521C *** We have found all of the consecutive repeated rows. 2522C *** 2523C *** ------------------------------------------------------------------ 2524C *** 25253200 CONTINUE 2526C *** 2527 IF(IRPCNT.GT.0) THEN 2528C *** Store the repeat count for later Encoding. 2529 IF(LTX05E.EQ..TRUE.) IRPEAT(IRPIND)=IRCIND 2530 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRPCNT 2531 IRPIND=IRPIND+1 2532 IRCIND=IRCIND+1 2533C *** Update the current position to be the the row of the last 2534C *** repeat count, and remain in the same column. 2535 IROW=IROW-IRPCNT 2536 ENDIF 2537C *** 2538C *** 2539C *** -------------------------------------------------------------------- 2540C *** 25414000 CONTINUE 2542C *** 2543C *** MIDDLE_NO_REPEAT: 2544C *** 2545C *** 2546C *** We are now located in the middle of a row, for which there 2547C *** are definitely not any repeated rows immediately below. 2548C *** There may, however, be that the remainder of the row is solid. 2549C *** 2550C *** 2551C *** - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 2552C *** Check for a transition on the current row. 2553C *** 2554C *** Find the transition point, (ITMPRO,ITMPCO). 2555 ITMPRO=IROW 2556 DO 4110, ITMPCO=ICOL,IXBXUR 2557 IF(LBLACK.EQ..TRUE.) THEN 2558 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2559 2 .EQ.WHITE) GOTO 4120 2560 ELSE 2561 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2562 2 .NE.WHITE) GOTO 4120 2563 ENDIF 25644110 CONTINUE 2565C *** We did not have a transition on the current row. 2566C *** Goto NO_TRANS_CURRENT_ROW. 2567 GOTO 4500 2568C *** 25694120 CONTINUE 2570C *** We did have a transition on the current row. 2571C *** 2572C *** Calculate the sum of pixels up to the transition. 2573 IRCSUM=IRCSUM+(ITMPCO-ICOL) 2574C *** Store out the resulting pixel RUN CODE sum count. 2575 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 2576 IRCIND=IRCIND+1 2577C *** Update the current position to be the point of transition. 2578 IROW=ITMPRO 2579 ICOL=ITMPCO 2580C *** Change the current color. 2581 LBLACK=.NOT.LBLACK 2582C *** Reset the counters. 2583 IRPCNT=0 2584 IRCSUM=0 2585C *** 2586C *** We are still in the middle of a row, for which there is no 2587C *** repeat count, and for which the remainder of the row may 2588C *** be of solid color. GOTO MIDDLE_NO_REPEAT. 2589 GOTO 4000 2590C *** 2591C *** - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 2592C *** 25934500 CONTINUE 2594C *** 2595C *** 2596C *** We are now in the middle of a row for which 2597C *** there are no repeat counts, but the remainder of the row 2598C *** is of solid color. 2599C *** 2600C *** Need check if we are on the last row of the minimal bounding 2601C *** box for the character. 2602 IF(IROW.EQ.IYBXLL) GOTO 8100 2603C *** 2604C *** Need to check for a transition at the first pixel of the 2605C *** next row of the minimal bounding box of the character. 2606 ITMPRO=IROW-1 2607 ITMPCO=IXBXLL 2608 IF(LBLACK.EQ..TRUE.) THEN 2609 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2610 2 .NE.WHITE) GOTO 4700 2611 ELSE 2612 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2613 2 .EQ.WHITE) GOTO 4700 2614 ENDIF 2615C *** 2616C *** - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 2617C *** 2618C *** We are on the middle of a row for which there are no 2619C *** repeated rows immediately following, and for which the 2620C *** remainder of the row is of solid color and for which 2621C *** the first pixel on the next row of the minimal bounding 2622C *** box of the character changes color (a transition occurs). 2623C *** 2624C *** Need to calculate the remaining pixels out to the end of the 2625C *** current row. 2626 IRCSUM=IRCSUM+(IXBXUR-ICOL+1) 2627C *** Store this for later Encoding. 2628 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 2629 IRCIND=IRCIND+1 2630C *** Update the current position to be the first pixel on the next line. 2631 ICOL=IXBXLL 2632 IROW=IROW-1 2633C *** Change colors. 2634 LBLACK=.NOT.LBLACK 2635C *** Reset the counters. 2636 IRCSUM=0 2637 IRPCNT=0 2638C *** 2639C *** We are now at the beginning of a new row. 2640C *** GOTO BEGINNING_OF_ROW. 2641 GOTO 2000 2642C *** 2643C *** - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 2644C *** 26454700 CONTINUE 2646C *** 2647C *** We are now in the middle of a row for which there are definitely 2648C *** no repeated rows immediately following, and for which the 2649C *** remainder of the row is of solid color, and for which the first 2650C *** pixel of the next row of the minimal bounding box for the 2651C *** character does not change color (no transition). 2652C *** 2653C *** Add up the pixels remaining on the end of the current row. 2654 IRCSUM=IRCSUM+(IXBXUR-ICOL+1) 2655C *** Update the current position to be the first pixel on the 2656C *** next row. 2657 IROW=IROW-1 2658 ICOL=IXBXLL 2659C *** 2660C *** 2661C *** ---------------------------------------------------------- 2662C *** 2663C *** Need to check and see if the current row is of solid color 2664C *** or not. 2665C *** We will check the "leftover" bits on the left and right of the 2666C *** character first, then if they pass, we will check the bytes in between. 2667C *** Initialize LSOLID=.FALSE. so that "jump_out" to label 5000 will 2668C *** be correct if we do not have a solid row. 2669 LSOLID=.FALSE. 2670 ITMPRO=IROW 2671 ITMPCO=IXBXLL-1 26724705 ITMPCO=ITMPCO+1 2673C *** If we are on an a byte boundary, we have finished checking the 2674C *** left "leftover" bits. Go check the right "leftover" bits. 2675 IF(MOD(ITMPCO,8).EQ.0) GOTO 4710 2676C *** See if the current pixel is the correct color for solid color row. 2677 IF(LBLACK.EQ..TRUE.) THEN 2678 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2679 2 .NE.WHITE) THEN 2680 GOTO 4705 2681 ELSE 2682 GOTO 5000 2683 ENDIF 2684 ELSE 2685 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2686 2 .EQ.WHITE) THEN 2687 GOTO 4705 2688 ELSE 2689 GOTO 5000 2690 ENDIF 2691 ENDIF 2692C *** 2693C *** 2694C *** 26954710 CONTINUE 2696C *** 2697C *** Checking the right "leftover" bits now for solid color row. 2698 J=IROW 2699 I=IXBXUR+1 27004720 I=I-1 2701C *** If we are on an a byte boundary, we have finished checking the 2702C *** right "leftover" bits. Go check the bytes in between. 2703 IF(MOD(I,8).EQ.7) GOTO 4740 2704C *** See if the current pixel is the correct color for solid color row. 2705 IF(LBLACK.EQ..TRUE.) THEN 2706 IF((BITMAP(I/8,J).AND.2**(7-MOD(I,8))) 2707 2 .NE.WHITE) THEN 2708 GOTO 4720 2709 ELSE 2710 GOTO 5000 2711 ENDIF 2712 ELSE 2713 IF((BITMAP(I/8,J).AND.2**(7-MOD(I,8))) 2714 2 .EQ.WHITE) THEN 2715 GOTO 4720 2716 ELSE 2717 GOTO 5000 2718 ENDIF 2719 ENDIF 2720C *** 2721C *** 2722C *** 2723C *** 2724C *** 27254740 CONTINUE 2726C *** 2727C *** Both the left and right "leftover" bits checked out to be solid 2728C *** color of the current color type. Now need to check the 2729C *** bytes in between to see if they are also solid color of the 2730C *** current type. If it is not solid, we will go to the label 2731C *** 5000 for processing, otherwise we will continue processing 2732C *** below. 2733 DO 4750, K=ITMPCO,I,8 2734 IF(LBLACK.EQ..TRUE.) THEN 2735 IF(BITMAP(K/8,J).NE.SOLBLK) GOTO 5000 2736 ELSE 2737 IF(BITMAP(K/8,J).NE.SOLWHT) GOTO 5000 2738 ENDIF 27394750 CONTINUE 2740C *** 2741C *** We have a row which is of solid color. 2742 LSOLID=.TRUE. 2743C *** 2744C *** 2745C *** 2746C *** 2747C *** 2748C *** --------------------------------------------------------------- 2749C *** 2750C *** 2751C *** Calculate the # of consecutive rows which are repeats of the current 2752C *** row. Set IRPCNT=#repeated_consecutive_rows. 2753C *** 2754 IRPCNT=0 27554800 J=IROW-IRPCNT-1 2756C *** Need to make sure that we do not go out of the bounding box. 2757 IF(J.LT.IYBXLL) GOTO 8200 2758C *** Do a loop comparing the bytes across two rows. Since the bits 2759C *** outside of the minimum bounding box are white (0), we do not 2760C *** have to worry about them -- they will compare okay. 2761C *** There are 8 bits to a byte, so there are 8 pixels to a byte. 2762C *** We can step by 8 pixels to do our check. 2763 DO 4820, I=IXBXLL, IXBXUR, 8 2764 IF(BITMAP(I/8,IROW).NE.BITMAP(I/8,J)) GOTO 4850 27654820 CONTINUE 2766C *** We have found another repeated consecutive row. 2767 IRPCNT=IRPCNT+1 2768C *** Go back and check if the next row down is also a repeated row. 2769 GOTO 4800 2770C *** 2771C *** 2772C *** 2773C *** 27744850 CONTINUE 2775C *** We have found all of the consecutive repeated rows. 2776C *** 2777C *** ------------------------------------------------------------------ 2778C *** Add up the sum of pixels on the (possibly repeated) solid rows 2779C *** and add this result to any earlier sum (for the row which 2780C *** had the last part of it solid). 2781 IRCSUM=IRCSUM+ (IXBXUR-IXBXLL+1)*(IRPCNT+1) 2782C *** Update the cursor position to be the first pixel on the next 2783C *** non-solid row below. 2784 IROW=IROW-IRPCNT-1 2785 ICOL=IXBXLL 2786C *** ------------------------------------------------------------------ 2787C *** 2788C *** Need to determine whether a transition occurs at the first 2789C *** pixel of the first non-repeated solid row. If a transition does 2790C *** not occur, goto label 4900, otherwise continue below. 2791 ITMPRO=IROW 2792 ITMPCO=IXBXLL 2793 IF(LBLACK.EQ..TRUE.) THEN 2794 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2795 2 .NE.WHITE) GOTO 4900 2796 ELSE 2797 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2798 2 .EQ.WHITE) GOTO 4900 2799 ENDIF 2800C *** 2801C *** ---------------------------------------------------------------- 2802C *** 2803C *** There is a transition at the first pixel of the minimum bounding 2804C *** box for this first non-solid row. 2805C *** 2806C *** Write out the RUN CODE sum count for later Encoding. 2807 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 2808 IRCIND=IRCIND+1 2809C *** Change color. 2810 LBLACK=.NOT.LBLACK 2811C *** Reset counters. 2812 IRPCNT=0 2813 IRCSUM=0 2814C *** 2815C *** We are now on the beginning of a new row. 2816C *** GOTO BEGINNING_OR_ROW. 2817 GOTO 2000 2818C *** 2819C *** ------------------------------------------------------------------------ 2820C *** 28214900 CONTINUE 2822C *** 2823C *** There is not a transition at the first pixel of the minimum bounding 2824C *** box for this first non-solid row. We are located at this first pixel 2825C *** of this non-solid row. 2826C *** Find the location of the transition on this current row. 2827C *** Find the transition point, (ITMPRO,ITMPCO). 2828 ITMPRO=IROW 2829 DO 4910, ITMPCO=IXBXLL+1,IXBXUR 2830 IF(LBLACK.EQ..TRUE.) THEN 2831 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2832 2 .EQ.WHITE) GOTO 4920 2833 ELSE 2834 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2835 2 .NE.WHITE) GOTO 4920 2836 ENDIF 28374910 CONTINUE 2838C *** 28394920 CONTINUE 2840C *** We now have ITMPRO, ITMPCO where the transition occurs. 2841C *** Calculate the sum of the pixels up to the transition on this row, 2842C *** and add this result to the earlier sum of solid (possibly repeated) 2843C *** rows and the row which had the remaining end pixels to be of solid 2844C *** color. 2845 IRCSUM=IRCSUM+(ITMPCO-IXBXLL) 2846C *** Write out this RUN CODE sum count for later Encoding. 2847 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 2848 IRCIND=IRCIND+1 2849C *** Update position to the transition location. 2850C *** IROW=ITMPRO We are still on the same row. 2851 ICOL=ITMPCO 2852C *** Change colors. 2853 LBLACK=.NOT.LBLACK 2854C *** Reset counters. 2855 IRPCNT=0 2856 IRCSUM=0 2857C *** 2858C *** We are now in the middle of a row, which may have possible repeats 2859C *** and which may have the remainder of the row being a solid color 2860C *** of the current type. GOTO MIDDLE_REPEAT. 2861 GOTO 3000 2862C *** 2863C *** ------------------------------------------------------------------- 2864C *** 28655000 CONTINUE 2866C *** 2867C *** We are on a row, for which the previous row had the remaining 2868C *** pixels on that row to be of solid color. We did not have 2869C *** a transition at the first pixel of this row, and this row 2870C *** is not of solid color. We are located at the first pixel 2871C *** on this non-solid row. 2872C *** 2873C *** Locate the transition on this current row. 2874C *** Find the transition point, (ITMPRO,ITMPCO). 2875 ITMPRO=IROW 2876 DO 5010, ITMPCO=IXBXLL+1,IXBXUR 2877 IF(LBLACK.EQ..TRUE.) THEN 2878 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2879 2 .EQ.WHITE) GOTO 5020 2880 ELSE 2881 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2882 2 .NE.WHITE) GOTO 5020 2883 ENDIF 28845010 CONTINUE 2885C *** 28865020 CONTINUE 2887C *** We now have ITMPRO, ITMPCO where the transition occurs. 2888C *** Add up the sum of the pixels up to the transition with the 2889C *** earlier sum for the previous row which had the pixels at the end 2890C *** to be of solid color. 2891 IRCSUM=IRCSUM + (ITMPCO-IXBXLL) 2892C *** Store this RUN CODE sum count for later Encoding. 2893 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 2894 IRCIND=IRCIND+1 2895C *** Update the current position to be the point of transition. 2896C *** IROW=ITMPRO It is on the same row. 2897 ICOL=ITMPCO 2898C *** Change colors. 2899 LBLACK=.NOT.LBLACK 2900C *** Reset counters. 2901 IRCSUM=0 2902 IRPCNT=0 2903C *** 2904C *** We are now in the middle of a row, for which there may be 2905C *** possible repeats, and for which the remainder of this row 2906C *** may be of solid color. GOTO MIDDLE_REPEAT. 2907 GOTO 3000 2908C *** 2909C *** -------------------------------------------------------------------- 2910C *** 29116000 CONTINUE 2912C *** 2913C *** NOT SOLID BEGINNING_OF_ROW PROCESSING CONTINUED 2914C *** 2915C *** 2916C *** --------------------------------------------------------------- 2917C *** 2918C *** 2919C *** Calculate the # of consecutive rows which are repeats of the current 2920C *** row. Set IRPCNT=#repeated_consecutive_rows. 2921C *** 2922 IRPCNT=0 29236100 J=IROW-IRPCNT-1 2924C *** Need to make sure that we do not go out of the bounding box. 2925 IF(J.LT.IYBXLL) GOTO 6200 2926C *** Do a loop comparing the bytes across two rows. Since the bits 2927C *** outside of the minimum bounding box are white (0), we do not 2928C *** have to worry about them -- they will compare okay. 2929C *** There are 8 bits to a byte, so there are 8 pixels to a byte. 2930C *** We can step by 8 pixels to do our check. 2931 DO 6120, I=IXBXLL, IXBXUR, 8 2932 IF(BITMAP(I/8,IROW).NE.BITMAP(I/8,J)) GOTO 6150 29336120 CONTINUE 2934C *** We have found another repeated consecutive row. 2935 IRPCNT=IRPCNT+1 2936C *** Go back and check if the next row down is also a repeated row. 2937 GOTO 6100 2938C *** 2939C *** 2940C *** 2941C *** 29426150 CONTINUE 2943C *** We have found all of the consecutive repeated rows. 2944C *** 2945C *** ------------------------------------------------------------------ 29466200 CONTINUE 2947C *** 2948 IF(IRPCNT.GT.0) THEN 2949C *** Store the repeat count for later Encoding 2950C *** and update the current position to be the last repeated row, 2951C *** and reset the repeat counter. 2952 IF(LTX05E.EQ..TRUE.) IRPEAT(IRPIND)=IRCIND 2953 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRPCNT 2954 IRPIND=IRPIND+1 2955 IRCIND=IRCIND+1 2956 IROW=IROW-IRPCNT 2957 IRPCNT=0 2958 ENDIF 2959C *** 2960C *** Locate the transition on this current row. 2961C *** Find the transition point, (ITMPRO,ITMPCO). 2962 ITMPRO=IROW 2963 DO 6210, ITMPCO=IXBXLL+1,IXBXUR 2964 IF(LBLACK.EQ..TRUE.) THEN 2965 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2966 2 .EQ.WHITE) GOTO 6220 2967 ELSE 2968 IF((BITMAP(ITMPCO/8,ITMPRO).AND.2**(7-MOD(ITMPCO,8))) 2969 2 .NE.WHITE) GOTO 6220 2970 ENDIF 29716210 CONTINUE 2972C *** 29736220 CONTINUE 2974C *** We now have ITMPRO, ITMPCO where the transition occurs. 2975C *** Add up the sum of the pixels up to the transition. 2976 IRCSUM=IRCSUM + (ITMPCO-IXBXLL) 2977C *** Store this RUN CODE sum count for later Encoding. 2978 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 2979 IRCIND=IRCIND+1 2980C *** Update the current position to be the point of transition. 2981C *** IROW=ITMPRO It is on the same row. 2982 ICOL=ITMPCO 2983C *** Change colors. 2984 LBLACK=.NOT.LBLACK 2985C *** Reset counters. 2986 IRCSUM=0 2987 IRPCNT=0 2988C *** 2989C *** We are now in the middle of a row for which there are 2990C *** no repeated rows immediately following, and for which the 2991C *** remainder of the row may be of solid color. 2992C *** GOTO MIDDLE_NO_REPEAT. 2993 GOTO 4000 2994C *** 2995C *** ----------------------------------------------------------------- 2996C *** 29978000 CONTINUE 2998C *** 2999C *** LAST ROW OF CHARACTER PROCESSING for BEGINNING_OF_ROW SOLID last row. 3000C *** 3001C *** Add up the pixels of all of the solid (possibly repeated) rows 3002C *** immediately above this last row which is solid. 3003 IRCSUM=IRCSUM+(IXBXUR-IXBXLL+1)*(IRPCNT+1) 3004C *** Store this RUN CODE sum count for later Encoding. 3005 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 3006 IRCIND=IRCIND+1 3007C *** Update position, change color, reset counters, and exit. 3008 IROW=IROW-IRPCNT-1 3009 ICOL=IXBXLL 3010 ITMPRO=IROW 3011 ITMPCO=ICOL 3012 LBLACK=.NOT.LBLACK 3013 IRCSUM=0 3014 IRPCNT=0 3015 GOTO 9000 3016C *** 3017C *** ---------------------------------------------------------------------- 3018C *** 30198100 CONTINUE 3020C *** 3021C *** 3022C *** 3023C *** LAST ROW OF CHARACTER PROCESSING for a row which has the last pixels 3024C *** on the row of solid color, but the whole row is not solid. 3025C *** 3026C *** Sum up the pixels remaining on this row. 3027 IRCSUM=IRCSUM+(IXBXUR-ICOL+1) 3028C *** Store this RUN CODE sum count for later Encoding. 3029 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 3030 IRCIND=IRCIND+1 3031C *** Update position, change color, reset counters, and exit. 3032 IROW=IROW-1 3033 ICOL=IXBXLL 3034 ITMPRO=IROW 3035 ITMPCO=ICOL 3036 LBLACK=.NOT.LBLACK 3037 IRPCNT=0 3038 IRCSUM=0 3039 GOTO 9000 3040C *** 3041C *** ------------------------------------------------------------------ 3042C *** 30438200 CONTINUE 3044C *** 3045C *** 3046C *** LAST ROW OF CHARACTER PROCESSING for a row which is solid 3047C *** and may have had repeated solid rows above it and which 3048C *** definitely had a row above it for which the last pixels on 3049C *** the end of the row were of solid color of the current color. 3050C *** 3051C *** Add up all of the pixels on the solid and solid repeated rows 3052C *** and add the earlier pixel count for the partially solid row. 3053 IRCSUM=IRCSUM + (IXBXUR-IXBXLL+1)*(IRPCNT+1) 3054C *** Store this RUN CODE sum count for later Encoding. 3055 IF(LTX05E.EQ..TRUE.) IRUNCD(IRCIND)=IRCSUM 3056 IRCIND=IRCIND+1 3057C *** Update the position, change color, reset counters, and exit. 3058 IROW=IROW-IRPCNT-1 3059 ICOL=IXBXLL 3060 ITMPRO=IROW 3061 ITMPCO=ICOL 3062 LBLACK=.NOT.LBLACK 3063 IRPCNT=0 3064 IRCSUM=0 3065 GOTO 9000 3066C *** 3067C *** -------------------------------------------------------------------- 3068C *** ------------------------------------------------------------------- 3069C *** 30709000 CONTINUE 3071C *** 3072C *** 3073C *** Finished. Exiting. 3074C *** 3075C *** 3076C *** 3077C *** 3078C------------------------------------------------------------------------ 3079 RETURN 3080 END 3081C<FF> 3082C *GRTX06 -- PGPLOT Calculate optimal value of dyn_f. 3083C 3084 SUBROUTINE GRTX06 (IRUNCD,IRCDIM,IBOXDX,IBOXDY,IDYNF, 3085 2 IRPEAT,IRPDIM,BITMAP,IBXDIM,IBYDIM) 3086C----------------------------------------------------------------- 3087C *** 3088C *** ------------------------------------------------------------- 3089C *** This routine is used to find the optimal value of dyn_f 3090C *** for encoding the RUN CODE for the current PK Font character. 3091C *** Documentation for the algorithm is found in the files PKtoPX.WEB, 3092C *** PXtoPK.WEB, PKtype.WEB, and GFtoPK.WEB. To obtain this 3093C *** documentation, WEAVE the WEB file, then TeX the output, then 3094C *** use a dvi-translator the translate the DVI file into a binary 3095C *** file suitable for output to your specific printer. 3096C *** The PK format was designed by Tomas Rokicki in August, 1985. 3097C *** Rokicki was a former Texas A&M Univerisity student. 3098C *** 3099C *** IRUNCD is an integer input array of dimension IRCDIM which contains 3100C *** the RUN CODE for the current character. 3101C *** IRCDIM is an integer input giving the dimension of the IRUNCD array. 3102C *** IBOXDX is an integer input giving the X-direction size of the minimum 3103C *** bounding box of the character. 3104C *** IBOXDY is an integer input giving the Y-direction size of the minimum 3105C *** bounding box of the character. 3106C *** IDYNF is an integer output array of dimension 15 giving the 3107C *** calculated value of dyn_f=(0,13) and the BITMAP encoding (14) 3108C *** upon return from this routine. 3109C *** BITMAP is a byte array of size IBXDIM x IBYDIM containing the 3110C *** Bitmap of the character. 3111C *** IBXDIM is an integer giving the X-dimension of the array BITMAP. 3112C *** IBYDIM is an integer giving the Y-dimension of the array BITMAP. 3113C *** IRPIND is an integer used to index into the IRPEAT array. 3114C *** IRPEAT is an integer array of size IRPDIM which contains indexes 3115C *** into the IRUNCD array pointing to Repeat codes in the RUN CODE 3116C *** for the character. 3117C *** IRPDIM is an integer giving the dimension of the array IRPEAT. 3118C *** I, J are temporary integer variables used for counting and 3119C *** for DO-loop indices. 3120C *** 3121C *** ---------------------------------------------------------------- 3122C *** 3123C *** 3124C *** 3125C *** 3126 IMPLICIT NONE 3127 INTEGER IRCDIM, IRPDIM, IBXDIM, IBYDIM, IBOXDX, I, J 3128 INTEGER IBOXDY, IRUNCD(IRCDIM), IRPEAT(IRPDIM), IRPIND 3129 BYTE BITMAP(0:IBXDIM-1,0:IBYDIM-1) 3130 INTEGER IDYNF(0:14),IVALUE(0:13,3) 3131C *** 3132C *** -------------------------------------------------------------- 3133C *** Store data values used for comparisons below. 3134 DO 50, I=0,13 3135C *** One nybble values are 3136C *** values from 1 to dyn_f. IVALUE(I,1) contains dyn_f=I. 3137 IVALUE(I,1)=I 3138C *** Two nybble values are 3139C *** values from dyn_f+1 to (13-dynf)*16+dynf . 3140 IVALUE(I,2)=(13-I)*16+I 3141C *** Three nybble and larger #nybbles are 3142C *** values from (13-dyn_f)*16+dyn_f up. 3143 IVALUE(I,3)=16-((13-I)*16+I+1) 314450 CONTINUE 3145C *** 3146C *** -------------------------------------------------------------- 3147C *** 3148C *** Initialize the IDYNF array to zero (will be used to keep running 3149C *** sums. 3150 DO 60, I=0,14 3151 IDYNF(I)=0 315260 CONTINUE 3153C *** 3154C *** 3155C *** 3156C *** ---------------------------------------------------------------- 3157C *** 3158C *** First, calculate the length required for the bitmap packing. 3159C *** In bitmap packing, the minimal bounded box pixels are all 3160C *** concatenated into one long string by concatenating rows, then 3161C *** the bitmap string is packed 8 bits into a byte, each pixel 3162C *** representing one bit in a byte. 3163C *** 3164C *** Note: 7/8=0 in integer arithmetic is used to round up the 3165C *** extra bits over a byte at the end of the bitmapping up to 3166C *** an even byte boundary. Also, there are 2 nybbles per byte. 3167C *** So, IDYNF(14) will be the count in nybbles require for compressed 3168C *** raw bitmapping. 3169 IDYNF(14)= (IBOXDX*IBOXDY+7)/8*2 3170C *** 3171C *** 3172C *** ----------------------------------------------------------------- 3173C *** 3174C *** Now calculate the length required for ENCODing the minimum bounded 3175C *** box RUN CODE for different values of dyn_f=[0,13]. 3176C *** 3177 DO 3000, J=0,13 3178C *** Calculate the length required for dyn_f=J ENCODing. 3179 IRPIND=1 3180 DO 1000, I=1,IRCDIM 3181C *** Check and see if the current RUN CODE value is a repeat code. 3182 IF(IRPIND.LE.IRPDIM) THEN 3183 IF(I.EQ.IRPEAT(IRPIND)) THEN 3184C *** It is a repeat value. 3185C *** Increment the Repeat Code index to point to the next repeat value. 3186 IRPIND=IRPIND+1. 3187C *** We use the nybble value 14 to signify a repeat count value > 1, 3188C *** and use the nybble value 15 to signify a repeat count value = 1, 3189C *** then follows immediately the packed number representation 3190C *** of the repeat value. For the signaling nybble (14, or 15), 3191C *** we require 1 nybble. 3192 IDYNF(J)=IDYNF(J)+1 3193C *** If the repeat count is 1, then only the nybble value 15 is 3194C *** required. We do not have to encode the packed number also. 3195 IF(IRUNCD(I).EQ.1) GOTO 1000 3196C *** 3197C *** Now, we will calculate the number of nybbles required for the 3198C *** packed number representation of the repeat count value below 3199C *** (where all packed number representation nybble requirements 3200C *** are determined --- repeat counts, white counts, or black counts). 3201 ENDIF 3202 ENDIF 3203C *** 3204C *** Calculate the number of nybbles required for the packed number 3205C *** representation. 3206C *** 3207C *** First, check for the one nybble packed number representation of 3208C *** the value. 3209 IF(IRUNCD(I).LE.IVALUE(J,1)) THEN 3210C *** Note: The special case J=0 will not occur. A value of 3211C *** zero for IRUNCD(I) signifies the end of the RUN CODE array 3212C *** and was checked for above. 3213 IDYNF(J)=IDYNF(J)+1 3214 GOTO 1000 3215 ENDIF 3216C *** 3217C *** Second, check for the two nybble packed number representation of 3218C *** the value. 3219 IF(IRUNCD(I).LE.IVALUE(J,2)) THEN 3220C *** Note: J=13 will have been caught in the 1 nybble case above 3221C *** so we do not have to worry about that special case. 3222 IDYNF(J)=IDYNF(J)+2 3223 GOTO 1000 3224 ENDIF 3225C *** 3226C *** Lastly, calculate the number of nybbles required for the 3227C *** large (3 or more) nybble representation of the value. 3228 IDYNF(J)=IDYNF(J)+(INT((LOG( 3229 2 FLOAT(IRUNCD(I)+IVALUE(J,3))) 3230 2 /LOG(16.0) + 1 ))*2 -1) 3231C *** 32321000 CONTINUE 32332000 CONTINUE 32343000 CONTINUE 3235C *** 3236C *** 3237C *** ------------------------------------------------------------- 3238C *** Finished. Return with the results. 3239C *** 3240 RETURN 3241 END 3242C<FF> 3243C *GRTX07 -- PGPLOT Compress the raw bitmap and DUMP encode. 3244C 3245 SUBROUTINE GRTX07 (BITMAP,IBXDIM,IBYDIM,BENCOD,IBEDIM, 3246 2 IXBXLL,IYBXLL,IXBXUR,IYBXUR) 3247C------------------------------------------------------------------- 3248C *** 3249C *** 3250C *** ---------------------------------------------------------------- 3251C *** This routine is used to encode the BITMAP into a PK Font 3252C *** by concatenating all of the rows inside of the character 3253C *** into a single row, and storing each pixel as a 1-to-1 mapping 3254C *** into the output array bits. One pixel is one bit in one of 3255C *** the output array bytes. 3256C *** 3257C *** BITMAP is the byte input array of dimension IBXDIM x IBYDIM 3258C *** containing the input PK Font character. 3259C *** IBXDIM is an integer providing the X-dimension of the BITMAP array. 3260C *** IBYDIM is an integer providing the Y-dimension of the BITMAP array. 3261C *** BENCOD is the integer array of dimension IBEDIM, which upon output 3262C *** will contain the ENCODEd BITMAP. 3263C *** IBEDIM is an integer providing the dimension of BENCOD. 3264C *** IXBXLL is an integer specifying the X-coordinate in pixel units 3265C *** of the lower left corner of the minimum bounding box of the 3266C *** PK Font character. 3267C *** IYBXLL is an integer specifying the Y-coordinate in pixel units 3268C *** of the lower left corner of the minimum bounding box of the 3269C *** PK Font character. 3270C *** IXBXUR is an integer specifying the X-coordinate in pixel units 3271C *** of the upper right corner of the minimum bounding box of the 3272C *** PK Font character. 3273C *** IYBXUR is an integer specifying the Y-coordinate in pixel units 3274C *** of the upper right of the minimum bounding box of the 3275C *** PK Font character. 3276C *** IBEIND is an integer variable, which upon output will contain 3277C *** the number of bytes used of the array BECOD. IBEIND is used 3278c *** as an index into the IBEIND array. 3279C *** I, J are temporary integer variables used for counting and 3280C *** and for DO-loop indices. 3281C *** 3282C *** 3283C *** ---------------------------------------------------------------- 3284C *** 3285 IMPLICIT NONE 3286 INTEGER IBXDIM, IBYDIM, IBEDIM, IXBXLL, IYBXLL 3287 INTEGER IXBXUR, IYBXUR, IBEIND, I, J 3288 BYTE BITMAP(0:IBXDIM-1,0:IBYDIM-1) 3289 INTEGER BENCOD(0:IBEDIM-1) 3290C *** 3291C *** 3292C *** ---------------------------------------------------------------- 3293C *** 3294C *** 3295C *** Initialize the variables. 3296C *** 3297 IBEIND=0 3298 DO 100, I=0, IBEDIM-1 3299 BENCOD(I)=0 3300100 CONTINUE 3301C *** 3302C *** 3303C *** ---------------------------------------------------------------- 3304C *** 3305C *** 3306C *** Do the encoding by "ORing" the current output byte (BENCOD(IBEIND/8)) 3307C *** with the value of the current input pixel (the IF statement) -- will 3308C *** be the value 0 or non-zero -- and then multiplying the 3309C *** value of the current pixel with the current output bit 3310C *** position (assignment statement) -- which will be 2**7,...,2*0 according 3311C *** to where you are within the current output byte}. 3312C *** Note: it has been assumed that the bits are arranged from 3313C *** left to right inside a byte as bit 7 (2**7), bit 6 (2**6), 3314C *** ..., bit 1 (2**1), bit 0 (2**0), and that we traverse the 3315C *** bitmap from left to right in increasing byte order ---- 3316C *** If this is not true, then this routine must be modified. 3317C *** I used BENCOD as an integer and '+' to implement the ".OR."ing. 3318 DO 300, J=IYBXUR, IYBXLL, -1 3319 DO 200, I=IXBXLL, IXBXUR 3320 IF((BITMAP(I/8,J).AND.(2**(7-MOD(I,8)))).NE.0)THEN 3321 BENCOD(IBEIND/8)=BENCOD(IBEIND/8) + 3322 2 (2**(7-MOD(IBEIND,8))) 3323 ENDIF 3324 IBEIND=IBEIND+1 3325200 CONTINUE 3326300 CONTINUE 3327C *** 3328C *** 3329C *** 3330C *** 3331C *** ------------------------------------------------------------------- 3332C *** Note: We do not have to worry about finishing packing the last 3333C *** byte, since we zeroed out the array initially. The last byte will 3334C *** have zeros as the last bits. 3335C *** 3336C *** ------------------------------------------------------------------ 3337C *** 3338C *** Now, we let's do a sanity check to make sure that I did not have 3339C *** a programming error which went out of bounds on the BENCOD array. 3340C *** 3341 IF(IBEIND.GT.IBEDIM*8) THEN 3342 CALL GRWARN('Exceeded the array dimension bounds of' 3343 2 //' the array BENCOD.') 3344 CALL GRWARN('This routine was calculating the ' 3345 2 //'ENCODEing of the BITMAP.') 3346 CALL GRWARN('This should never happen. This is a' 3347 2 //' programming error in this routine.') 3348 ENDIF 3349C *** 3350C *** 3351C *** ---------------------------------------------------------------- 3352C *** 3353C *** Finished. Let's return. 3354C *** 3355C *** 3356 RETURN 3357 END 3358C<FF> 3359C *GRTX08 -- PGPLOT ENCODE the RUN CODE count using optimal dyn_f. 3360C 3361 SUBROUTINE GRTX08(IRUNCD,IRCDIM,IDYNF,IRPEAT,IRPDIM, 3362 2 BENCOD,IBEDIM) 3363C----------------------------------------------------------------- 3364C *** 3365C *** ------------------------------------------------------------- 3366C *** This routine is used to encode the current PK Font character 3367C *** using the optimal dyn_f value which was calculated earlier. 3368C *** Documentation for the algorithm is found in the files PKtoPX.WEB, 3369C *** PXtoPK.WEB, PKtype.WEB, and GFtoPK.WEB. To obtain this 3370C *** documentation, WEAVE the WEB file, then TeX the output, then 3371C *** use a dvi-translator the translate the DVI file into a binary 3372C *** file suitable for output to your specific printer. 3373C *** The PK format was designed by Tomas Rokicki in August, 1985. 3374C *** Rokicki was a former Texas A&M Univerisity student. 3375C *** 3376C *** IRUNCD is an integer input array of dimension IRCDIM which contains 3377C *** the RUN CODE for the current character. 3378C *** IRCDIM is an integer input giving the dimension of the IRUNCD array. 3379C *** IDYNF is an integer containing the optimal value of dyn_f which 3380C *** was calculated earlier. dynf=[0,13]. 3381C *** IRPIND is an integer used to index into the IRPEAT array. 3382C *** IRPEAT is an integer array of size IRPDIM which contains indexes 3383C *** into the IRUNCD array pointing to Repeat codes in the RUN CODE 3384C *** for the character. 3385C *** IRPDIM is an integer giving the dimension of the array IRPEAT. 3386C *** BENCOD is an integer array of dimension IBEDIM which upon output 3387C *** is to contain the ENCODEd value of the RUN CODE for the current 3388C *** PK Font character. 3389C *** IBEDIM is an integer giving the dimension of the array BENCOD. 3390C *** IBEIND is an integer used to index into the array BENCOD 3391C *** by indexing using IBEIND/2. 3392C *** ITMPL is used as a temporary integer variable for the number of 3393C *** nybbles required in part of the Large Packed number representation 3394C *** calcluations. 3395C *** ITMP1 is a temporary integer variable used in calculations 3396C *** for the Large Packed number representation, and the 2 nybble 3397C *** representation of the ENCODEd RUN CODE for the current Font character. 3398C *** ITMP2 is a temporary integer variable used in calculations 3399C *** for the Large Packed number representation, and the 2 nybble 3400C *** representation of the ENCODEd RUN CODE for the current Font character. 3401C *** I, K are temporary integer variables used for counting and 3402C *** do-loop indices. 3403C *** ---------------------------------------------------------------- 3404C *** 3405C *** 3406C *** 3407C *** 3408 IMPLICIT NONE 3409 INTEGER IRCDIM, IRPDIM, IBEDIM, IDYNF, I, K 3410 INTEGER IRUNCD(IRCDIM), IRPEAT(IRPDIM), IRPIND, IBEIND 3411 INTEGER ITMPL, ITMP1, ITMP2, I1NYBL, I2NYBL, ILNYBL 3412 INTEGER BENCOD(0:IBEDIM-1) 3413C *** 3414C *** -------------------------------------------------------------- 3415C *** Calculate data values used for comparisons below. 3416C *** One nybble values are 3417C *** values from 1 to dyn_f. I1NYBL contains dyn_f=IDYNF. 3418 I1NYBL=IDYNF 3419C *** Two nybble values are 3420C *** values from dyn_f+1 to (13-dynf)*16+dynf . 3421 I2NYBL=(13-IDYNF)*16+IDYNF 3422C *** Three nybble and larger #nybbles are 3423C *** values from (13-dyn_f)*16+dyn_f up. 3424 ILNYBL=16-((13-IDYNF)*16+IDYNF+1) 3425C *** 3426C *** -------------------------------------------------------------- 3427C *** 3428C *** Initialize the BENCOD array to zero. 3429 DO 60, I=0,IBEDIM-1 3430 BENCOD(I)=0 343160 CONTINUE 3432C *** 3433C *** 3434C *** 3435C *** ---------------------------------------------------------------- 3436C *** 3437C *** Now calculate the ENCODEd RUN CODE for the minimum bounded 3438C *** box using the optimal value dyn_f. 3439C *** 3440 IBEIND=0 3441 IRPIND=1 3442 DO 1000, I=1,IRCDIM 3443 IF(IRPIND.LE.IRPDIM) THEN 3444C *** Check and see if the current RUN CODE value is a repeat code. 3445 IF(I.EQ.IRPEAT(IRPIND)) THEN 3446C *** It is a repeat value. 3447C *** Increment the Repeat Code index to point to the next repeat value. 3448 IRPIND=IRPIND+1. 3449C *** We use the nybble value 14 to signify a repeat count value > 1, 3450C *** and use the nybble value 15 to signify a repeat count value = 1, 3451C *** then follows immediately the packed number representation 3452C *** of the repeat value. For the signaling nybble (14, or 15), 3453C *** we require 1 nybble. 3454C *** If the repeat count is 1, then only the nybble value 15 is 3455C *** required. We do not have to encode the packed number also. 3456 IF(IRUNCD(I).EQ.1) THEN 3457 BENCOD(IBEIND/2)=BENCOD(IBEIND/2) + 3458 2 (15*16*MOD(IBEIND+1,2) + 15*MOD(IBEIND,2)) 3459 IBEIND=IBEIND+1 3460 GOTO 1000 3461 ELSE 3462C *** However, if the repeat count was greater than 1, we have 3463C *** to encode the nybble value 14 and then follow with the 3464C *** packed number representation of the Repeat Count. 3465 BENCOD(IBEIND/2)=BENCOD(IBEIND/2) + 3466 2 (14*16*MOD(IBEIND+1,2) + 14*MOD(IBEIND,2)) 3467 IBEIND=IBEIND+1 3468 ENDIF 3469C *** 3470C *** Now, we will calculate the packed number representation 3471C *** of the repeat count value below (where all packed number 3472C *** representations are determined --- repeat counts, 3473C *** white pixel counts, or black pixel counts). 3474 ENDIF 3475 ENDIF 3476C *** 3477C *** Calculate the number of nybbles required for the packed number 3478C *** representation and ENCODE the RUN CODE in packed format. 3479C *** 3480C *** First, check for the one nybble packed number representation of 3481C *** the value. 3482 IF(IRUNCD(I).LE.I1NYBL) THEN 3483C *** Note: The special case J=0 will not occur. A value of 3484C *** zero for IRUNCD(I) signifies the end of the RUN CODE array 3485C *** and was checked for above. 3486 BENCOD(IBEIND/2)=BENCOD(IBEIND/2) + 3487 2 (IRUNCD(I)*16*MOD(IBEIND+1,2) 3488 3 + IRUNCD(I)*MOD(IBEIND,2)) 3489 IBEIND=IBEIND+1 3490 GOTO 1000 3491 ENDIF 3492C *** 3493C *** Second, check for the two nybble packed number representation of 3494C *** the value. 3495 IF(IRUNCD(I).LE.I2NYBL) THEN 3496C *** Note: J=13 will have been caught in the 1 nybble case above 3497C *** so we do not have to worry about that special case. 3498 ITMP1=INT((IRUNCD(I)-1-IDYNF)/16) + 1 + IDYNF 3499 ITMP2=IRUNCD(I)-(ITMP1-IDYNF-1)*16 - IDYNF - 1 3500 BENCOD(IBEIND/2)=BENCOD(IBEIND/2) + 3501 2 (ITMP1*16*MOD(IBEIND+1,2) 3502 3 + ITMP1*MOD(IBEIND,2)) 3503 IBEIND=IBEIND+1 3504 BENCOD(IBEIND/2)=BENCOD(IBEIND/2) + 3505 2 (ITMP2*16*MOD(IBEIND+1,2) 3506 3 + ITMP2*MOD(IBEIND,2)) 3507 IBEIND=IBEIND+1 3508 GOTO 1000 3509 ENDIF 3510C *** 3511C *** Lastly, calculate the number of nybbles required to be zero 3512C *** for the large (3 or more) nybble representation of the value. 3513C *** Then encode that value as a large packed number. 3514 ITMPL=INT(LOG(FLOAT(IRUNCD(I)+ILNYBL))/LOG(16.0)+1)-1 3515 DO 500, K=1,ITMPL 3516C *** Place ITMPL zeroed nybbles into the BENCOD array. 3517 IBEIND=IBEIND+1 3518500 CONTINUE 3519C *** Now, pack the value as a large packed number into array BENCOD. 3520C *** Values greater than -ILNYBL=((13-dyn_f)*16+dyn_f)) are 3521C *** large run counts. 3522 ITMP1=IRUNCD(I) + ILNYBL 3523 DO 600, K=1,ITMPL+1 3524 ITMP2=INT(ITMP1/(16**(ITMPL-K+1))) 3525 BENCOD(IBEIND/2)=BENCOD(IBEIND/2) + 3526 2 (ITMP2*16*MOD(IBEIND+1,2) 3527 3 + ITMP2*MOD(IBEIND,2)) 3528 IBEIND=IBEIND+1 3529 ITMP1=ITMP1-ITMP2*16**(ITMPL-K+1) 3530600 CONTINUE 3531C *** 3532C *** ---------------------------------------------------------------- 3533C *** 35341000 CONTINUE 35352000 CONTINUE 3536C *** Note: We do not need to finish packing the last nybble of a byte 3537C *** because the byte was zeroed out at the start of this routine. 3538C *** Let us now perform a sanity check to make sure that we did not 3539C *** go out of bounds on the array BENCOD (if we did, it is a programming 3540C *** error --- this should not ever happen). 3541 IF(IBEIND-1.GE.IBEDIM*2) THEN 3542 CALL GRWARN ('Exceeded array dimensions in the TeX PK' 3543 2 //' Font RUN CODE ENCODEr routine.') 3544 CALL GRWARN ('Byte Array BENCOD bounds was exceeded.' 3545 2 //' This is a programming error in that routine.') 3546 CALL GRWARN ('That should never occur.') 3547 ENDIF 3548C *** 3549C *** 3550C *** 3551C *** 3552C *** ------------------------------------------------------------- 3553C *** Finished. Return with the results. 3554C *** 3555 RETURN 3556 END 3557C<FF> 3558C *GRTX09 -- PGPLOT Write out the current PK Font character to PK file. 3559C 3560 SUBROUTINE GRTX09 (IBEDIM,BC,NC,XMAX,RESOLX,NDEV,DEVICE, 3561 2 IXBXLL,IXBXUR,IYBXLL,IYBXUR,IDYNFO, 3562 3 LIBLAK,NPKBYT,LUN,BENCOD,HEIGHT, 3563 4 WIDTH,YMAX,RESOLY) 3564C----------------------------------------------------------------------- 3565C *** 3566C *** 3567 IMPLICIT NONE 3568 INTEGER IBEDIM,BC,NC,NDEV,DEVICE,NPKBYT,LUN(2) 3569 INTEGER IXBXLL,IXBXUR,IYBXLL,IYBXUR,IDYNFO,FLAG 3570 INTEGER DM,DX,DY,W,H,HOFF,VOFF,PL(3),CC,I,ITMPVL 3571 INTEGER ITMPV1,ITMPV2,ITMPV3,ITMPV4,ITMP32,ITMP16 3572 DOUBLE PRECISION TFM,TFMW,TFMH,TMPVAR 3573 REAL XMAX,RESOLX(NDEV),YMAX,RESOLY(NDEV) 3574 LOGICAL LIBLAK 3575 INTEGER BENCOD(IBEDIM),HEIGHT(0:15,4),WIDTH(0:15,4) 3576 INTEGER BYTOUT 3577C *** 3578C------------------------------------------------------------------------- 3579C *** First, we need to calculate the Character Preamble paramaters 3580C *** for the PK file for the short, short extended, and long formats. 3581C *** The packet lengths are: 3582 PL(1)=8+IBEDIM 3583 PL(2)=13+IBEDIM 3584 PL(3)=28+IBEDIM 3585C *** The Character code is: 3586 CC=BC+NC 3587C *** The width values are: 3588 W=IXBXUR-IXBXLL+1 3589C *** The height values are: 3590 H=IYBXUR-IYBXLL+1 3591C *** The TFM value will be computed from: 3592C TFM=XMAX/RESOLX(DEVICE)/1.3837 3593 TFM=W/RESOLX(DEVICE)/1.3837 3594C *** {We will also calculate the char_info width and height table 3595C *** values for the character here, WIDTH, HEIGHT in design size units}. 3596 TFMW=W/RESOLX(DEVICE)/1.3837 3597C TFMW=XMAX/RESOLX(DEVICE)/1.3837 3598 TFMH=H/RESOLY(DEVICE)/1.3837 3599C TFMH=YMAX/RESOLY(DEVICE)/1.3837 3600C *** The DX ( or DM) values are: 3601C DM=XMAX 3602 DM=W 3603 DX=DM*65536 3604C *** The DY values are 0. 3605 DY=0 3606C *** The horizontal offset values are: 3607C HOFF=-IXBXLL 3608 HOFF=0 3609C *** The vertical offset values are: 3610C VOFF=IYBXUR 3611 VOFF=H 3612C *** 3613C *** 3614C *** ------------------------------------------------------------------ 3615C *** 3616C *** Now, we will determine which format of the preamble will be used -- 3617C *** the long, the short, or the short extended. 3618C *** 3619C *** 3620C *** We will use the short form if possible. SHORT_FORM: label 500. 3621 IF( (PL(1).LT.1024) .AND. (CC.LT.256) .AND. 3622 2 (TFM.LT.16) .AND. (DM.LT.256) .AND. (W.LT.256) 3623 3 .AND. (H.LT.256) .AND. (HOFF.GT.-129) 3624 4 .AND. (HOFF.LT.128) .AND. (VOFF.GT.-129) 3625 5 .AND. (VOFF.LT.128)) GOTO 500 3626C *** 3627C *** 3628C *** The short form was not possible. We will try to use the 3629C *** short extended form. SHORT_EXT: label 2000. 3630 IF( (PL(2).LT.196608) .AND. (CC.LT.256) .AND. 3631 2 (TFM.LT.16) .AND. (DM.LT.65536) .AND. (W.LT.65536) 3632 3 .AND. (H.LT.65536) .AND. (HOFF.GT.-32769) 3633 4 .AND. (HOFF.LT.32768) .AND. (VOFF.GT.-32769) 3634 5 .AND. (VOFF.LT.32768)) GOTO 2000 3635C *** 3636C *** 3637C *** The short form, and the short extended forms were not possible. 3638C *** The Long form had better work!. LONG_FORM: label 3500. 3639 IF( (PL(3).LT.2.147836*10**9) .AND. 3640 2 (CC.LT.2.147836*10**9) .AND. 3641 3 (TFM.LT.2048) .AND. (DM.LT.32768) .AND. 3642 4 (W.LT.2.147836*10**9) .AND. (H.LT.2.147836*10**9) 3643 5 .AND. (HOFF.GT.-2.147836*10**9) 3644 6 .AND. (HOFF.LT.2.147836*10**9) .AND. 3645 7 (VOFF.GT.-2.147836*10**9) 3646 8 .AND. (VOFF.LT.2.147836*10**9)) GOTO 3500 3647C *** 3648C *** --------------------------------------------------------------- 3649C *** This file can not be output to a PK file. There is something wrong. 3650C *** 3651 CALL GRWARN ('The PK file cannot be output to.') 3652 CALL GRQUIT ('Character Preamble Format for the ' 3653 2 //'character is too large.') 3654C *** 3655C ----------------------------------------------------------------------- 3656C *** 3657C *** 3658C *** 3659C *** 3660C *** 3661C *** 3662C *** 3663C *** 3664C *** 3665C *** 3666C -------------------------------------------------------------------------- 3667500 CONTINUE 3668C *** 3669C *** SHORT_FORMAT: 3670C *** 3671C *** 3672C *** ----------------- 3673C *** First, we write out the Flag (1 byte). 3674 FLAG=0 3675 FLAG=FLAG+IDYNFO*16 3676 IF((LIBLAK.EQ..TRUE.) .AND. (IDYNFO.LT.14)) 3677 2 FLAG=FLAG + 2**3 3678 ITMPVL=INT(PL(1)/256.0) 3679 FLAG=FLAG+ITMPVL 3680 BYTOUT=FLAG 3681 CALL GRTX11(LUN(1),BYTOUT) 3682C *** 3683C *** Second, we write out the Packet_Length (1 byte). 3684 BYTOUT=PL(1)-ITMPVL*256 3685 CALL GRTX11(LUN(1),BYTOUT) 3686C *** 3687C *** Third, we write out the Character_Code (1 byte). 3688 BYTOUT=CC 3689 CALL GRTX11(LUN(1),BYTOUT) 3690C *** 3691C *** Fourth, we write out the TFM_width (3 bytes). 3692 TMPVAR=TFM 3693 ITMPVL=INT(TMPVAR/16.0**(-1)) 3694 BYTOUT=ITMPVL 3695 CALL GRTX11(LUN(1),BYTOUT) 3696 TMPVAR=TMPVAR-ITMPVL*16.0**(-1) 3697 ITMPVL=INT(TMPVAR/16.0**(-3)) 3698 BYTOUT=ITMPVL 3699 CALL GRTX11(LUN(1),BYTOUT) 3700 TMPVAR=TMPVAR-ITMPVL*16.0**(-3) 3701 ITMPVL=INT(TMPVAR/16.0**(-5)) 3702 BYTOUT=ITMPVL 3703 CALL GRTX11(LUN(1),BYTOUT) 3704C *** 3705C *** Fifth, we write out the horizontal escapement (DM is 1 byte). 3706 BYTOUT=DM 3707 CALL GRTX11(LUN(1),BYTOUT) 3708C *** 3709C *** Sixth, we write out the Width of the bitmap (1 byte). 3710 BYTOUT=W 3711 CALL GRTX11(LUN(1),BYTOUT) 3712C *** 3713C *** Seventh, we write out the Height of the bitmap (1 byte). 3714 BYTOUT=H 3715 CALL GRTX11(LUN(1),BYTOUT) 3716C *** 3717C *** Eighth, we write out the Horizontal offset (signed 1 byte) 3718C *** Since it is signed, we must take care of this. 3719 IF (HOFF.LT.0) THEN 3720 BYTOUT=HOFF+256 3721 ELSE 3722 BYTOUT=HOFF 3723 ENDIF 3724 CALL GRTX11(LUN(1),BYTOUT) 3725C *** 3726C *** 3727C *** Ninth, we write out the Vertical offset (signed 1 byte) 3728C *** Since it is signed, we must take care of this. 3729 IF (VOFF.LT.0) THEN 3730 BYTOUT=VOFF+256 3731 ELSE 3732 BYTOUT=VOFF 3733 ENDIF 3734 CALL GRTX11(LUN(1),BYTOUT) 3735C *** 3736C *** We just wrote out 11 bytes to the PK file. 3737 NPKBYT=NPKBYT+11 3738C *** Finished with the character Preamble, time to write out the character 3739C *** to the PK file. 3740C *** 3741C *** 3742C *** Write out the encoded character. 3743 GOTO 5000 3744C -------------------------------------------------------------------------- 37452000 CONTINUE 3746C *** 3747C *** SHORT_EXT: 3748C *** 3749C *** ----------------- 3750C *** First, we write out the Flag (1 byte). 3751 FLAG=0 3752 FLAG=FLAG+IDYNFO*16 3753 IF((LIBLAK.EQ..TRUE.) .AND. (IDYNFO.LT.14)) 3754 2 FLAG=FLAG + 2**3 3755 FLAG=FLAG+2**2 3756 ITMPVL=INT(PL(2)/65536.0) 3757 FLAG=FLAG+ITMPVL 3758 BYTOUT=FLAG 3759 CALL GRTX11(LUN(1),BYTOUT) 3760C *** 3761C *** Second, we write out the Packet_Length (2 byte). 3762 ITMPVL=PL(2)-ITMPVL*65536 3763 ITMPV2=INT(ITMPVL/256.0) 3764 BYTOUT=ITMPV2 3765 CALL GRTX11(LUN(1),BYTOUT) 3766 ITMPV1=ITMPVL-ITMPV2*256 3767 BYTOUT=ITMPV1 3768 CALL GRTX11(LUN(1),BYTOUT) 3769C *** 3770C *** 3771C *** 3772C *** Third, we write out the Character_Code (1 byte). 3773 BYTOUT=CC 3774 CALL GRTX11(LUN(1),BYTOUT) 3775C *** 3776C *** Fourth, we write out the TFM_width (3 bytes). 3777 TMPVAR=TFM 3778 ITMPVL=INT(TMPVAR/16.0**(-1)) 3779 BYTOUT=ITMPVL 3780 CALL GRTX11(LUN(1),BYTOUT) 3781 TMPVAR=TMPVAR-ITMPVL*16.0**(-1) 3782 ITMPVL=INT(TMPVAR/16.0**(-3)) 3783 BYTOUT=ITMPVL 3784 CALL GRTX11(LUN(1),BYTOUT) 3785 TMPVAR=TMPVAR-ITMPVL*16.0**(-3) 3786 ITMPVL=INT(TMPVAR/16.0**(-5)) 3787 BYTOUT=ITMPVL 3788 CALL GRTX11(LUN(1),BYTOUT) 3789C *** 3790C *** 3791C *** Fifth, we write out the horizontal escapement (DM is 2 byteS). 3792 ITMPV2=INT(DM/256.0) 3793 BYTOUT=ITMPV2 3794 CALL GRTX11(LUN(1),BYTOUT) 3795 ITMPV1=DM-ITMPV2*256 3796 BYTOUT=ITMPV1 3797 CALL GRTX11(LUN(1),BYTOUT) 3798C *** 3799C *** Sixth, we write out the Width of the bitmap (2 bytes). 3800 ITMPV2=INT(W/256.0) 3801 BYTOUT=ITMPV2 3802 CALL GRTX11(LUN(1),BYTOUT) 3803 ITMPV1=W-ITMPV2*256 3804 BYTOUT=ITMPV1 3805 CALL GRTX11(LUN(1),BYTOUT) 3806C *** 3807C *** Seventh, we write out the Height of the bitmap (2 bytes). 3808 ITMPV2=INT(H/256.0) 3809 BYTOUT=ITMPV2 3810 CALL GRTX11(LUN(1),BYTOUT) 3811 ITMPV1=H-ITMPV2*256 3812 BYTOUT=ITMPV1 3813 CALL GRTX11(LUN(1),BYTOUT) 3814C *** 3815C *** Eighth, we write out the Horizontal offset (signed 2 bytes) 3816 IF (HOFF.LT.0) THEN 3817 ITMPVL=HOFF+65536 3818 ELSE 3819 ITMPVL=HOFF 3820 ENDIF 3821 ITMPV2=INT(ITMPVL/256.0) 3822 BYTOUT=ITMPV2 3823 CALL GRTX11(LUN(1),BYTOUT) 3824 ITMPV1=ITMPVL-ITMPV2*256 3825 BYTOUT=ITMPV1 3826 CALL GRTX11(LUN(1),BYTOUT) 3827C *** 3828C *** 3829C *** Ninth, we write out the Vertical offset (signed 2 bytes). 3830 IF (VOFF.LT.0) THEN 3831 ITMPVL=VOFF+65536 3832 ELSE 3833 ITMPVL=VOFF 3834 ENDIF 3835 ITMPV2=INT(ITMPVL/256.0) 3836 BYTOUT=ITMPV2 3837 CALL GRTX11(LUN(1),BYTOUT) 3838 ITMPV1=ITMPVL-ITMPV2*256 3839 BYTOUT=ITMPV1 3840 CALL GRTX11(LUN(1),BYTOUT) 3841C *** 3842C *** 3843C *** We just wrote out 17 bytes to the PK file. 3844 NPKBYT=NPKBYT+17 3845C *** Finished with the character Preamble, time to write out the character 3846C *** to the PK file. 3847C *** 3848C *** 3849C *** 3850C *** 3851C *** Write out the encoded character. 3852 GOTO 5000 3853C -------------------------------------------------------------------------- 38543500 CONTINUE 3855C *** 3856C *** LONG_FORMAT: 3857C *** 3858C *** Note: All of these 4 byte quantites are "signed", but only 3859C *** HOFF and VOFF can actually be negative. We did a check 3860C *** on all of the other variables at the start of this routine. 3861C *** We only have to worry about HOFF and VOFF being signed quantities. 3862C *** ----------------- 3863C *** First, we write out the Flag (1 byte). 3864 FLAG=0 3865 FLAG=FLAG+IDYNFO*16 3866 IF((LIBLAK.EQ..TRUE.) .AND. (IDYNFO.LT.14)) 3867 2 FLAG=FLAG + 2**3 3868 FLAG=FLAG+7 3869 BYTOUT=FLAG 3870 CALL GRTX11(LUN(1),BYTOUT) 3871C *** 3872C *** Second, we write out the Packet_Length (4 bytes). 3873 ITMPVL=PL(3) 3874 ITMPV4=INT(ITMPVL/16777216.0) 3875 BYTOUT=ITMPV4 3876 CALL GRTX11(LUN(1),BYTOUT) 3877 ITMPVL=ITMPVL-ITMPV4*16777216 3878 ITMPV3=INT(ITMPVL/65536.0) 3879 BYTOUT=ITMPV3 3880 CALL GRTX11(LUN(1),BYTOUT) 3881 ITMPVL=ITMPVL-ITMPV3*65536 3882 ITMPV2=INT(ITMPVL/256.0) 3883 BYTOUT=ITMPV2 3884 CALL GRTX11(LUN(1),BYTOUT) 3885 ITMPVL=ITMPVL-ITMPV2*256 3886 ITMPV1=ITMPVL 3887 BYTOUT=ITMPV1 3888 CALL GRTX11(LUN(1),BYTOUT) 3889C *** 3890C *** Third, we write out the Character_Code (1 byte). 3891 ITMPVL=CC 3892 ITMPV4=INT(ITMPVL/16777216.0) 3893 BYTOUT=ITMPV4 3894 CALL GRTX11(LUN(1),BYTOUT) 3895 ITMPVL=ITMPVL-ITMPV4*16777216 3896 ITMPV3=INT(ITMPVL/65536.0) 3897 BYTOUT=ITMPV3 3898 CALL GRTX11(LUN(1),BYTOUT) 3899 ITMPVL=ITMPVL-ITMPV3*65536 3900 ITMPV2=INT(ITMPVL/256.0) 3901 BYTOUT=ITMPV2 3902 CALL GRTX11(LUN(1),BYTOUT) 3903 ITMPVL=ITMPVL-ITMPV2*256 3904 ITMPV1=ITMPVL 3905 BYTOUT=ITMPV1 3906 CALL GRTX11(LUN(1),BYTOUT) 3907C *** 3908C *** Fourth, we write out the TFM_width (4 bytes). 3909 TMPVAR=TFM 3910 ITMPVL=INT(TMPVAR/16.0**1) 3911 BYTOUT=ITMPVL 3912 CALL GRTX11(LUN(1),BYTOUT) 3913 TMPVAR=TMPVAR-ITMPVL*16.0**1 3914 ITMPVL=INT(TMPVAR/16.0**(-1)) 3915 BYTOUT=ITMPVL 3916 CALL GRTX11(LUN(1),BYTOUT) 3917 TMPVAR=TMPVAR-ITMPVL*16.0**(-1) 3918 ITMPVL=INT(TMPVAR/16.0**(-3)) 3919 BYTOUT=ITMPVL 3920 CALL GRTX11(LUN(1),BYTOUT) 3921 TMPVAR=TMPVAR-ITMPVL*16.0**(-3) 3922 ITMPVL=INT(TMPVAR/16.0**(-5)) 3923 BYTOUT=ITMPVL 3924 CALL GRTX11(LUN(1),BYTOUT) 3925C *** 3926C *** Fifth, we write out the horizontal escapement (DX is 4 bytes). 3927C *** 3928 ITMPVL=DX 3929 ITMPV4=INT(ITMPVL/16777216.0) 3930 BYTOUT=ITMPV4 3931 CALL GRTX11(LUN(1),BYTOUT) 3932 ITMPVL=ITMPVL-ITMPV4*16777216 3933 ITMPV3=INT(ITMPVL/65536.0) 3934 BYTOUT=ITMPV3 3935 CALL GRTX11(LUN(1),BYTOUT) 3936 ITMPVL=ITMPVL-ITMPV3*65536 3937 ITMPV2=INT(ITMPVL/256.0) 3938 BYTOUT=ITMPV2 3939 CALL GRTX11(LUN(1),BYTOUT) 3940 ITMPVL=ITMPVL-ITMPV2*256 3941 ITMPV1=ITMPVL 3942 BYTOUT=ITMPV1 3943 CALL GRTX11(LUN(1),BYTOUT) 3944C *** Sixth, we write out the Vertical escapement (4 bytes). DY=0. 3945 DO 3600, I=1, 4 3946 BYTOUT=0 3947 CALL GRTX11(LUN(1),BYTOUT) 39483600 CONTINUE 3949C *** Seventh, we write out the Width of the bitmap (4 bytes). 3950 ITMPVL=W 3951 ITMPV4=INT(ITMPVL/16777216.0) 3952 BYTOUT=ITMPV4 3953 CALL GRTX11(LUN(1),BYTOUT) 3954 ITMPVL=ITMPVL-ITMPV4*16777216 3955 ITMPV3=INT(ITMPVL/65536.0) 3956 BYTOUT=ITMPV3 3957 CALL GRTX11(LUN(1),BYTOUT) 3958 ITMPVL=ITMPVL-ITMPV3*65536 3959 ITMPV2=INT(ITMPVL/256.0) 3960 BYTOUT=ITMPV2 3961 CALL GRTX11(LUN(1),BYTOUT) 3962 ITMPVL=ITMPVL-ITMPV2*256 3963 ITMPV1=ITMPVL 3964 BYTOUT=ITMPV1 3965 CALL GRTX11(LUN(1),BYTOUT) 3966C *** 3967C *** Eighth, we write out the Height of the bitmap (4 bytes). 3968 ITMPVL=H 3969 ITMPV4=INT(ITMPVL/16777216.0) 3970 BYTOUT=ITMPV4 3971 CALL GRTX11(LUN(1),BYTOUT) 3972 ITMPVL=ITMPVL-ITMPV4*16777216 3973 ITMPV3=INT(ITMPVL/65536.0) 3974 BYTOUT=ITMPV3 3975 CALL GRTX11(LUN(1),BYTOUT) 3976 ITMPVL=ITMPVL-ITMPV3*65536 3977 ITMPV2=INT(ITMPVL/256.0) 3978 BYTOUT=ITMPV2 3979 CALL GRTX11(LUN(1),BYTOUT) 3980 ITMPVL=ITMPVL-ITMPV2*256 3981 ITMPV1=ITMPVL 3982 BYTOUT=ITMPV1 3983 CALL GRTX11(LUN(1),BYTOUT) 3984C *** 3985C *** Ninth, we write out the Horizontal offset (signed 4 bytes). 3986C *** This will be a negative quantity. But officially can be signed. 3987C *** The result is NOT just two's complement as in the case with 2 byte 3988C *** and 1 byte signed quantities. The first two bytes take care of 3989C *** whether the quantity is signed or not, while the last two bytes 3990C *** are positive. 3991 ITMP32=HOFF 3992 ITMP16=INT(ITMP32/65536.0) 3993 IF(ITMP16.LT.0) ITMP16=ITMP16+65536 3994 ITMPV4=INT(ITMP16/256.0) 3995 ITMPV3=ITMP16-ITMPV4*256 3996 ITMP16=ITMP32-ITMP16*65536 3997 ITMPV2=INT(ITMP16/256.0) 3998 ITMPV1=ITMP16-ITMPV2*256 3999 BYTOUT=ITMPV4 4000 CALL GRTX11(LUN(1),BYTOUT) 4001 BYTOUT=ITMPV3 4002 CALL GRTX11(LUN(1),BYTOUT) 4003 BYTOUT=ITMPV2 4004 CALL GRTX11(LUN(1),BYTOUT) 4005 BYTOUT=ITMPV1 4006 CALL GRTX11(LUN(1),BYTOUT) 4007C *** 4008C *** 4009C *** Tenth, we write out the Vertical offset (signed 4 bytes). 4010C *** This will be a positive quantity. But officially can be signed. 4011C *** The result is NOT just two's complement as in the case with 2 byte 4012C *** and 1 byte signed quantities. The first two bytes take care of 4013C *** whether the quantity is signed or not, while the last two bytes 4014C *** are positive. 4015 ITMP32=VOFF 4016 ITMP16=INT(ITMP32/65536.0) 4017 IF(ITMP16.LT.0) ITMP16=ITMP16+65536 4018 ITMPV4=INT(ITMP16/256.0) 4019 ITMPV3=ITMP16-ITMPV4*256 4020 ITMP16=ITMP32-ITMP16*65536 4021 ITMPV2=INT(ITMP16/256.0) 4022 ITMPV1=ITMP16-ITMPV2*256 4023 BYTOUT=ITMPV4 4024 CALL GRTX11(LUN(1),BYTOUT) 4025 BYTOUT=ITMPV3 4026 CALL GRTX11(LUN(1),BYTOUT) 4027 BYTOUT=ITMPV2 4028 CALL GRTX11(LUN(1),BYTOUT) 4029 BYTOUT=ITMPV1 4030 CALL GRTX11(LUN(1),BYTOUT) 4031C *** 4032C *** We just wrote out 37 bytes to the PK file. 4033 NPKBYT=NPKBYT+37 4034C *** Finished with the character Preamble, time to write out the character 4035C *** to the PK file. 4036C *** 4037C *** 4038C *** 4039C *** Write out the encoded character. 4040 GOTO 5000 4041C ------------------------------------------------------------------------- 40425000 CONTINUE 4043C *** 4044C *** CHAR_WRITE: 4045C *** 4046C *** 4047C *** 4048C *** Write out the encode character information to the PK file. 4049 DO 5100, I=1,IBEDIM 4050 CALL GRTX11(LUN(1),BENCOD(I)) 40515100 CONTINUE 4052C *** We just wrote out IBEDIM bytes to the PK file. 4053 NPKBYT=NPKBYT+IBEDIM 4054C *** 4055C *** We need to finish up some bookkeeping, and calculate the TFM file 4056C *** WIDTH and HEIGHT lookup values for this character. 4057C *** We calculate TFMW and TFMH at the start of this routine, we now 4058C *** just need to put them into a Fix_word representation (like the 4059C *** PK files TFM width calculation for the large format of character 4060C *** preamble. 4061C *** First do the TFM WIDTH value calculation and store it for 4062C *** this character. 4063 TMPVAR=TFMW 4064 ITMPVL=INT(TMPVAR/16.0**1) 4065 WIDTH(NC+1,1)=ITMPVL 4066 TMPVAR=TMPVAR-ITMPVL*16.0**1 4067 ITMPVL=INT(TMPVAR/16.0**(-1)) 4068 WIDTH(NC+1,2)=ITMPVL 4069 TMPVAR=TMPVAR-ITMPVL*16.0**(-1) 4070 ITMPVL=INT(TMPVAR/16.0**(-3)) 4071 WIDTH(NC+1,3)=ITMPVL 4072 TMPVAR=TMPVAR-ITMPVL*16.0**(-3) 4073 ITMPVL=INT(TMPVAR/16.0**(-5)) 4074 WIDTH(NC+1,4)=ITMPVL 4075C *** 4076C *** Second, do the HEIGHT calculation and store it. 4077 TMPVAR=TFMH 4078 ITMPVL=INT(TMPVAR/16.0**1) 4079 HEIGHT(NC+1,1)=ITMPVL 4080 TMPVAR=TMPVAR-ITMPVL*16.0**1 4081 ITMPVL=INT(TMPVAR/16.0**(-1)) 4082 HEIGHT(NC+1,2)=ITMPVL 4083 TMPVAR=TMPVAR-ITMPVL*16.0**(-1) 4084 ITMPVL=INT(TMPVAR/16.0**(-3)) 4085 HEIGHT(NC+1,3)=ITMPVL 4086 TMPVAR=TMPVAR-ITMPVL*16.0**(-3) 4087 ITMPVL=INT(TMPVAR/16.0**(-5)) 4088 HEIGHT(NC+1,4)=ITMPVL 4089C *** 4090C *** Finished. Let's return and do the next character if there are 4091C *** any more. 4092C ------------------------------------------------------------------------ 4093 RETURN 4094 END 4095C<FF> 4096C *GRTX10 -- PGPLOT Output the TFM file. 4097C 4098 SUBROUTINE GRTX10(NC,ITFMUN,CHINFO,WIDTH,HEIGHT,BC) 4099C *** ------------------------------------------------------------------- 4100C *** We have limited the dimensions to support only 15 characters 4101C *** per Font. ASCII codes "A" through a possible maximum of "O" 4102C *** are assumed. TFM file limit of 16 different character 4103C *** HEIGHT table lookup values was the reason for this choice of 4104C *** limiting the Font to a maximum of 15 characters. Each of the 4105C *** 15 characters will have exactly 1 entry in the character WIDTH 4106C *** and HEIGHT lookup tables for simplicity. 4107C *** 4108C---------------------------------------------------------------------- 4109 IMPLICIT NONE 4110 INTEGER LF,BC,NC,I,J,ITFMUN 4111C *** BC is the decimal value representing ASCII "A". 4112C *** ECMAX is to be the 15th character after the starting 4113C *** character (denoted by the value of BC). 4114 INTEGER BYTOUT, HEADER(0:16,4),CHINFO(BC:BC+14,4), 4115 2 WIDTH(0:15,4),HEIGHT(0:15,4) 4116C *** 4117C *** =========================================================== 4118C *** Have finished writing out the PK Font file. Now, write out 4119C *** the TFM (TeX Font Metric) File. The TFM file should be 4120C *** "SEQUENTIAL, FIXED-LENGTH 512 BYTES, NO CARRIAGE_CONTROL" 4121C *** to match the other TFM files on the VAX. 4122C *** TFM files require the most significant byte to appear in the 4123C *** file before the less significant byte. VMS RMS will take 4124C *** care of the order of reading and writing the bits in a byte. 4125C *** So, as long as bytes are written out by this program in the 4126C *** correct order, the bits will be okay. 4127C *** 4128C *** 4129C *** Write out the total length of the TFM file in words (1 word=4 bytes). 4130C *** High byte, low byte integer as is required throught the TFM file. 4131C *** LF comes from 6 words (LF,LH,BC,EC,NW,NH,ND,NI,NL,NK,NE,NP values) 4132C *** plus 17 header words, plus NC+1 char_info words, plus 4133C *** NC+2 width table words, plus NC+2 height table words, 4134C *** plus 1 depth word, plus 1 italic word, plus 7 parameter words. 4135 LF=37+3*NC 4136 BYTOUT = INT(LF/256.0) 4137 CALL GRTX12(ITFMUN,BYTOUT) 4138 BYTOUT = LF - INT(LF/256.0)*256 4139 CALL GRTX12(ITFMUN,BYTOUT) 4140C *** 4141C *** Write out the length of the header data in words (1 word=4 bytes). 4142C *** High byte, low byte integer format. 4143 BYTOUT=0 4144 CALL GRTX12(ITFMUN,BYTOUT) 4145 BYTOUT=17 4146 CALL GRTX12(ITFMUN,BYTOUT) 4147C *** 4148C *** Write out the ASCII value to be used for the first Font character. 4149C *** Value < 256 require by TFM file. High byte, low byte integer format. 4150 BYTOUT = 0 4151 CALL GRTX12(ITFMUN,BYTOUT) 4152 BYTOUT = BC 4153 CALL GRTX12(ITFMUN,BYTOUT) 4154C *** 4155C *** Write out the ASCII value to be used for the last Font character. 4156C *** BC <= Value <= BC+14 = ECMAX required by program dimensions and 4157C *** algorithm used. TFM requires Value < 256. 4158C *** High byte, low byte integer format. 4159 BYTOUT = 0 4160 CALL GRTX12(ITFMUN,BYTOUT) 4161 BYTOUT = BC + NC 4162 CALL GRTX12(ITFMUN,BYTOUT) 4163C *** 4164C *** Write out the number of words in the character WIDTH lookup table. 4165C *** (One for each character was used for simplicity. Maximum of 15 4166C *** characters). High byte, low byte integer format. 4167 BYTOUT = 0 4168 CALL GRTX12(ITFMUN,BYTOUT) 4169 BYTOUT = NC + 2 4170 CALL GRTX12(ITFMUN,BYTOUT) 4171C *** 4172C *** Write out the number of words in the character HEIGHT lookup table. 4173C *** (One for each character was used for simplicity. Maximum of 15 4174C *** characters). High byte, low byte integer format. 4175 BYTOUT = 0 4176 CALL GRTX12(ITFMUN,BYTOUT) 4177 BYTOUT = NC + 2 4178 CALL GRTX12(ITFMUN,BYTOUT) 4179C *** 4180C *** Write out the number of words in the character DEPTH lookup table. 4181C *** (Only the value 0). Hight byte, low byte integer format. 4182 BYTOUT = 0 4183 CALL GRTX12(ITFMUN,BYTOUT) 4184 BYTOUT = 1 4185 CALL GRTX12(ITFMUN,BYTOUT) 4186C *** 4187C *** Write the number of words in the character ITALIC correction lookup 4188C *** table. (Only the value 0). High byte, low byte integer format. 4189 BYTOUT = 0 4190 CALL GRTX12(ITFMUN,BYTOUT) 4191 BYTOUT = 1 4192 CALL GRTX12(ITFMUN,BYTOUT) 4193C *** 4194C *** Write out the number of words in the character LIG/KERN lookup table. 4195C *** (No values. This table is ommitted). High byte, low byte integer format. 4196 BYTOUT = 0 4197 CALL GRTX12(ITFMUN,BYTOUT) 4198 BYTOUT = 0 4199 CALL GRTX12(ITFMUN,BYTOUT) 4200C *** 4201C *** Write out the number of words in the character KERN lookup table. 4202C *** (No values. This table is ommitted). High byte, low byte integer format. 4203 BYTOUT = 0 4204 CALL GRTX12(ITFMUN,BYTOUT) 4205 BYTOUT = 0 4206 CALL GRTX12(ITFMUN,BYTOUT) 4207C *** 4208C *** Write out the number of words in the extensible character lookup table. 4209C *** (No values. This table is ommitted). High byte, low byte integer format. 4210 BYTOUT = 0 4211 CALL GRTX12(ITFMUN,BYTOUT) 4212 BYTOUT = 0 4213 CALL GRTX12(ITFMUN,BYTOUT) 4214C *** 4215C *** Write out the number of Font PARAMater words. High byte, low byte 4216C *** integer format. 4217 BYTOUT = 0 4218 CALL GRTX12(ITFMUN,BYTOUT) 4219 BYTOUT = 7 4220 CALL GRTX12(ITFMUN,BYTOUT) 4221C *** 4222C *** 4223C *** ------------------------------------------------------------------ 4224C *** 4225C *** Write out the HEADER information of the TFM file. 4226C *** 4227C *** ------------------------------------------------------------------ 4228C *** 4229C *** Store the 32 bit check sum, HEADER[0], that TeX will copy into the 4230C *** DVI output file whenever it uses the font. This same checksum 4231C *** should be in the FONT PK file as well. 4232C *** I arbitrarily chose HEADER[0]=09281963 as the 32 bit Hex value. 4233C *** (my birthdate is easy to remember...). 4234 HEADER(0,1) = 9 4235 HEADER(0,2) = 2*16 + 8 4236 HEADER(0,3) = 1*16 + 9 4237 HEADER(0,4) = 6*16 + 3 4238C *** 4239C *** Store HEADER[1], a Fix_word containing the design size of the 4240C *** Font in TeX point units. (7227 TeX points = 254 cm.). 4241C *** Note: This number must be at least 1.0. 4242C *** [Fix_word is a 32-bit representation of a binary fraction. 4243C *** Of the 32 bits in a Fix_word, exactly 12 are to the left of the 4244C *** binary point. Thus, 2048-2**-20 >= Fixed_word >= -2048 ]. 4245C *** I chosed 100.00 TeX points as the Font design size. Since many of 4246C *** the fields in the TFM file must be expressed within 16 absolute 4247C *** design-size units in value, 100.0 TeX points approximately = 1.38 4248C *** inches will allow up to approximately 22 inch output to be used. 4249C *** HEADER[1]=100.0base10=64.0base16 = 06400000 . 4250 HEADER(1,1) = 0*16 + 6 4251 HEADER(1,2) = 4*16 + 0 4252 HEADER(1,3) = 0 4253 HEADER(1,4) = 0 4254C *** 4255C *** Store HEADER[2]...HEADER[11]. 4256C *** These 40 bytes identify the character coding scheme. The first byte 4257C *** gives the number of bytes that are used to contain the identifying 4258C *** string. We will use 7 bytes to contain the string "GRAPHIC". 4259C *** ASCII codes in Hex are "G"=47,"R"=52","A"=41,"P"=50,"H"=48, 4260C *** "I"=49,"C"=43. So, in Hex, HEADER[2]=07475241, HEADER[3]=50484943, 4261C *** HEADER[4]=00000000, HEADER[5]=00000000, HEADER[6]=00000000, 4262C *** HEADER[7]=00000000, HEADER[8]=00000000, HEADER[9]=00000000, 4263C *** HEADER[10]=00000000, HEADER[11]=00000000. 4264C *** Storing thoses values, we have: 4265 HEADER(2,1) = 0*16 + 7 4266 HEADER(2,2) = 4*16 + 7 4267 HEADER(2,3) = 5*16 + 2 4268 HEADER(2,4) = 4*16 + 1 4269 HEADER(3,1) = 5*16 + 0 4270 HEADER(3,2) = 4*16 + 8 4271 HEADER(3,3) = 4*16 + 9 4272 HEADER(3,4) = 4*16 + 3 4273C *** Storing HEADER[4]...HEADER[11] = 00000000, we have: 4274 DO 20, J=1,4 4275 DO 10, I=4,11 4276 HEADER(I,J)=0 427710 CONTINUE 427820 CONTINUE 4279C *** 4280C *** Store HEADER[12]...HEADER[16]. 4281C *** These 20 bytes contain the Font family name in BCPL format. 4282C *** This filed is know as the "Font identifier". I chose the 18 characters 4283C *** "PGPLOT BITMAP DATA" for the Font name. ASCII values in HEX are: 4284C *** "P"=50,"G"=47,"P"=50,"L"=4C,"O"=4F,"T"=54," "=20,"B"=42,"I"=49, 4285C *** "T"=54,"M"=4D,"A"=41,"P"=50," "=20,"D"=44,"A"=41,"T"=54,"A"=41. 4286C *** So, HEADER[12]=12504750, HEADER[13]=4C4F5420, HEADER[14]=4249544D, 4287C *** HEADER[15]=41502044, HEADER[16]=41544100. 4288C *** Storing these values, we have: 4289 HEADER(12,1) = 1*16 + 2 4290 HEADER(12,2) = 5*16 + 0 4291 HEADER(12,3) = 4*16 + 7 4292 HEADER(12,4) = 5*16 + 0 4293 HEADER(13,1) = 4*16 + 12 4294 HEADER(13,2) = 4*16 + 15 4295 HEADER(13,3) = 5*16 + 4 4296 HEADER(13,4) = 2*16 + 0 4297 HEADER(14,1) = 4*16 + 2 4298 HEADER(14,2) = 4*16 + 9 4299 HEADER(14,3) = 5*16 + 4 4300 HEADER(14,4) = 4*16 + 13 4301 HEADER(15,1) = 4*16 + 1 4302 HEADER(15,2) = 5*16 + 0 4303 HEADER(15,3) = 2*16 + 0 4304 HEADER(15,4) = 4*16 + 4 4305 HEADER(16,1) = 4*16 + 1 4306 HEADER(16,2) = 5*16 + 4 4307 HEADER(16,3) = 4*16 + 1 4308 HEADER(16,4) = 0 4309C *** Note: I'm not sure what HEADER[17] accomplishes. I have NOT used it. 4310C *** If it is to be used, then the Dimension of HEADER must be increased, 4311C *** and the value written to the TFM file describing the length of 4312C *** the HEADER array must be increased. 4313C *** 4314C *** Now write out the store HEADER array to the TFM file. 4315 DO 40, I = 0,16 4316 DO 30, J=1,4 4317 CALL GRTX12(ITFMUN,HEADER(I,J)) 431830 CONTINUE 431940 CONTINUE 4320C *** 4321C *** 4322C *** Now write the previously stored char_info array, CHINFO, to the TFM file. 4323 DO 60, I =BC, BC+NC 4324 DO 50, J=1,4 4325 CALL GRTX12(ITFMUN,CHINFO(I,J)) 432650 CONTINUE 432760 CONTINUE 4328C *** 4329C *** 4330C *** Now write the previously store character width lookup array, WIDTH, 4331C *** to the TFM file. 4332 DO 80, I = 0, NC+1 4333 DO 70, J=1,4 4334 CALL GRTX12(ITFMUN,WIDTH(I,J)) 433570 CONTINUE 433680 CONTINUE 4337C *** 4338C *** 4339C *** Now write the previosly stored character height lookup array, HEIGHT, 4340C *** to the TFM file. 4341 DO 100, I= 0, NC+1 4342 DO 90, J=1,4 4343 CALL GRTX12(ITFMUN,HEIGHT(I,J)) 434490 CONTINUE 4345100 CONTINUE 4346C *** 4347C *** 4348C *** Now write the character depth lookup array. 4349C *** Note: WIDTH[0]=HEIGHT[0]=DEPTH[0]=ITALIC[0]=0 is required by TFM 4350C *** file specifications. 4351 DO 110, I=1,4 4352 BYTOUT = 0 4353 CALL GRTX12(ITFMUN,BYTOUT) 4354110 CONTINUE 4355C *** 4356C *** Now write the character italic lookup array. 4357C *** Note: WIDTH[0]=HEIGHT[0]=DEPTH[0]=ITALIC[0]=0 is required by TFM 4358C *** file specifications. 4359 DO 111, I=1,4 4360 BYTOUT = 0 4361 CALL GRTX12(ITFMUN,BYTOUT) 4362111 CONTINUE 4363C *** 4364C *** Character LIG/KERN lookup table would have normally been written out here. 4365C *** However, there are no entries in our table. I ommitted this table. 4366C *** 4367C *** 4368C *** Character KERN lookup table would have normally been written out here. 4369C *** However, there are no entries in our table. I ommitted this table. 4370C *** 4371C *** 4372C *** Extensible character lookup table would have normally been written out 4373C *** here. However, there are no entries in our table. I ommitted this table. 4374C *** 4375C *** 4376C *** Now, write out the character PARAM array of Fix_words. 4377C *** PARAM[1]=italic_slant = 00000000 (0.0) is the amount of italic slant. 4378C *** PARAM[2]=space = 00001000 (0.001 design-size units = 1.0 TeX points 4379C *** which approximately=0.0138 inches) is the normal 4380C *** spacing between words in the text I arbitrarily chose. 4381C *** PARAM[3]=space_stretch = 00000000 (0.0) is the glue stretching 4382C *** between words of the text. 4383C *** PARAM[4]=space_shrink = 00000000 (0.0) is the glue shrinking 4384C *** between words of the text. 4385C *** PARAM[5]=x_height = 00000000 (0.0) is the height of letters for 4386C *** which accents don't have to be raised. 4387C *** PARAM[6]=quad= 00001000 (0.001 design-size units = 1.0 TeX points 4388C *** which approximately=0.0138 inches) is the size 4389C *** I chose for one "em" in this Font. This was an 4390C *** arbitrary choice. I do not believe this parameter 4391C *** will be used--- but just in case... 4392C *** PARAM[7]=extra_space = 00000000 (0.0) is the amount added to 4393C *** PARAM[2] at the ends of sentences. 4394C *** 4395C *** Writing out these values for the PARAM array, 4396C *** for PARAM[1] we have: 4397 DO 120, I = 1,4 4398 BYTOUT = 0 4399 CALL GRTX12(ITFMUN,BYTOUT) 4400120 CONTINUE 4401C *** for PARAM[2] we have: 4402 BYTOUT = 0 4403 CALL GRTX12(ITFMUN,BYTOUT) 4404 BYTOUT = 0 4405 CALL GRTX12(ITFMUN,BYTOUT) 4406 BYTOUT = 1*16 + 0 4407 CALL GRTX12(ITFMUN,BYTOUT) 4408 BYTOUT = 0 4409 CALL GRTX12(ITFMUN,BYTOUT) 4410C *** for PARAM[3] we have: 4411 DO 130, I = 1,4 4412 BYTOUT = 0 4413 CALL GRTX12(ITFMUN,BYTOUT) 4414130 CONTINUE 4415C *** for PARAM[4] we have: 4416 DO 140, I = 1,4 4417 BYTOUT = 0 4418 CALL GRTX12(ITFMUN,BYTOUT) 4419140 CONTINUE 4420C *** for PARAM[5] we have: 4421 DO 150, I = 1,4 4422 BYTOUT = 0 4423 CALL GRTX12(ITFMUN,BYTOUT) 4424150 CONTINUE 4425C *** for PARAM[6] we have: 4426 BYTOUT = 0 4427 CALL GRTX12(ITFMUN,BYTOUT) 4428 BYTOUT = 0 4429 CALL GRTX12(ITFMUN,BYTOUT) 4430 BYTOUT = 1*16 + 0 4431 CALL GRTX12(ITFMUN,BYTOUT) 4432 BYTOUT = 0 4433 CALL GRTX12(ITFMUN,BYTOUT) 4434C *** for PARAM[7] we have: 4435 DO 160, I = 1,4 4436 BYTOUT = 0 4437 CALL GRTX12(ITFMUN,BYTOUT) 4438160 CONTINUE 4439C *** 4440C *** 4441C *** 4442C *** =================================================================== 4443C *** Finish writing the 512 byte record block on the Vax with 0's. 4444C *** Note: TFM files do not require this...I just wanted to fill the 4445C *** record (and block) on out, and I chose 0 to do this. 4446 DO 500, I=LF*4+1,512 4447 BYTOUT=0 4448 CALL GRTX12(ITFMUN,BYTOUT) 4449500 CONTINUE 4450C *** 4451 RETURN 4452 END 4453C<FF> 4454C *GRTX11 -- PGPLOT buffering of PK file byte writes until 512 bytes buffered. 4455C 4456 SUBROUTINE GRTX11 (ILUNIT,BYTOUT) 4457C *** ------------------------------------------------------------------ 4458C *** PK file writes... 4459C *** ---------------------------------------------------------------- 4460C *** The purpose of this file is to provide buffering of the writes 4461C *** to the output PK file until 512 bytes can be written out together 4462C *** as one record. 4463C *** ILUNIT is the unit number of the output file. 4464C *** BYTOUT is the byte sent to be buffered up for the record write. 4465C *** This routine requires the SAVE statement. The variables 4466C *** BUFFER and IBFIND must retain their values upon successive 4467C *** calls!. 4468C *** PORTABILITY NOTES: 4469C *** This routine is system dependent. On a vax, a byte ranges from 4470C *** -128 to 127 in decimal representation (For a Vax byte, 4471C *** -128base10 is FF in hex) (For a Vax byte, 127base10 is 7F in hex). 4472C *** So {[0,255]base10 integer } gets mapped to {[0,FF]base16 byte}, 4473C *** which is interpreted as: 4474C *** {[0,127]base10 integer } getting mapped to {[0,127]base10 byte} 4475C *** while {[128,255]base10 integer} getting mapped 4476C *** to {[-128,-1]base10 byte}. 4477C *** Also, you may have to change the write statement below. 4478C *** in *UNIX we are after "bytes on the disk" without any record 4479C *** attributes in the middle of the record. Under *VMS I expect 4480C *** RMS to take care of so that we get "bytes on the disk" appearance. 4481C *** Routine GRTX12 also has this write statement that may need to 4482C *** be modified. 4483C---------------------------------------------------------------------- 4484C *** 4485 IMPLICIT NONE 4486 SAVE 4487 INTEGER ILUNIT, IBFIND, I, BYTOUT, CONVBY,IRECRD 4488 BYTE BUFFER(512) 4489C *** ------------------------------------------------------------ 4490C *** Initialize some values to be set before the first time this 4491C *** routine is entered. After the routine is entered, the values 4492C *** will be changed and will retain their new "changed" values 4493C *** upon successive calls to this routine. 4494C *** 4495 DATA BUFFER /512*0/ 4496 DATA IBFIND /1/ 4497 DATA IRECRD /1/ 4498C *** 4499C *** ------------------------------------------------------------ 4500C *** Convert the desired output value, BYTOUT, from its integer 4501C *** form to the Vax_specific_required_signed_output form for 4502C *** outputing a byte value, CONVBY. PORTABILITY NOTE: 4503C *** This will very likely be different on different machines. 4504C *** If the byte quantity is NOT signed on your machine, then 4505C *** you should change the line CONVBY=BYTOUT-256 to 4506C *** CONVBY=BYTOUT below!!!!. 4507C *** 4508 IF(BYTOUT.GT.127) THEN 4509 CONVBY=BYTOUT-256 4510 ELSE 4511 CONVBY=BYTOUT 4512 ENDIF 4513C *** 4514C *** Store the current byte that is to be output to the file. 4515 BUFFER(IBFIND)=CONVBY 4516 IF(MOD(IBFIND,512).EQ.0) THEN 4517C *** We have buffered up 512 bytes. Time to write out a record 4518C *** to the PK file and reset the buffer index IBFIND. 4519C *** *VMS 4520C *** If you have problems, you may want to try to change 4521C *** this to a sequential write on the VAX. Routine GRTX12 4522C *** also has a write statement like the one below. 4523 WRITE(UNIT=ILUNIT,REC=IRECRD,ERR=1000) (BUFFER(I),I=1,512) 4524 IRECRD=IRECRD+1 4525 IBFIND=0 4526 ENDIF 4527C *** 4528C *** Increment the buffer index to the next element of the buffer. 4529 IBFIND=IBFIND+1 4530C *** 4531C *** --------------------------------------------------------------- 4532C *** Return to the calling routine. 4533C *** 4534C----------------------------------------------------------------------- 4535 RETURN 45361000 CONTINUE 4537 CALL GRWARN('ERROR writing to the PK Font file.') 4538 CALL GRQUIT('EXITING to operating system. Routine GRTX11.') 4539 STOP 4540C *** ----------------------- 4541 ENTRY GRTX14 4542C *** This part of GRTX11,GRTX14 is to reinitialze the file pointers 4543C *** to the beginning of a new file. 4544 DO 1500, I=1,512 4545 BUFFER(I)=0 45461500 CONTINUE 4547 IBFIND=1 4548 IRECRD=1 4549 RETURN 4550 END 4551C<FF> 4552C *GRTX12 -- PGPLOT buffering of TFM file byte writes until 512 bytes buffered. 4553C 4554 SUBROUTINE GRTX12 (ILUNIT,BYTOUT) 4555C *** ------------------------------------------------------------------ 4556C *** TFM file writes... 4557C *** ---------------------------------------------------------------- 4558C *** The purpose of this file is to provide buffering of the writes 4559C *** to the output TFM file until 512 bytes can be written out together 4560C *** as one record. 4561C *** ILUNIT is the unit number of the output file. 4562C *** BYTOUT is the byte sent to be buffered up for the record write. 4563C *** This routine requires the SAVE statement. The variables 4564C *** BUFFER and IBFIND must retain their values upon successive 4565C *** calls!. 4566C *** PORTABILITY NOTES: 4567C *** This routine is system dependent. On a vax, a byte ranges from 4568C *** -128 to 127 in decimal representation (For a Vax byte, 4569C *** -128base10 is FF in hex) (For a Vax byte, 127base10 is 7F in hex). 4570C *** So {[0,255]base10 integer } gets mapped to {[0,FF]base16 byte}, 4571C *** which is interpreted as: 4572C *** {[0,127]base10 integer } getting mapped to {[0,127]base10 byte} 4573C *** while {[128,255]base10 integer} getting mapped 4574C *** to {[-128,-1]base10 byte}. 4575C *** Also, in *UNIX we want "bytes on the disk" with no interspersed 4576C *** record information. Under *VMS I beileve that RMS will give us 4577C *** the appearance of "bytes on the disk". You may have to 4578C *** change this routine and routines GRTX11 in order to get 4579C *** a stream of bytes on the disk without any record control information 4580C *** interspersed in your file. 4581C---------------------------------------------------------------------- 4582C *** 4583 IMPLICIT NONE 4584 SAVE 4585 INTEGER ILUNIT, IBFIND, I, BYTOUT, CONVBY,IRECRD 4586 BYTE BUFFER(512) 4587C *** ------------------------------------------------------------ 4588C *** Initialize some values to be set before the first time this 4589C *** routine is entered. After the routine is entered, the values 4590C *** will be changed and will retain their new "changed" values 4591C *** upon successive calls to this routine. 4592C *** 4593 DATA BUFFER /512*0/ 4594 DATA IBFIND /1/ 4595 DATA IRECRD /1/ 4596C *** 4597C *** ------------------------------------------------------------ 4598C *** Convert the desired output value, BYTOUT, from its integer 4599C *** form to the Vax_specific_required_signed_output form for 4600C *** outputing a byte value, CONVBY. PORTABILITY NOTE: 4601C *** This will very likely be different on different machines. 4602C *** If the byte quantity is NOT signed on your machine, then 4603C *** you should change the line CONVBY=BYTOUT-256 to 4604C *** CONVBY=BYTOUT below!!!!. 4605C *** 4606 IF(BYTOUT.GT.127) THEN 4607 CONVBY=BYTOUT-256 4608 ELSE 4609 CONVBY=BYTOUT 4610 ENDIF 4611C *** 4612C *** Store the current byte that is to be output to the file. 4613 BUFFER(IBFIND)=CONVBY 4614 IF(MOD(IBFIND,512).EQ.0) THEN 4615C *** We have buffered up 512 bytes. Time to write out a record 4616C *** to the TFM file and reset the buffer index IBFIND. 4617C *** Under *VMS you may have to change this to a sequential 4618C *** write. It seems to work okay for our DVI driver as direct 4619C *** access. However, the original PK and TFM font files we have 4620C *** look like sequential access. This line also appears in 4621C *** routine GRTX11. 4622 WRITE(UNIT=ILUNIT,REC=IRECRD,ERR=1000) (BUFFER(I),I=1,512) 4623 IRECRD=IRECRD+1 4624 IBFIND=0 4625 ENDIF 4626C *** 4627C *** Increment the buffer index to the next element of the buffer. 4628 IBFIND=IBFIND+1 4629C *** 4630C *** --------------------------------------------------------------- 4631C *** Return to the calling routine. 4632C *** 4633C----------------------------------------------------------------------- 4634 RETURN 46351000 CONTINUE 4636 CALL GRWARN('ERROR writing to the TFM Font file.') 4637 CALL GRQUIT('EXITING to operating system. Routine GRTX12.') 4638 STOP 4639C *** ----------------------- 4640 ENTRY GRTX15 4641C *** This part of GRTX12,GRTX15 is to reinitialze the file pointers 4642C *** to the beginning of a new file. 4643 DO 1500, I=1,512 4644 BUFFER(I)=0 46451500 CONTINUE 4646 IBFIND=1 4647 IRECRD=1 4648 RETURN 4649 END 4650C<FF> 4651C *GRTX13 -- TXDRIV routine to zero out the BITMAP array. 4652C 4653 SUBROUTINE GRTX13 ( ISIZE , BITMAP, BYTVAL) 4654C *** called by "CALL GRTX13 (BX*BY, %VAL(BITMAP),'00'X)" 4655 IMPLICIT NONE 4656 INTEGER ISIZE, I 4657 BYTE BITMAP(ISIZE),BYTVAL 4658C -------------------------- 4659 DO 100, I=1, ISIZE 4660 BITMAP(I)=BYTVAL 4661100 CONTINUE 4662 RETURN 4663 END 4664