💾 Archived View for spam.works › mirrors › textfiles › computers › bradbery.asc captured on 2023-11-14 at 09:10:00.
⬅️ Previous capture (2023-06-14)
-=-=-=-=-=-=-
_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