home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / DDJMAG / DDJ9009.ZIP / BRADBERY.ASC < prev    next >
Encoding:
Text File  |  1990-07-25  |  12.6 KB  |  424 lines
  1. _PORTING FORTAN PROGRAMS FROM MINIS TO PCS_
  2. by John L. Bradberry
  3.  
  4. [LISTING ONE]
  5.  
  6. C
  7. C    >**************************************************************
  8.       PROGRAM GLOBE
  9. C     **************************************************************
  10. C     PROGRAM TO DRAW A GLOBE AT A USER SPECIFIED ANGLE ON A GRAPHICS
  11. C     SURFACE. INPUTS ALSO INCLUDE LOCATION OF GRATING LOBES REFERENCED
  12. C     TO LONGITUDE AND LATITUDE.
  13.       AUTHOR: SCIENTIFIC CONCEPTS
  14. C     --------------------------------------------------------------   
  15.       IMPLICIT NONE
  16. C
  17. C
  18.       INTEGER*2         I               !LOOP COUNTER
  19.       INTEGER*2         J               !LOOP COUNTER
  20.       INTEGER*2         PMOVE           !PEN CONTROL MOVE COMMAND
  21.       INTEGER*2         PDRAW           !PEN CONTROL DRAW COMMAND
  22.       INTEGER*2         PENC            !PEN CONTROL: 2=DRAW,3=MOVE
  23.       INTEGER*2         TLU             !TERMINAL LOGICAL UNIT NUMBER
  24.       INTEGER*2         ROW             !TEXT ROW POSITION
  25.       INTEGER*2         COLUMN          !TEXT COLUMN POSITION
  26.       INTEGER*2         NUMLOBES        !NUMBER OF GRATING LOBES REQUESTED
  27. C
  28.       REAL*8            GRLOBEX(10)     !X LOCATION FOR GRATING LOBE
  29.       REAL*8            GRLOBEY(10)     !Y LOCATION FOR GRATING LOBE
  30.       REAL*8            XPOS            !HORIZONTAL PIXEL POSITION
  31.       REAL*8            YPOS            !VERTICAL PIXEL POSITION
  32.       REAL*8            HORIZONTAL      !CALCULATED HORIZONTAL PIXEL POSITION
  33.       REAL*8            VERTICAL        !CALCULATED VERTICAL PIXEL POSITION
  34.       REAL*8            RADIUS          !RADIUS OF GLOBE CIRCLE
  35.       REAL*8            TILT            !TILT ANGLE FOR GLOBE
  36.       REAL*8            PI              !PI CONSTANT
  37.       REAL*8            COSCONVER       !COS CONVERSION OF TILT IN RADIANS
  38.       REAL*8            SINCONVER       !SIN CONVERSION OF TILT IN RADIANS
  39.       REAL*8            ELEVATION       !CALCULATED LONGITUDE POSITION
  40.       REAL*8            AZIMUTH         !CALCULATED LATITUDE POSITION
  41.       REAL*8            GLOBEINC        !GRATING LOBE INCREMENT (RADIANS)
  42. C  
  43.       CHARACTER         STEMP*8         !TEMPORARY STRING 
  44. C
  45. C 
  46.       PARAMETER         (PMOVE=3,PDRAW=2)
  47. C
  48.       TLU=6
  49.       NUMLOBES=0
  50.       PI=3.14159265
  51. C
  52. C      
  53. C     HORIZONTAL,VERTICAL ARE COORDINATES OF ORIGIN 
  54. C
  55.       WRITE(TLU,*)'ENTER ORIGIN COORDINATES (TRY 300,200 FOR EGA/VGA)'    
  56.       READ(TLU,*)HORIZONTAL,VERTICAL
  57. C
  58.       WRITE(TLU,*)'ENTER RADIUS OF CIRCLE (TRY 160 FOR EGA/VGA)'
  59.       READ(TLU,*)RADIUS
  60. C
  61.       WRITE(TLU,*)'ENTER TILT ANGLE IN DEGREES (TRY 30)'
  62.       READ(TLU,*)TILT
  63. C
  64.       WRITE(TLU,*)'HOW MANY GRATING LOBES (MAXIMUM=10) ? '
  65.       READ(TLU,*)NUMLOBES
  66. C
  67.       IF (NUMLOBES.GT.10) THEN
  68.         WRITE(TLU,*)' ERROR: TOO MANY GRATING LOBES REQUESTED!'
  69.         STOP
  70.       ELSE IF (NUMLOBES.GT.0) THEN
  71.         DO I=1,NUMLOBES
  72.           WRITE(TLU,*)'ENTER (X,Y) COORDINATES FOR POINT ',I
  73.           READ(TLU,*)GRLOBEX(I),GRLOBEY(I)
  74.         END DO
  75.       ENDIF
  76. C
  77. C     INITIALIZE IBM PC TO MAXIMUM RESOLUTION ...
  78. C
  79.       CALL GINIT(TLU)
  80. C
  81. C     DRAW '+' AT ORIGIN 
  82. C
  83.       XPOS=HORIZONTAL-4.5
  84.       CALL PLOT(XPOS,VERTICAL,PMOVE)
  85.       XPOS=HORIZONTAL+4.5
  86.       CALL PLOT(XPOS,VERTICAL,PDRAW)
  87.       YPOS=VERTICAL-3.6
  88.       CALL PLOT(HORIZONTAL,YPOS,PMOVE)
  89.       YPOS=VERTICAL+3.9
  90.       CALL PLOT(HORIZONTAL,YPOS,PDRAW)
  91. C
  92. C     LABEL FIGURE WITH PARAMETERS
  93. C
  94.       ROW=24
  95.       COLUMN=26
  96.       WRITE(STEMP,'(F6.2)')TILT
  97.       CALL TEXTLABEL(ROW,COLUMN,'TILT ANGLE (DEGREES)='//STEMP)
  98. C       
  99. C     DRAW OUTER CIRCLE
  100. C
  101.       CALL PLOT(HORIZONTAL+RADIUS,VERTICAL,PMOVE)
  102.       DO I=1,100
  103.         XPOS=HORIZONTAL+RADIUS*COS(I*2*PI/100)
  104.         YPOS=VERTICAL+RADIUS*SIN(I*2*PI/100)
  105.         CALL PLOT(XPOS,YPOS,PDRAW)
  106.       END DO
  107. C
  108. C     DRAW LATITUDES
  109. C
  110.       TILT=TILT*PI/180.0
  111.       COSCONVER=COS(TILT)
  112.       SINCONVER=SIN(TILT)
  113. C
  114.       DO I=1,12
  115.         ELEVATION=PI/2-PI/12*I
  116.         XPOS=HORIZONTAL
  117.         YPOS=VERTICAL+RADIUS*(SIN(ELEVATION)*COSCONVER
  118.      +       -COS(ELEVATION)*SINCONVER)
  119.         CALL PLOT(XPOS,YPOS,PMOVE)
  120.         PENC=2
  121.         DO J=1,100
  122.           AZIMUTH=J*2*PI/100.0
  123.           IF (SIN(ELEVATION)*SINCONVER+COS(ELEVATION)*
  124.      +        COS(AZIMUTH)*COSCONVER.GE.0.) THEN
  125.             XPOS=HORIZONTAL+RADIUS*COS(ELEVATION)*SIN(AZIMUTH)
  126.             YPOS=VERTICAL+RADIUS*(SIN(ELEVATION)*COSCONVER
  127.      +           -COS(ELEVATION)*COS(AZIMUTH)*SINCONVER)
  128.             CALL PLOT(XPOS,YPOS,PENC)
  129.             PENC=2
  130.           ELSE
  131.             PENC=3
  132.           END IF
  133.         END DO
  134.       END DO
  135. C
  136. C     DRAW LONGITUDES
  137. C
  138.       DO I=1,12
  139.         AZIMUTH=I*PI/12
  140.         YPOS=VERTICAL+RADIUS*COSCONVER
  141.         CALL PLOT(HORIZONTAL,YPOS,PMOVE)
  142.         PENC=2
  143.         DO J=1,100
  144.           ELEVATION=PI/2-J*2*PI/100
  145.           IF (SIN(ELEVATION)*SINCONVER+COS(ELEVATION)*
  146.      +        COS(AZIMUTH)*COSCONVER.GE.0.) THEN
  147.             XPOS=HORIZONTAL+RADIUS*COS(ELEVATION)*SIN(AZIMUTH)
  148.             YPOS=VERTICAL+RADIUS*(SIN(ELEVATION)*COSCONVER
  149.      +           -COS(ELEVATION)*COS(AZIMUTH)*SINCONVER)
  150.             CALL PLOT(XPOS,YPOS,PENC)
  151.             PENC=2
  152.           ELSE
  153.             PENC=3
  154.           END IF
  155.         END DO
  156.       END DO
  157. C
  158. C
  159. C     DRAW GRATING LOBES
  160. C
  161.       IF (NUMLOBES.GT.0) THEN
  162.         DO I=1,NUMLOBES
  163.           XPOS=HORIZONTAL+GRLOBEX(I)+RADIUS
  164.           YPOS=VERTICAL+GRLOBEY(I)
  165.           CALL PLOT(XPOS,YPOS,PMOVE)
  166. C
  167.           DO J=1,100
  168.             GLOBEINC=J*PI/50
  169.             XPOS=HORIZONTAL+GRLOBEX(I)+RADIUS*COS(GLOBEINC+.04)
  170.             YPOS=VERTICAL+GRLOBEY(I)+RADIUS*SIN(GLOBEINC+.04)
  171.             IF((GRLOBEX(I)+RADIUS*COS(GLOBEINC))**2+
  172.      +         (GRLOBEY(I)+RADIUS*SIN(GLOBEINC))**2.LT.RADIUS**2) THEN
  173.               CALL PLOT(XPOS,YPOS,PDRAW)
  174.             ELSE
  175.               CALL PLOT(XPOS,YPOS,PMOVE)
  176.             END IF
  177.           END DO
  178.         END DO
  179.       END IF
  180. C
  181. C
  182. C     PREPARE TO EXIT GRAPHICS AND RETURN TO NORMAL VIDEO ...
  183. C
  184.       CALL EXITGRAPHICS(TLU)
  185. C
  186.       END
  187. C
  188. C
  189.       INCLUDE 'FGRAPH.FI'
  190. C
  191. C
  192. C    >**************************************************************
  193.       SUBROUTINE TEXTLABEL(ROW,COLUMN,STRING) 
  194. C     **************************************************************
  195. C     SUBROUTINE TO WAIT FOR USER SIGNAL AND EXIT GRAPHICS MODE. TERMINAL
  196. C     IS RESTORED TO PRE-VIDEO CONDITIONS...
  197. C     --------------------------------------------------------------
  198.       IMPLICIT NONE
  199. C
  200.       INCLUDE 'FGRAPH.FD'
  201. C
  202.       INTEGER*2         ROW             !TEXT ROW POSITION
  203.       INTEGER*2         COLUMN          !TEXT COLUMN POSITION
  204. C
  205.       CHARACTER         STRING*(*)      !TEXT STRING FOR LABEL
  206. C
  207.       RECORD /RCCOORD/ CURPOS
  208. C
  209. C
  210. C     OUTPUT USER SUPLIED STRING AT ROW,COLUMN ...
  211. C
  212.       CALL SETTEXTPOSITION(ROW,COLUMN,CURPOS)
  213.       CALL OUTTEXT(STRING)
  214. C
  215.       RETURN
  216.       END 
  217. C
  218. C
  219. C    >**************************************************************
  220.       SUBROUTINE EXITGRAPHICS(TLU) 
  221. C     **************************************************************
  222. C     SUBROUTINE TO WAIT FOR USER SIGNAL AND EXIT GRAPHICS MODE. TERMINAL
  223. C     IS RESTORED TO PRE-VIDEO CONDITIONS...
  224. C     --------------------------------------------------------------   
  225.       IMPLICIT NONE
  226. C
  227.       INCLUDE 'FGRAPH.FD'
  228. C
  229.       INTEGER*2         TLU             !TERMINAL LOGICAL UNIT NUMBER
  230.       INTEGER*2         DUMMY           !DUMMY FUNCTION ARGUMENT
  231.       INTEGER*2         ROW             !TEXT ROW POSITION
  232.       INTEGER*2         COLUMN          !TEXT COLUMN POSITION
  233. C
  234.       ROW=25
  235.       COLUMN=28
  236. C
  237. C
  238. C     OUTPUT PROMPT AND WAIT FOR ENTER KEY ...
  239. C
  240.       CALL TEXTLABEL(ROW,COLUMN,'PRESS ENTER TO CONTINUE')
  241.       READ(TLU,*)
  242. C
  243. C     RESET VIDEO MODE AND STOP
  244. C
  245.       DUMMY=SETVIDEOMODE($DEFAULTMODE)
  246. C
  247.       RETURN
  248.       END 
  249. C
  250. C
  251. C    >**************************************************************
  252.       SUBROUTINE GINIT(TLU) 
  253. C     **************************************************************
  254. C     SUBROUTINE TO INITIALIZE IBM PC GRAPHICS MODE TO MAXIMUM
  255. C     AVAILABLE RESOLUTION ...
  256. C     --------------------------------------------------------------
  257.       IMPLICIT NONE
  258. C
  259.       INCLUDE 'FGRAPH.FD'
  260. C
  261.       INTEGER*2         ERRC            !ERROR CODE RETURNED
  262.       INTEGER*2         TLU             !TERMINAL LOGICAL UNIT NUMBER
  263.       INTEGER*2         DUMMY           !DUMMY FUNCTION ARGUMENT
  264. C
  265.       LOGICAL*2         WINDINVERT      !INVERT WINDOW COORDINATES IF TRUE
  266. C
  267.       REAL*8            LOWERX          !LOWER X AXIS CORNER OF WINDOW
  268.       REAL*8            LOWERY          !LOWER Y AXIS CORNER OF WINDOW
  269.       REAL*8            UPPERX          !UPPER X AXIS CORNER OF WINDOW
  270.       REAL*8            UPPERY          !UPPER Y AXIS CORNER OF WINDOW
  271. C
  272. C
  273. C
  274. C     INITIALIZE VIDEO MODE TO MAXIMUM RESOLUTION AVAILABLE
  275. C
  276.       ERRC=SETVIDEOMODE($MAXRESMODE)
  277.       IF (ERRC.EQ.0) THEN
  278.         WRITE(TLU,*)' ERROR: CANNOT SET VIDEO MODE'
  279.         STOP
  280.       END IF
  281. C
  282.       LOWERX=-3.0
  283.       LOWERY=3.0
  284.       UPPERX=-3.0
  285.       UPPERY=3.0
  286.       WINDINVERT=.TRUE.
  287.       DUMMY=SETWINDOW(WINDINVERT,LOWERX,LOWERY,UPPERX,UPPERY)
  288. C
  289.       RETURN
  290.       END 
  291. C
  292. C
  293. C    >**************************************************************
  294.       SUBROUTINE PLOT(XPOS,YPOS,PENC) 
  295. C     **************************************************************
  296. C     SUBROUTINE TO DRAW OR MOVE TO THE USER SPECIFIED POSITION 'XPOS,
  297. C     YPOS' WITH PEN CONTROL AS DESIGNATED BY 'PENC'.
  298. C     --------------------------------------------------------------   
  299.       IMPLICIT NONE
  300. C
  301.       INCLUDE 'FGRAPH.FD'
  302. C
  303.       INTEGER*2         DUMMY           !DUMMY FUNCTION ARGUMENT
  304.       INTEGER*2         PENC            !PEN CONTROL: 2=DRAW,3=MOVE
  305. C
  306.       REAL*8            XPOS            !HORIZONTAL PIXEL POSITION
  307.       REAL*8            YPOS            !VERTICAL PIXEL POSITION
  308. C
  309.       RECORD /WXYCOORD/ XY
  310. C
  311.       IF (PENC.EQ.2) THEN 
  312.         DUMMY=LINETO_W(XPOS,YPOS)
  313.       ELSE
  314.         CALL MOVETO_W(XPOS,YPOS,XY)
  315.       END IF
  316. C
  317.       RETURN
  318.       END 
  319.  
  320.  
  321.  
  322.  
  323. [LISTING TWO]
  324.                        Top Level Fragment
  325.  
  326.  
  327. C    >**********************************************************
  328.       PROGRAM GLOBE
  329. C     **********************************************************
  330. C
  331. C PROGRAM TO DRAW A GLOBE AT A USER SPECIFIED ANGLE ON A GRAPHICS
  332. C SURFACE. INPUTS ALSO INCLUDE LOCATION OF GRATING LOBES REFERENCED
  333. C TO LONGITUDE AND LATITUDE.
  334. C AUTHOR: SCIENTIFIC CONCEPTS
  335. C    
  336. --------------------------------------------------------------
  337. .
  338. .
  339. .
  340.       CALL GINIT         !INITIALIZE GRAPHICS DEVICE
  341. .
  342. .
  343. .
  344.       END
  345.  
  346.                     Layer 3: Graphics Primitives   
  347.  
  348. C*******************************************************C
  349.       SUBROUTINE GINIT
  350. C*******************************************************C
  351. C     PURPOSE: INITIALIZE GRAPHICS DEVICE CURRENTLY
  352. C              SET BY GLOBAL VARIABLE 'DEVICETYPE' ... 
  353. .
  354. .
  355. .
  356.       IF (DEVICETYPE.EQ.HPGL) THEN         !HP GRAPHICS DEVICE
  357.         CALL HPGLINIT
  358.       ELSE IF (DEVICETYPE.EQ.IBMPC) THEN   !IBM MODES CGA-VGA
  359.         CALL IBMPCINIT
  360.       ELSE IF (DEVICETYPE.EQ.TEK) THEN     !TEKTRONIX DEVICES
  361.         CALL TEKINIT
  362.       ELSE IF (DEVICETYPE.EQ.DECVT) THEN   !DEC VT340
  363.         CALL DECVTINIT
  364.       ELSE IF (DEVICETYPE.EQ.VAXSTA) THEN  !DEC VAXSTATION 2000
  365.         CALL VAXSTAINIT  
  366. .
  367. .    
  368. .     ELSE
  369.         CALL INITERROR
  370.       END IF
  371.  
  372.                Layer 2: Graphics Device Drivers      
  373.  
  374. C*******************************************************C
  375.       SUBROUTINE IBMPCINIT
  376. C*******************************************************C
  377. C     PURPOSE: INITIALIZE CURRENT IBM PC GRAPHICS MODE
  378. C              COLORS, RESOLUTION ETC ...
  379. .
  380. .
  381. .
  382.  
  383. C
  384.       IF (IBMMODE.EQ.EGACOLOR) THEN
  385.         DUMMY=SETVIDEOMODE($ERESCOLOR)
  386.       ELSE IF (IBMMODE.EQ.HERCULES) THEN
  387.         DUMMY=SETVIDEOMODE($HERCMONO)
  388. .
  389. .
  390. .
  391.       END IF
  392. C
  393.       RETURN
  394.       END
  395. C
  396. C*******************************************************C
  397.       SUBROUTINE VAXSTAINIT
  398. C*******************************************************C
  399. C     PURPOSE: INITIALIZE VAXSTATION 200 GRAPHICS DEVICE
  400. C              MODE, VIEWPORT ...
  401. .
  402. .
  403. .
  404. C
  405.       LOWLX=1.0             !LOWER LEFT X COORDINATE
  406.       LOWLY=1.0             !LOWER LEFT Y COORDINATE
  407.       UPPRX=20.0            !UPPER RIGHT X COORDINATE
  408.       UPPRY=20.0            !UPPER RIGHT Y COORDINATE
  409.       DISPWIDTH=20.0        
  410.       DISPHEIGHT=20.0
  411. C
  412.       VD_ID=UIS$CREATE_DISPLAY(LOWLX,LOWLY,UPPRX,UPPRY,
  413.      +                           DISPWIDTH,DISPHEIGHT)
  414.       WD_ID=UIS$CREATE_WINDOW(VD_ID,'SYS$WORKSTATION')
  415. C
  416. .
  417. .
  418. .
  419.       RETURN
  420.       END
  421. C
  422. C
  423.  
  424.