SUBROUTINE hpDRIV(IFUNC,RBUF,NBUF,CHR,LCHR) integer IFUNC, NBUF,LCHR REAL RBUF(*) CHARACTER*45 CHR integer ixdim,iydim,lenbuf,ICOL include "driv.inc" data ixdim,iydim,lenbuf,lun,ICOL/292, 3200, 934400,99,0/ if(ifunc.eq.28)goto 280 GOTO( 10, 20, 30, 40, 50, 60, 70,999, 90,100, & 110,120,130,140,150) IFUNC GOTO 999 C--- IFUNC= 1, Return device name. C 10 CHR='HP (jiang, portrait for hp_printer)' ! NBUF=0 LCHR=LEN(CHR) RETURN C--- IFUNC= 2, Return Physical min and max for plot device. 20 RBUF(1)=0 RBUF(2)=2335 ! RBUF(3)=0 RBUF(4)=3199 ! RBUF(5)=0 RBUF(6)=1 NBUF=6 LCHR = 0 RETURN C--- IFUNC= 3, Return device (X and Y) resolution in pixels per inch as 30 RBUF(1)=300.0 RBUF(2)=300.0 RBUF(3)=1 NBUF=3 LCHR=0 RETURN C--- IFUNC= 4, Return misc device info. 40 CHR='HNNNNNNNNN' NBUF =0 LCHR=10 RETURN C--- IFUNC= 5, Return default file name. 50 CHR='pgplot.hp' NBUF=0 LCHR=LEN(CHR) RETURN C--- IFUNC= 6, Return default physical size of plot. 60 RBUF(1)=0 RBUF(2)=2335 ! RBUF(3)=0 RBUF(4)=3199 ! NBUF=4 LCHR=0 RETURN C--- IFUNC= 7, Return misc defaults. 70 RBUF(1)=1 NBUF=1 LCHR=0 RETURN C--- IFUNC= 9, Open workstation. 90 CALL grglun(lun) call unlink(CHR(:LCHR)) OPEN(UNIT=lun,FILE=CHR(:LCHR),STATUS='NEW',IOSTAT=IER) IF(IER.NE.0) THEN CALL GRWARN('Cannot open graphics device '//CHR(:LCHR)) RBUF(1)=lun RBUF(2)=0 close (lun) goto 999 ELSE RBUF(1)=0 RBUF(2)=1 END IF call hpbuf0(934400,PIXMAP) RETURN C--- IFUNC=10, Close workstation. 100 close (lun) RETURN C--- IFUNC=11, Begin Picture. Note, IXMIN=0 and IXMAX=RBUF(1) so, C--- IXDIM=IXMAX-IXMIN+1=RBUF(1)+1 110 IxDIM=INT(RBUF(1)/8.)+1 IyDIM=RBUF(2)+1 LENBUF=IxDIM*IyDIM call grhp02(PIXMAP,lenbuf) RETURN C--- IFUNC=12, Draw line. 120 continue CALL GRhp01(1,RBUF,ICOL,IxDIM,PIXMAP) RETURN C--- IFUNC=13, Draw dot. 130 CALL GRhp01(0,RBUF,ICOL,IxDIM,PIXMAP) RETURN C--- IFUNC=14, End picture. 140 CALL GRhp04(LUN,PIXMAP,IxDIM,IyDIM) RETURN C--- IFUNC=15, Select pen. Save pen number (up to 11) for C--- possible use in pattern interior. 150 ICOL=MAX(0,MIN(NINT(RBUF(1)),11)) RBUF(1)=MAX(0,MIN(ICOL,1)) RETURN C--- Flag function not implemented. 999 NBUF=-1 RETURN c for gray scale raster 280 call grhp03(rbuf,ixdim,PIXMAP) return END subroutine hpbuf0(k,buf) byte buf(1) do i=1,k buf(i)=0 enddo end SUBROUTINE GRhp01(LINE,RBUFI,ICOL,IXDIM,QXYBUF) ! integer*2 qxybuf(0:*),qmask(0:15),i2 REAL RBUFI(4),RBUF(4) DATA QMASK /32768,16384,8192,4096, * 2048,1024,512,256,128,64,32,16,8,4,2,1/ c write(*,*)line,rbufi,icol,ixdim RBUF(1)=rbufi(1) RBUF(2)=3199-rbufi(2) RBUF(3)=rbufi(3) RBUF(4)=3199-rbufi(4) ixd2=ixdim/2 IF(LINE.GT.0) THEN LENGTH=NINT(MAX(ABS(RBUF(3)-RBUF(1)), & ABS(RBUF(4)-RBUF(2)))) D = MAX(1,LENGTH) XINC = (RBUF(3)-RBUF(1))/D YINC = (RBUF(4)-RBUF(2))/D ELSE LENGTH=0 XINC=0. YINC=0. END IF XP = RBUF(1) YP = RBUF(2) IF (ICOL.GT.0) THEN DO K=0,LENGTH KX = NINT(XP) KY = NINT(YP) kk=ky*ixd2+kx/16 QXYBUF(kk) = IOR(QXYBUF(kk),QMASK(MOD(Kx,16))) XP = XP + XINC YP = YP + YINC END DO ELSE DO K=0,LENGTH KX = NINT(XP) KY = NINT(YP) kk=ky*ixd2+kx/16 i2= nnot(QMASK(MOD(kx,16))) QXYBUF(kk) = IAND(QXYBUF(kk),i2) XP = XP + XINC YP = YP + YINC END DO END IF RETURN END subroutine grhp02(buf,n) integer*2 buf(1) do 10 i=1,n/2 10 buf(i)=0 end subroutine grhp03(rbuf,ixdim,qxybuf) integer*2 qxybuf(0:*),qmask(0:15) integer*2 ii(18),jj(18),ix,iy REAL RBUF(*) DATA QMASK /32768,16384,8192,4096, * 2048,1024,512,256,128,64,32,16,8,4,2,1/ data ii/0,0,1,0,-1,1,1,2,-1,-1,-2,0,0,2,-2,1,-1,0/ data jj/0,1,0,-1,0,1,-1,0,1,-1,0,2,-2,1,1,2,2,3/ ixd2=ixdim/2 ix= rbuf(1) iy= 3199-rbuf(2) kz= nint(rbuf(3)) if(kz.lt.1)return is=nint(rbuf(4)) if(kz.gt.is)kz=is do 10 i=1,kz kx=ix+ii(i) ky=iy+jj(i) kk=ky*ixd2+kx/16 10 QXYBUF(kk) = IOR(QXYBUF(kk),QMASK(MOD(Kx,16))) END SUBROUTINE GRhp04(LUN,QBUF,IXDIM,IYDIM) BYTE QBUF(ixdim,iydim),a(300) character c*300,c_line*9,c_row*5,c_head*12,c_end*4 byte init_hp(17),end_hp(5),v_line(9), * h_row(5),line_head(12),line_end(4) equivalence (c,a),(c_line,v_line),(c_row,h_row), * (c_head,line_head),(c_end,line_end) data init_hp/32,32,27,69,27,42,112,43,49,89, ! init&.5 inch from top * 27,42,116,51,48,48,82/ ! 300 dots/inch data v_line/27,42,112,43,5*0/ ! down # pixel data h_row /5*0/ ! right_shift # pixel data line_head/27,42,114,49,65, ! current curcor * 27,42,98,3*0,87/ ! raster nnn bytes data line_end/27,42,114,66/ ! end line's raster data end_hp/27,38,108,48,72/ ! eject paper call swap2(qbuf,ixdim*iydim) write(lun,'(17a1,$)')init_hp jj=0 do 10 j=1,iydim do 15 i=1,ixdim if(qbuf(i,j).ne.0)goto 16 15 continue 16 ii=i-1 l=5 i=ii*8 if(i.lt.1000)l=4 if(i.lt.100)l=3 if(i.lt.10)l=2 c write(c_row(1:),'(i)')i if(l.eq.5)write(c_row(1:),'(i4)')i if(l.eq.4)write(c_row(1:),'(i3)')i if(l.eq.3)write(c_row(1:),'(i2)')i if(l.eq.2)write(c_row(1:),'(i1)')i h_row(l)=88 do 20 i=1,ixdim-ii 20 a(i)=qbuf(i+ii,j) do 30 i=ixdim-ii,1,-1 if(a(i).ne.0)goto 40 30 continue 40 k=i if(k.ne.0)then write(c_head(9:),'(i3.3)')k line_head(12)=87 m=9 if(jj.lt.1000)m=8 if(jj.lt.100)m=7 if(jj.lt.10)m=6 c write(c_line(5:),'(i)')jj if(m.eq.9)write(c_line(5:),'(i4)')jj if(m.eq.8)write(c_line(5:),'(i3)')jj if(m.eq.7)write(c_line(5:),'(i2)')jj if(m.eq.6)write(c_line(5:),'(i1)')jj v_line(m)=121 write(lun,'(5a,$)')c_line(1:m),c_row(1:l),c_head,c(1:k),c_end jj=0 else jj=jj+1 endif 10 continue write(lun,'(5a1,$)')end_hp END function nnot(a) integer*2 a nnot=65535-a end