_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