331 lines
12 KiB
Fortran
331 lines
12 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C PCDRAW -- PC Graphics package using the library supplied with
|
|
C MS FORTRAN version 5.0
|
|
C
|
|
C Version for DIFRAC. Supports a graphics window as well as two
|
|
C text windows, one for commands and the other for use by HKLN
|
|
C-----------------------------------------------------------------------
|
|
include 'fgraph.fi'
|
|
SUBROUTINE PCDRAW (IFUNC,IX,IY,IZ,STRING)
|
|
include 'fgraph.fd'
|
|
include 'COMDIF'
|
|
integer ifunc, ix, iy, iz
|
|
character string*(*)
|
|
C-----------------------------------------------------------------------
|
|
C Definitions for the graphics package, these may not be standard
|
|
C Fortran
|
|
C-----------------------------------------------------------------------
|
|
integer*2 result,
|
|
$ irt(3),ict(3),irb(3),icb(3),
|
|
$ RED,BLUE,WHITE,CYAN,
|
|
$ irow,icol
|
|
common /pclocl/ irt,ict,irb,icb,ntextw
|
|
record /videoconfig/ screen
|
|
double precision wx,wy
|
|
record /wxycoord/ wprev
|
|
record /rccoord/ cursor,cursor2,tcoords
|
|
logical first
|
|
data first /.true./
|
|
data RED,BLUE,WHITE,CYAN/4,1,15,3/
|
|
C-----------------------------------------------------------------------
|
|
C XOPEN Initialise the display
|
|
C-----------------------------------------------------------------------
|
|
if (IFUNC .eq. XOPEN) then
|
|
C-----------------------------------------------------------------------
|
|
C -- Find the graphics mode
|
|
C-----------------------------------------------------------------------
|
|
call getvideoconfig (screen)
|
|
select case (screen.adapter)
|
|
case ($CGA)
|
|
result = setvideomode ($HRESBW)
|
|
termgr = 'CGA'
|
|
case ($OCGA)
|
|
result = setvideomode ($ORESCOLOR)
|
|
termgr = 'OCGA'
|
|
case ($EGA,$OEGA)
|
|
if (screen.monitor .eq. $MONO) then
|
|
result = setvideomode (ERESNOCOLOR)
|
|
termgr = 'EGAM'
|
|
else
|
|
result = setvideomode ($ERESCOLOR)
|
|
termgr = 'EGA'
|
|
endif
|
|
case ($HGC)
|
|
result = setvideomode ($HERCMONO)
|
|
termgr = 'HERC'
|
|
case ($MCGA)
|
|
result = setvideomode ($VRES2COLOR)
|
|
termgr = 'MCGA'
|
|
case ($VGA,$OVGA)
|
|
result = setvideomode ($VRES16COLOR)
|
|
termgr = 'VGA'
|
|
case DEFAULT
|
|
result = 0
|
|
end select
|
|
if (result .eq. 0) STOP 'ERROR: Unsupported graphics adaptor'
|
|
C-----------------------------------------------------------------------
|
|
C -- Now we can find out some dimensions
|
|
C-----------------------------------------------------------------------
|
|
call getvideoconfig (screen)
|
|
edxres = screen.numxpixels
|
|
edyres = screen.numypixels
|
|
nrows = screen.numtextrows
|
|
ncols = screen.numtextcols
|
|
C-----------------------------------------------------------------------
|
|
C -- And setup the default colour scheme
|
|
C-----------------------------------------------------------------------
|
|
result = setbkcolor ($BLUE)
|
|
result = setcolor (WHITE)
|
|
call clearscreen ($GCLEARSCREEN)
|
|
C-----------------------------------------------------------------------
|
|
C -- For now define text window 1 as the top three lines of the screen
|
|
C-----------------------------------------------------------------------
|
|
irt(1) = 1
|
|
irb(1) = 3
|
|
ict(1) = 1
|
|
icb(1) = ncols
|
|
call settextwindow (irt(1),ict(1),irb(1),icb(1))
|
|
call clearscreen ($GWINDOW)
|
|
call settextwindow (irt(1),ict(1),irb(1)+1,icb(1))
|
|
do 100 i = 2,79
|
|
win1bf(1)(i:i) = char(205)
|
|
win1bf(3)(i:i) = char(205)
|
|
100 continue
|
|
win1bf(2) = ' '
|
|
win1bf(1)(1:1) = char(201)
|
|
win1bf(1)(ncols:ncols) = char(187)
|
|
win1bf(2)(1:1) = char(186)
|
|
win1bf(2)(ncols:ncols) = char(186)
|
|
win1bf(3)(1:1) = char(200)
|
|
win1bf(3)(ncols:ncols) = char(188)
|
|
win1bf(2)(3:14) = 'D I F R A C '
|
|
do 110 i = 1,3
|
|
call settextposition (i,1,cursor)
|
|
call outtext (win1bf(i))
|
|
110 continue
|
|
C-----------------------------------------------------------------------
|
|
C And setup the constants for a second text window which is the
|
|
C normal command window
|
|
C-----------------------------------------------------------------------
|
|
irt(2) = nrows - 6
|
|
irb(2) = nrows
|
|
ict(2) = 1
|
|
icb(2) = ncols
|
|
call settextwindow (irt(2),ict(2),irb(2),icb(2))
|
|
call settextposition (1,1,cursor)
|
|
ntextw = 2
|
|
C-----------------------------------------------------------------------
|
|
C And then window 3 which is a full screen window.
|
|
C-----------------------------------------------------------------------
|
|
irt(3) = 4
|
|
irb(3) = nrows
|
|
ict(3) = 1
|
|
ict(3) = ncols
|
|
C-----------------------------------------------------------------------
|
|
C -- And the graphics window as the top righthand corner of the
|
|
C screen on a scale of 4096 along the x-axis and 60% of the screen.
|
|
C-----------------------------------------------------------------------
|
|
xt = 0.0
|
|
ypix = edyres/float(nrows)
|
|
yt = 3.0 * ypix + 1
|
|
yb = edyres - (7.0 * ypix + 1)
|
|
xb = (yb - yt) * edxres/edyres
|
|
call setviewport (xt,yt,xb,yb)
|
|
result = setwindow (.TRUE.,-205.0,-154.0,4300.0,3225.0)
|
|
result = setcolor (BLUE)
|
|
C call clearscreen ($GVIEWPORT)
|
|
C-----------------------------------------------------------------------
|
|
C XMOVE Move the graphics cursor to x,y
|
|
C-----------------------------------------------------------------------
|
|
else if (IFUNC .eq. XMOVE) then
|
|
wx = ix
|
|
wy = iy
|
|
call moveto_w (wx,wy,wprev)
|
|
C-----------------------------------------------------------------------
|
|
C XDRAW Draw a line
|
|
C-----------------------------------------------------------------------
|
|
else if (IFUNC .eq. XDRAW) then
|
|
wx = ix
|
|
wy = iy
|
|
result = lineto_w (wx,wy)
|
|
C-----------------------------------------------------------------------
|
|
C XCLOSE Return to normal text mode
|
|
C-----------------------------------------------------------------------
|
|
else if (IFUNC .eq. XCLOSE) then
|
|
result = setvideomode ($DEFAULTMODE)
|
|
C-----------------------------------------------------------------------
|
|
C XCLEAR Clear the graphics viewport
|
|
C-----------------------------------------------------------------------
|
|
else if (IFUNC .eq. XCLEAR) then
|
|
result = setcolor (BLUE)
|
|
call gettextposition (cursor2)
|
|
call settextwindow (irt(1),ict(1),irb(1)+1,icb(1))
|
|
call clearscreen ($GWINDOW)
|
|
do 120 i = 1,3
|
|
call settextposition (i,1,cursor)
|
|
call outtext (win1bf(i))
|
|
120 continue
|
|
call displa (theta,omega,chi,phi)
|
|
call settextwindow (irt(2),ict(2),irb(2),icb(2))
|
|
irow = cursor2.row
|
|
icol = cursor2.col
|
|
call settextposition (irow,icol,cursor2)
|
|
result = rectangle_w ($GFILLINTERIOR,-205.0,-154.0,
|
|
$ 4300.0,3225.0)
|
|
result = setcolor (WHITE)
|
|
result = rectangle_w ($GBORDER,-205.0,-154.0,
|
|
$ 4300.0,3225.0)
|
|
ntextw = 2
|
|
C-----------------------------------------------------------------------
|
|
C XTEXT Output text to the current text window
|
|
C-----------------------------------------------------------------------
|
|
else if (IFUNC .EQ. XTEXT) then
|
|
call outtext (string)
|
|
C-----------------------------------------------------------------------
|
|
C XSCROL Scroll text in the current window
|
|
C-----------------------------------------------------------------------
|
|
else if (IFUNC .EQ. XSCROL) then
|
|
call gettextposition (tcoords)
|
|
irow = tcoords.row + 1
|
|
icol = 1
|
|
mxlins = irb(ntextw) - irt(ntextw) + 1
|
|
if (irow .gt. mxlins) then
|
|
call scrolltextwindow ($GSCROLLUP)
|
|
irow = mxlins
|
|
endif
|
|
call settextposition (irow,icol,tcoords)
|
|
C-----------------------------------------------------------------------
|
|
C XTDEL Delete a character
|
|
C-----------------------------------------------------------------------
|
|
else if (IFUNC .EQ. XTDEL) then
|
|
call gettextposition (tcoords)
|
|
irow = tcoords.row
|
|
icol = tcoords.col - 1
|
|
if (icol .ge. 1) then
|
|
call settextposition (irow,icol,tcoords)
|
|
call outtext (' ')
|
|
call settextposition (irow,icol,tcoords)
|
|
endif
|
|
C-----------------------------------------------------------------------
|
|
C XWIN Set current text window
|
|
C-----------------------------------------------------------------------
|
|
else if (IFUNC .EQ. XWIN) then
|
|
if (ix .ge. 1 .and. ix .le. 3) then
|
|
call settextwindow (irt(ix),ict(ix),irb(ix),icb(ix))
|
|
if (iy .eq. XCLEAR) call clearscreen ($GWINDOW)
|
|
ntextw = ix
|
|
endif
|
|
endif
|
|
return
|
|
end
|
|
C-----------------------------------------------------------------------
|
|
C WNTEXT Simple routine to output text the the current window
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE WNTEXT (STRING)
|
|
INCLUDE 'COMDIF'
|
|
CHARACTER STRING*(*)
|
|
INTEGER IX,IY,IZ
|
|
DATA IX,IY,IZ/1,0,0/
|
|
CALL PCDRAW (XTEXT,IX,IY,IZ,STRING)
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C WNCDEL Delete a character from the screen
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE WNCDEL
|
|
INCLUDE 'COMDIF'
|
|
CALL PCDRAW (XTDEL,0,0,0,'Delete')
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C WNSET Routine to set the current text window
|
|
C Assumes: 1 -- Top left hand window
|
|
C 2 -- Text window along bottom
|
|
C 3 -- Full Screen
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE WNSET (I)
|
|
INCLUDE 'COMDIF'
|
|
LOGICAL FIRST
|
|
DATA FIRST/.TRUE./
|
|
IF (FIRST) THEN
|
|
CALL PCDRAW (XOPEN,0,0,0,'PCDRAW')
|
|
FIRST = .FALSE.
|
|
ENDIF
|
|
IF (I .EQ. 2 .AND. IWNCUR .NE. 3) THEN
|
|
CALL PCDRAW (XWIN,2,0,0,ANS)
|
|
ELSE IF (I .EQ. 2 .AND. IWNCUR .EQ. 3) THEN
|
|
CALL PCDRAW (XWIN,3,XCLEAR,0,ANS)
|
|
CALL PCDRAW (XWIN,2,XCLEAR,0,ANS)
|
|
CALL PCDRAW (XCLEAR,0,0,0,ANS)
|
|
ELSE IF (I .EQ. 3) THEN
|
|
CALL PCDRAW (XWIN,3,XCLEAR,0,ANS)
|
|
ELSE
|
|
CALL PCDRAW (XWIN,I,0,0,ANS)
|
|
ENDIF
|
|
IWNCUR = I
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C WNEND Tidy up for quitting
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE WNEND
|
|
INCLUDE 'COMDIF'
|
|
CALL PCDRAW (XCLOSE,0,0,0,'WNEND')
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C SCROLL Scroll text in current window
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE SCROLL
|
|
INCLUDE 'COMDIF'
|
|
CHARACTER STRING
|
|
DATA IX,IY,IZ/0,0,0/,STRING/' '/
|
|
CALL PCDRAW (XSCROL,IX,IY,IZ,STRING)
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C DISPLA Display current angle settings
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE DISPLA (ZT,ZO,ZC,ZP)
|
|
include 'fgraph.fd'
|
|
INCLUDE 'COMDIF'
|
|
character buffer*76
|
|
integer*2 result,
|
|
$ irt(3),ict(3),irb(3),icb(3)
|
|
record /rccoord/ cursor,old
|
|
common /pclocl/ irt,ict,irb,icb,ntextw
|
|
nw = ntextw
|
|
icount = acount(1)
|
|
call gettextposition (old)
|
|
call settextwindow (irt(1),ict(1),irb(1),icb(1))
|
|
call settextposition (2,2,cursor)
|
|
write (buffer,10000) ih,ik,il,zt,zo,zc,zp,nref,icount
|
|
10000 format (3i4,' ',4f8.2,' Nref',I5,' Int',i8)
|
|
call outtext (buffer(1:76))
|
|
call settextwindow (irt(nw),ict(nw),irb(nw),icb(nw))
|
|
call settextposition (old.row,old.col,cursor)
|
|
return
|
|
end
|
|
C-----------------------------------------------------------------------
|
|
C DISPLC Display current count settings
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE DISPLC (ICOUNT)
|
|
include 'fgraph.fd'
|
|
INCLUDE 'COMDIF'
|
|
character buffer*64
|
|
integer*2 result,
|
|
$ irt(3),ict(3),irb(3),icb(3)
|
|
record /rccoord/ cursor,old
|
|
common /pclocl/ irt,ict,irb,icb,ntextw
|
|
nw = ntextw
|
|
call gettextposition (old)
|
|
call settextwindow (irt(1),ict(1),irb(1),icb(1))
|
|
call settextposition (2,54,cursor)
|
|
write (buffer,10000) nref,icount
|
|
10000 format (' Nref',I5,' Int',i8)
|
|
call outtext (buffer(1:24))
|
|
call settextwindow (irt(nw),ict(nw),irb(nw),icb(nw))
|
|
call settextposition (old.row,old.col,cursor)
|
|
return
|
|
end
|