_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