424 lines
13 KiB
Plaintext
424 lines
13 KiB
Plaintext
_PORTING FORTAN PROGRAMS FROM MINIS TO PCS_
|
||
by John L. Bradberry
|
||
|
||
[LISTING ONE]
|
||
|
||
C
|
||
C >**************************************************************
|
||
PROGRAM GLOBE
|
||
C **************************************************************
|
||
C PROGRAM TO DRAW A GLOBE AT A USER SPECIFIED ANGLE ON A GRAPHICS
|
||
C SURFACE. INPUTS ALSO INCLUDE LOCATION OF GRATING LOBES REFERENCED
|
||
C TO LONGITUDE AND LATITUDE.
|
||
AUTHOR: SCIENTIFIC CONCEPTS
|
||
C --------------------------------------------------------------
|
||
IMPLICIT NONE
|
||
C
|
||
C
|
||
INTEGER*2 I !LOOP COUNTER
|
||
INTEGER*2 J !LOOP COUNTER
|
||
INTEGER*2 PMOVE !PEN CONTROL MOVE COMMAND
|
||
INTEGER*2 PDRAW !PEN CONTROL DRAW COMMAND
|
||
INTEGER*2 PENC !PEN CONTROL: 2=DRAW,3=MOVE
|
||
INTEGER*2 TLU !TERMINAL LOGICAL UNIT NUMBER
|
||
INTEGER*2 ROW !TEXT ROW POSITION
|
||
INTEGER*2 COLUMN !TEXT COLUMN POSITION
|
||
INTEGER*2 NUMLOBES !NUMBER OF GRATING LOBES REQUESTED
|
||
C
|
||
REAL*8 GRLOBEX(10) !X LOCATION FOR GRATING LOBE
|
||
REAL*8 GRLOBEY(10) !Y LOCATION FOR GRATING LOBE
|
||
REAL*8 XPOS !HORIZONTAL PIXEL POSITION
|
||
REAL*8 YPOS !VERTICAL PIXEL POSITION
|
||
REAL*8 HORIZONTAL !CALCULATED HORIZONTAL PIXEL POSITION
|
||
REAL*8 VERTICAL !CALCULATED VERTICAL PIXEL POSITION
|
||
REAL*8 RADIUS !RADIUS OF GLOBE CIRCLE
|
||
REAL*8 TILT !TILT ANGLE FOR GLOBE
|
||
REAL*8 PI !PI CONSTANT
|
||
REAL*8 COSCONVER !COS CONVERSION OF TILT IN RADIANS
|
||
REAL*8 SINCONVER !SIN CONVERSION OF TILT IN RADIANS
|
||
REAL*8 ELEVATION !CALCULATED LONGITUDE POSITION
|
||
REAL*8 AZIMUTH !CALCULATED LATITUDE POSITION
|
||
REAL*8 GLOBEINC !GRATING LOBE INCREMENT (RADIANS)
|
||
C
|
||
CHARACTER STEMP*8 !TEMPORARY STRING
|
||
C
|
||
C
|
||
PARAMETER (PMOVE=3,PDRAW=2)
|
||
C
|
||
TLU=6
|
||
NUMLOBES=0
|
||
PI=3.14159265
|
||
C
|
||
C
|
||
C HORIZONTAL,VERTICAL ARE COORDINATES OF ORIGIN
|
||
C
|
||
WRITE(TLU,*)'ENTER ORIGIN COORDINATES (TRY 300,200 FOR EGA/VGA)'
|
||
READ(TLU,*)HORIZONTAL,VERTICAL
|
||
C
|
||
WRITE(TLU,*)'ENTER RADIUS OF CIRCLE (TRY 160 FOR EGA/VGA)'
|
||
READ(TLU,*)RADIUS
|
||
C
|
||
WRITE(TLU,*)'ENTER TILT ANGLE IN DEGREES (TRY 30)'
|
||
READ(TLU,*)TILT
|
||
C
|
||
WRITE(TLU,*)'HOW MANY GRATING LOBES (MAXIMUM=10) ? '
|
||
READ(TLU,*)NUMLOBES
|
||
C
|
||
IF (NUMLOBES.GT.10) THEN
|
||
WRITE(TLU,*)' ERROR: TOO MANY GRATING LOBES REQUESTED!'
|
||
STOP
|
||
ELSE IF (NUMLOBES.GT.0) THEN
|
||
DO I=1,NUMLOBES
|
||
WRITE(TLU,*)'ENTER (X,Y) COORDINATES FOR POINT ',I
|
||
READ(TLU,*)GRLOBEX(I),GRLOBEY(I)
|
||
END DO
|
||
ENDIF
|
||
C
|
||
C INITIALIZE IBM PC TO MAXIMUM RESOLUTION ...
|
||
C
|
||
CALL GINIT(TLU)
|
||
C
|
||
C DRAW '+' AT ORIGIN
|
||
C
|
||
XPOS=HORIZONTAL-4.5
|
||
CALL PLOT(XPOS,VERTICAL,PMOVE)
|
||
XPOS=HORIZONTAL+4.5
|
||
CALL PLOT(XPOS,VERTICAL,PDRAW)
|
||
YPOS=VERTICAL-3.6
|
||
CALL PLOT(HORIZONTAL,YPOS,PMOVE)
|
||
YPOS=VERTICAL+3.9
|
||
CALL PLOT(HORIZONTAL,YPOS,PDRAW)
|
||
C
|
||
C LABEL FIGURE WITH PARAMETERS
|
||
C
|
||
ROW=24
|
||
COLUMN=26
|
||
WRITE(STEMP,'(F6.2)')TILT
|
||
CALL TEXTLABEL(ROW,COLUMN,'TILT ANGLE (DEGREES)='//STEMP)
|
||
C
|
||
C DRAW OUTER CIRCLE
|
||
C
|
||
CALL PLOT(HORIZONTAL+RADIUS,VERTICAL,PMOVE)
|
||
DO I=1,100
|
||
XPOS=HORIZONTAL+RADIUS*COS(I*2*PI/100)
|
||
YPOS=VERTICAL+RADIUS*SIN(I*2*PI/100)
|
||
CALL PLOT(XPOS,YPOS,PDRAW)
|
||
END DO
|
||
C
|
||
C DRAW LATITUDES
|
||
C
|
||
TILT=TILT*PI/180.0
|
||
COSCONVER=COS(TILT)
|
||
SINCONVER=SIN(TILT)
|
||
C
|
||
DO I=1,12
|
||
ELEVATION=PI/2-PI/12*I
|
||
XPOS=HORIZONTAL
|
||
YPOS=VERTICAL+RADIUS*(SIN(ELEVATION)*COSCONVER
|
||
+ -COS(ELEVATION)*SINCONVER)
|
||
CALL PLOT(XPOS,YPOS,PMOVE)
|
||
PENC=2
|
||
DO J=1,100
|
||
AZIMUTH=J*2*PI/100.0
|
||
IF (SIN(ELEVATION)*SINCONVER+COS(ELEVATION)*
|
||
+ COS(AZIMUTH)*COSCONVER.GE.0.) THEN
|
||
XPOS=HORIZONTAL+RADIUS*COS(ELEVATION)*SIN(AZIMUTH)
|
||
YPOS=VERTICAL+RADIUS*(SIN(ELEVATION)*COSCONVER
|
||
+ -COS(ELEVATION)*COS(AZIMUTH)*SINCONVER)
|
||
CALL PLOT(XPOS,YPOS,PENC)
|
||
PENC=2
|
||
ELSE
|
||
PENC=3
|
||
END IF
|
||
END DO
|
||
END DO
|
||
C
|
||
C DRAW LONGITUDES
|
||
C
|
||
DO I=1,12
|
||
AZIMUTH=I*PI/12
|
||
YPOS=VERTICAL+RADIUS*COSCONVER
|
||
CALL PLOT(HORIZONTAL,YPOS,PMOVE)
|
||
PENC=2
|
||
DO J=1,100
|
||
ELEVATION=PI/2-J*2*PI/100
|
||
IF (SIN(ELEVATION)*SINCONVER+COS(ELEVATION)*
|
||
+ COS(AZIMUTH)*COSCONVER.GE.0.) THEN
|
||
XPOS=HORIZONTAL+RADIUS*COS(ELEVATION)*SIN(AZIMUTH)
|
||
YPOS=VERTICAL+RADIUS*(SIN(ELEVATION)*COSCONVER
|
||
+ -COS(ELEVATION)*COS(AZIMUTH)*SINCONVER)
|
||
CALL PLOT(XPOS,YPOS,PENC)
|
||
PENC=2
|
||
ELSE
|
||
PENC=3
|
||
END IF
|
||
END DO
|
||
END DO
|
||
C
|
||
C
|
||
C DRAW GRATING LOBES
|
||
C
|
||
IF (NUMLOBES.GT.0) THEN
|
||
DO I=1,NUMLOBES
|
||
XPOS=HORIZONTAL+GRLOBEX(I)+RADIUS
|
||
YPOS=VERTICAL+GRLOBEY(I)
|
||
CALL PLOT(XPOS,YPOS,PMOVE)
|
||
C
|
||
DO J=1,100
|
||
GLOBEINC=J*PI/50
|
||
XPOS=HORIZONTAL+GRLOBEX(I)+RADIUS*COS(GLOBEINC+.04)
|
||
YPOS=VERTICAL+GRLOBEY(I)+RADIUS*SIN(GLOBEINC+.04)
|
||
IF((GRLOBEX(I)+RADIUS*COS(GLOBEINC))**2+
|
||
+ (GRLOBEY(I)+RADIUS*SIN(GLOBEINC))**2.LT.RADIUS**2) THEN
|
||
CALL PLOT(XPOS,YPOS,PDRAW)
|
||
ELSE
|
||
CALL PLOT(XPOS,YPOS,PMOVE)
|
||
END IF
|
||
END DO
|
||
END DO
|
||
END IF
|
||
C
|
||
C
|
||
C PREPARE TO EXIT GRAPHICS AND RETURN TO NORMAL VIDEO ...
|
||
C
|
||
CALL EXITGRAPHICS(TLU)
|
||
C
|
||
END
|
||
C
|
||
C
|
||
INCLUDE 'FGRAPH.FI'
|
||
C
|
||
C
|
||
C >**************************************************************
|
||
SUBROUTINE TEXTLABEL(ROW,COLUMN,STRING)
|
||
C **************************************************************
|
||
C SUBROUTINE TO WAIT FOR USER SIGNAL AND EXIT GRAPHICS MODE. TERMINAL
|
||
C IS RESTORED TO PRE-VIDEO CONDITIONS...
|
||
C --------------------------------------------------------------
|
||
IMPLICIT NONE
|
||
C
|
||
INCLUDE 'FGRAPH.FD'
|
||
C
|
||
INTEGER*2 ROW !TEXT ROW POSITION
|
||
INTEGER*2 COLUMN !TEXT COLUMN POSITION
|
||
C
|
||
CHARACTER STRING*(*) !TEXT STRING FOR LABEL
|
||
C
|
||
RECORD /RCCOORD/ CURPOS
|
||
C
|
||
C
|
||
C OUTPUT USER SUPLIED STRING AT ROW,COLUMN ...
|
||
C
|
||
CALL SETTEXTPOSITION(ROW,COLUMN,CURPOS)
|
||
CALL OUTTEXT(STRING)
|
||
C
|
||
RETURN
|
||
END
|
||
C
|
||
C
|
||
C >**************************************************************
|
||
SUBROUTINE EXITGRAPHICS(TLU)
|
||
C **************************************************************
|
||
C SUBROUTINE TO WAIT FOR USER SIGNAL AND EXIT GRAPHICS MODE. TERMINAL
|
||
C IS RESTORED TO PRE-VIDEO CONDITIONS...
|
||
C --------------------------------------------------------------
|
||
IMPLICIT NONE
|
||
C
|
||
INCLUDE 'FGRAPH.FD'
|
||
C
|
||
INTEGER*2 TLU !TERMINAL LOGICAL UNIT NUMBER
|
||
INTEGER*2 DUMMY !DUMMY FUNCTION ARGUMENT
|
||
INTEGER*2 ROW !TEXT ROW POSITION
|
||
INTEGER*2 COLUMN !TEXT COLUMN POSITION
|
||
C
|
||
ROW=25
|
||
COLUMN=28
|
||
C
|
||
C
|
||
C OUTPUT PROMPT AND WAIT FOR ENTER KEY ...
|
||
C
|
||
CALL TEXTLABEL(ROW,COLUMN,'PRESS ENTER TO CONTINUE')
|
||
READ(TLU,*)
|
||
C
|
||
C RESET VIDEO MODE AND STOP
|
||
C
|
||
DUMMY=SETVIDEOMODE($DEFAULTMODE)
|
||
C
|
||
RETURN
|
||
END
|
||
C
|
||
C
|
||
C >**************************************************************
|
||
SUBROUTINE GINIT(TLU)
|
||
C **************************************************************
|
||
C SUBROUTINE TO INITIALIZE IBM PC GRAPHICS MODE TO MAXIMUM
|
||
C AVAILABLE RESOLUTION ...
|
||
C --------------------------------------------------------------
|
||
IMPLICIT NONE
|
||
C
|
||
INCLUDE 'FGRAPH.FD'
|
||
C
|
||
INTEGER*2 ERRC !ERROR CODE RETURNED
|
||
INTEGER*2 TLU !TERMINAL LOGICAL UNIT NUMBER
|
||
INTEGER*2 DUMMY !DUMMY FUNCTION ARGUMENT
|
||
C
|
||
LOGICAL*2 WINDINVERT !INVERT WINDOW COORDINATES IF TRUE
|
||
C
|
||
REAL*8 LOWERX !LOWER X AXIS CORNER OF WINDOW
|
||
REAL*8 LOWERY !LOWER Y AXIS CORNER OF WINDOW
|
||
REAL*8 UPPERX !UPPER X AXIS CORNER OF WINDOW
|
||
REAL*8 UPPERY !UPPER Y AXIS CORNER OF WINDOW
|
||
C
|
||
C
|
||
C
|
||
C INITIALIZE VIDEO MODE TO MAXIMUM RESOLUTION AVAILABLE
|
||
C
|
||
ERRC=SETVIDEOMODE($MAXRESMODE)
|
||
IF (ERRC.EQ.0) THEN
|
||
WRITE(TLU,*)' ERROR: CANNOT SET VIDEO MODE'
|
||
STOP
|
||
END IF
|
||
C
|
||
LOWERX=-3.0
|
||
LOWERY=3.0
|
||
UPPERX=-3.0
|
||
UPPERY=3.0
|
||
WINDINVERT=.TRUE.
|
||
DUMMY=SETWINDOW(WINDINVERT,LOWERX,LOWERY,UPPERX,UPPERY)
|
||
C
|
||
RETURN
|
||
END
|
||
C
|
||
C
|
||
C >**************************************************************
|
||
SUBROUTINE PLOT(XPOS,YPOS,PENC)
|
||
C **************************************************************
|
||
C SUBROUTINE TO DRAW OR MOVE TO THE USER SPECIFIED POSITION 'XPOS,
|
||
C YPOS' WITH PEN CONTROL AS DESIGNATED BY 'PENC'.
|
||
C --------------------------------------------------------------
|
||
IMPLICIT NONE
|
||
C
|
||
INCLUDE 'FGRAPH.FD'
|
||
C
|
||
INTEGER*2 DUMMY !DUMMY FUNCTION ARGUMENT
|
||
INTEGER*2 PENC !PEN CONTROL: 2=DRAW,3=MOVE
|
||
C
|
||
REAL*8 XPOS !HORIZONTAL PIXEL POSITION
|
||
REAL*8 YPOS !VERTICAL PIXEL POSITION
|
||
C
|
||
RECORD /WXYCOORD/ XY
|
||
C
|
||
IF (PENC.EQ.2) THEN
|
||
DUMMY=LINETO_W(XPOS,YPOS)
|
||
ELSE
|
||
CALL MOVETO_W(XPOS,YPOS,XY)
|
||
END IF
|
||
C
|
||
RETURN
|
||
END
|
||
|
||
|
||
|
||
|
||
[LISTING TWO]
|
||
Top Level Fragment
|
||
|
||
|
||
C >**********************************************************
|
||
PROGRAM GLOBE
|
||
C **********************************************************
|
||
C
|
||
C PROGRAM TO DRAW A GLOBE AT A USER SPECIFIED ANGLE ON A GRAPHICS
|
||
C SURFACE. INPUTS ALSO INCLUDE LOCATION OF GRATING LOBES REFERENCED
|
||
C TO LONGITUDE AND LATITUDE.
|
||
C AUTHOR: SCIENTIFIC CONCEPTS
|
||
C
|
||
--------------------------------------------------------------
|
||
.
|
||
.
|
||
.
|
||
CALL GINIT !INITIALIZE GRAPHICS DEVICE
|
||
.
|
||
.
|
||
.
|
||
END
|
||
|
||
Layer 3: Graphics Primitives
|
||
|
||
C*******************************************************C
|
||
SUBROUTINE GINIT
|
||
C*******************************************************C
|
||
C PURPOSE: INITIALIZE GRAPHICS DEVICE CURRENTLY
|
||
C SET BY GLOBAL VARIABLE 'DEVICETYPE' ...
|
||
.
|
||
.
|
||
.
|
||
IF (DEVICETYPE.EQ.HPGL) THEN !HP GRAPHICS DEVICE
|
||
CALL HPGLINIT
|
||
ELSE IF (DEVICETYPE.EQ.IBMPC) THEN !IBM MODES CGA-VGA
|
||
CALL IBMPCINIT
|
||
ELSE IF (DEVICETYPE.EQ.TEK) THEN !TEKTRONIX DEVICES
|
||
CALL TEKINIT
|
||
ELSE IF (DEVICETYPE.EQ.DECVT) THEN !DEC VT340
|
||
CALL DECVTINIT
|
||
ELSE IF (DEVICETYPE.EQ.VAXSTA) THEN !DEC VAXSTATION 2000
|
||
CALL VAXSTAINIT
|
||
.
|
||
.
|
||
. ELSE
|
||
CALL INITERROR
|
||
END IF
|
||
|
||
Layer 2: Graphics Device Drivers
|
||
|
||
C*******************************************************C
|
||
SUBROUTINE IBMPCINIT
|
||
C*******************************************************C
|
||
C PURPOSE: INITIALIZE CURRENT IBM PC GRAPHICS MODE
|
||
C COLORS, RESOLUTION ETC ...
|
||
.
|
||
.
|
||
.
|
||
|
||
C
|
||
IF (IBMMODE.EQ.EGACOLOR) THEN
|
||
DUMMY=SETVIDEOMODE($ERESCOLOR)
|
||
ELSE IF (IBMMODE.EQ.HERCULES) THEN
|
||
DUMMY=SETVIDEOMODE($HERCMONO)
|
||
.
|
||
.
|
||
.
|
||
END IF
|
||
C
|
||
RETURN
|
||
END
|
||
C
|
||
C*******************************************************C
|
||
SUBROUTINE VAXSTAINIT
|
||
C*******************************************************C
|
||
C PURPOSE: INITIALIZE VAXSTATION 200 GRAPHICS DEVICE
|
||
C MODE, VIEWPORT ...
|
||
.
|
||
.
|
||
.
|
||
C
|
||
LOWLX=1.0 !LOWER LEFT X COORDINATE
|
||
LOWLY=1.0 !LOWER LEFT Y COORDINATE
|
||
UPPRX=20.0 !UPPER RIGHT X COORDINATE
|
||
UPPRY=20.0 !UPPER RIGHT Y COORDINATE
|
||
DISPWIDTH=20.0
|
||
DISPHEIGHT=20.0
|
||
C
|
||
VD_ID=UIS$CREATE_DISPLAY(LOWLX,LOWLY,UPPRX,UPPRY,
|
||
+ DISPWIDTH,DISPHEIGHT)
|
||
WD_ID=UIS$CREATE_WINDOW(VD_ID,'SYS$WORKSTATION')
|
||
C
|
||
.
|
||
.
|
||
.
|
||
RETURN
|
||
END
|
||
C
|
||
C
|
||
|
||
|