C*LHDRIV -- PGPLOT device driver for MS-DOS machines running Lahey F77 C 32-bit FORTRAN C+ SUBROUTINE LHDRIV (IFUNC, RBUF, NBUF, CHR, LCHR) IMPLICIT NONE INTEGER IFUNC, NBUF, LCHR REAL RBUF(*) CHARACTER*(*) CHR C C PGPLOT driver for IBM PC's and clones running Lahey F77 32-bit Fortran v5.0. C This driver will put the display into graphics mode, and calls to 'close' C the workstation will set it back into the previous mode (generally erasing C the display, so don't do it until you are really finished). C C This routine must be compiled and linked with the Lahey graphics C library GRAPH3 supplied with Lahey Fortran v4.0 or greater. C C Microsoft FORTRAN versions: C 1989-Nov-03 - Started work [AFT] C 1989-Apr-06 - Improved version [AFT] C 1991-Mar-13 - Added cursor routine [JHT] C Lahey FORTRAN versions: C 1991-Dec-28 - derived from Microsoft version [PAH] C----------------------------------------------------------------------- C C Supported device: IBM PC's and compatables C C Device type code: /LH C C Default device name: None (the device name, if specified, is C ignored). C C Default view surface dimensions: Depends on monitor, typical 7x10 inches C C Resolution: Depends on graphics card. Tested with a 640x480 VGA card. C Driver should work with other graphics cards, however, expect to C tweak it a bit. C C Color capability: Color indices 0-15 are accepted. This version maps C the PGPLOT color indices into the IBM color indices for with the C default color most closely corresponds to the PGPLOT default color. C Thus, PGPLOT index 2 (red) maps to IBM index 12 (light red). C C Input capability: Graphics cursor implemented using Microsoft Mouse C or compatible, accessed through DOS calls. C C File format: None. C C Obtaining hardcopy: Not possible. C----------------------------------------------------------------------- CHARACTER CMSG*10 REAL A,B real xfac, yfac parameter (xfac=11.0/640.0, yfac=8.5/480.0) integer pencolour, pend, colourmap(0:15), ix, iy logical got_mouse save pencolour, pend DATA colourmap/ 0,15,12,10, 9,11,13,14, 6, 2, 3, 1, 5, 4, 8, 7/ C--- GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, 1 110,120,130,140,150,160,170,180,190,200, 2 210,220,230,240,250,260) IFUNC 900 WRITE (CMSG, '(I10)') IFUNC CALL GRWARN('Unimplemented function in LAHEY device driver: '/ : /CMSG) NBUF = -1 RETURN C C--- IFUNC = 1, Return device name.------------------------------------- C 10 CHR = 'LH' LCHR = 2 RETURN C C--- IFUNC = 2, Return physical min and max for plot device, and range C of color indices.--------------------------------------- C 20 CONTINUE RBUF(1) = 0 RBUF(2) = 640.0 RBUF(3) = 0 RBUF(4) = 480.0 RBUF(5) = 0 RBUF(6) = 15.0 NBUF = 6 RETURN C C--- IFUNC = 3, Return device resolution. ------------------------------ C Divide the number of pixels on screen by a typical screen size in C inches. C 30 continue A = 640.0/9.5 RBUF(1) = A B = 480.0/7.5 RBUF(2) = B RBUF(3) = 1.0 NBUF = 3 RETURN C C--- IFUNC = 4, Return misc device info. ------------------------------- C (This device is Interactive, No cursor, No dashed lines, No area fill, C No thick lines, No rectangle fill, No pixel primitives,) C 40 continue if (got_mouse()) then CHR = 'ICNNNNNNNN' else CHR = 'INNNNNNNNN' endif LCHR = 10 RETURN C C--- IFUNC = 5, Return default file name. ------------------------------ C 50 CHR = ' ' LCHR = 1 RETURN C C--- IFUNC = 6, Return default physical size of plot. ------------------ C 60 CONTINUE RBUF(1) = 0 RBUF(2) = 640.0 RBUF(3) = 0 RBUF(4) = 480.0 NBUF = 4 RETURN C C--- IFUNC = 7, Return misc defaults. ---------------------------------- C 70 RBUF(1) = 1 NBUF = 1 RETURN C C--- IFUNC = 8, Select plot. ------------------------------------------- C 80 CONTINUE RETURN C C--- IFUNC = 9, Open workstation. -------------------------------------- C 90 CONTINUE RBUF(1) = 0 RBUF(2) = 1 NBUF = 2 IF(RBUF(3) .NE. 0.0) THEN PEND=1 ELSE PEND=0 END IF CALL PLOTS(0, 0, 18) RETURN C C--- IFUNC=10, Close workstation. -------------------------------------- C 100 CONTINUE CALL PLOT(0, 0, 999) RETURN C C--- IFUNC=11, Begin picture. ------------------------------------------ C 110 CONTINUE IF(PEND.EQ.0) THEN CALL PLOT(0, 0, -999) ENDIF PEND=0 RETURN C C--- IFUNC=12, Draw line. ---------------------------------------------- C 120 CONTINUE CALL PLOT(RBUF(1)*xfac, RBUF(2)*yfac, 3) CALL PLOT(RBUF(3)*xfac, RBUF(4)*yfac, 2) RETURN C C--- IFUNC=13, Draw dot. ----------------------------------------------- C 130 CONTINUE CALL SETPIX(RBUF(1)*xfac, RBUF(2)*yfac, pencolour) RETURN C C--- IFUNC=14, End picture. -------------------------------------------- C 140 CONTINUE IF (RBUF(1) .NE. 0.0) THEN CALL PLOT(0.0, 0.0, -999) ENDIF RETURN C C--- IFUNC=15, Select color index. ------------------------------------- 150 CONTINUE pencolour=MIN( MAX(0,NINT(RBUF(1))) ,15) pencolour=colourmap(pencolour) CALL NEWPEN(pencolour) RETURN C C--- IFUNC=16, Flush buffer. ------------------------------------------- C 160 CONTINUE RETURN C C--- IFUNC=17, Read cursor. -------------------------------------------- C C 170 CONTINUE ix = nint(rbuf(1)) iy = 479-nint(rbuf(2)) call show_mouse call put_mouse(ix,iy) call cursor_key(ix,iy,chr) rbuf(1) = ix rbuf(2) = 479-iy call hide_mouse RETURN C C--- IFUNC=18, Erase alpha screen. ------------------------------------- C 180 CONTINUE RETURN C C--- IFUNC=19, Set line style. ----------------------------------------- C 190 CONTINUE RETURN C C--- IFUNC=20, Polygon fill. ------------------------------------------- C 200 CONTINUE RETURN C C--- IFUNC=21, Set color representation. ------------------------------- C 210 CONTINUE RETURN C C--- IFUNC=22, Set line width. ----------------------------------------- C 220 CONTINUE RETURN C C--- IFUNC=23, Escape. ------------------------------------------------- C 230 CONTINUE RETURN C C--- IFUNC=24, Rectangle fill. ----------------------------------------- C 240 CONTINUE RETURN C C--- IFUNC=25, Set fill pattern. --------------------------------------- C 250 CONTINUE RETURN C C--- IFUNC=26, Line of pixels. ----------------------------------------- C 260 CONTINUE RETURN C----------------------------------------------------------------------- END logical function got_mouse() implicit none integer*2 ntrup integer intary(9), eax equivalence (eax,intary(1)) eax = 0 ntrup = 51 call intrup(intary,ntrup) got_mouse = (eax .eq. 65535) return end subroutine show_mouse implicit none integer*2 ntrup integer intary(9), eax equivalence (eax,intary(1)) eax = 1 ntrup = 51 call intrup(intary,ntrup) return end subroutine hide_mouse implicit none integer*2 ntrup integer intary(9), eax equivalence (eax,intary(1)) eax = 2 ntrup = 51 call intrup(intary,ntrup) return end subroutine get_mouse(ix, iy, button) implicit none integer ix, iy, button integer*2 ntrup integer intary(9), eax integer*2 bx, cx, dx equivalence (eax,intary(1)), - (bx,intary(2)), - (cx,intary(3)), - (dx,intary(4)) eax = 3 ntrup = 51 call intrup(intary,ntrup) ix = cx iy = dx button = bx return end subroutine put_mouse(ix, iy) implicit none integer ix, iy integer*2 ntrup integer intary(9), eax integer*2 bx, cx, dx equivalence (eax,intary(1)), - (bx,intary(2)), - (cx,intary(3)), - (dx,intary(4)) eax = 4 cx = ix dx = iy ntrup = 51 call intrup(intary, ntrup) return end subroutine cursor_key(ix, iy, key) implicit none character*(*) key integer ix, iy, ikey, ib integer*2 ixkey ikey = ixkey() key = char(ikey) call get_mouse(ix, iy, ib) return end