home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / FORTRAN / DISK6 / REALG.FO$ / REALG.bin
Text File  |  1989-01-27  |  5KB  |  155 lines
  1. CC  REALG.FOR - Illustrates real coordinate graphics.
  2.  
  3.       INCLUDE  'FGRAPH.FI'
  4.       INCLUDE  'FGRAPH.FD'
  5.  
  6.       LOGICAL  fourcolors
  7.       EXTERNAL fourcolors
  8.  
  9.       IF( fourcolors() ) THEN
  10.          CALL threegraphs()
  11.       ELSE
  12.          WRITE (*,*) ' This program requires a CGA, EGA, or',
  13.      +               ' VGA graphics card.'
  14.       END IF
  15.       END 
  16.  
  17. C     Additional functions defined below
  18.  
  19. CC  FOURCOLORS - Function to enter graphics mode for REALG.
  20.  
  21.       LOGICAL FUNCTION fourcolors()
  22.  
  23.       INCLUDE  'FGRAPH.FD'
  24.  
  25.       INTEGER*2            dummy
  26.       RECORD /videoconfig/ screen
  27.       COMMON               screen
  28.  
  29. C
  30. C     Set to maximum number of available colors.
  31. C
  32.       CALL getvideoconfig( screen )
  33.       SELECT CASE( screen.adapter )
  34.          CASE( $CGA, $OCGA )
  35.             dummy = setvideomode( $MRES4COLOR )
  36.          CASE( $EGA, $OEGA )
  37.             dummy = setvideomode( $ERESCOLOR )
  38.          CASE( $VGA, $OVGA )
  39.             dummy = setvideomode( $VRES16COLOR )
  40.          CASE DEFAULT
  41.             dummy = 0
  42.       END SELECT
  43.  
  44.       CALL getvideoconfig( screen )
  45.       fourcolors = .TRUE.
  46.       IF( dummy .EQ. 0 ) fourcolors = .FALSE.
  47.       END
  48.  
  49.  
  50. CC  THREEGRAPHS - This subroutine displays three graphs for REALG.
  51.  
  52.       SUBROUTINE threegraphs()
  53.  
  54.       INCLUDE  'FGRAPH.FD'
  55.  
  56.       INTEGER*2            dummy, halfx, halfy
  57.       INTEGER*2            xwidth, yheight, cols, rows
  58.       RECORD /videoconfig/ screen
  59.       COMMON               screen
  60.  
  61.       CALL clearscreen( $GCLEARSCREEN )
  62.       xwidth  = screen.numxpixels
  63.       yheight = screen.numypixels
  64.       cols    = screen.numtextcols
  65.       rows    = screen.numtextrows
  66.       halfx   = xwidth / 2
  67.       halfy   = (yheight / rows) * (rows / 2)
  68. C
  69. C     First window
  70. C
  71.       CALL setviewport( 0, 0, halfx - 1, halfy - 1 )
  72.       CALL settextwindow( 1, 1, rows / 2, cols / 2 )
  73.       dummy = setwindow( .FALSE., -2.0, -2.0, 2.0, 2.0 )
  74.       CALL gridshape( INT2( rows / 2 ) )
  75.       dummy = rectangle( $GBORDER, 0, 0, halfx - 1, halfy - 1 )
  76. C
  77. C     Second window
  78. C
  79.       CALL setviewport( halfx, 0, xwidth - 1, halfy - 1 )
  80.       CALL settextwindow( 1, (cols / 2) + 1, rows / 2, cols )
  81.       dummy = setwindow( .FALSE., -3.0, -3.0, 3.0, 3.0 )
  82.       CALL gridshape( INT2( rows / 2 ) )
  83.       dummy = rectangle_w( $GBORDER, -3.0, -3.0, 3.0, 3.0 )   
  84. C  
  85. C     Third window
  86. C
  87.       CALL setviewport( 0, halfy, xwidth - 1, yheight - 1 )
  88.       CALL settextwindow( (rows / 2 ) + 1, 1, rows, cols )
  89.       dummy = setwindow( .TRUE., -3.0, -1.5, 1.5, 1.5 )
  90.       CALL gridshape( INT2( (rows / 2) + MOD( rows, 2 ) ) )
  91.       dummy = rectangle_w( $GBORDER, -3.0, -1.5, 1.5, 1.5 )
  92.    
  93.       READ (*,*)         ! Wait for ENTER key to be pressed
  94.       dummy = setvideomode( $DEFAULTMODE )
  95.       END
  96.  
  97.  
  98. CC  GRIDSHAPE - This subroutine plots data for the REALG program.
  99.  
  100.       SUBROUTINE gridshape( numc )
  101.  
  102.       INCLUDE  'FGRAPH.FD'
  103.  
  104.       INTEGER*2            dummy, numc, i
  105.       CHARACTER*2          str
  106.       DOUBLE PRECISION     bananas(21), x
  107.       RECORD /videoconfig/ screen
  108.       RECORD /wxycoord/    wxy
  109.       RECORD /rccoord/     curpos
  110.       COMMON               screen
  111. C
  112. C     Data for the graph
  113. C
  114.       DATA bananas /-0.3  , -0.2 , -0.224, -0.1, -0.5  ,
  115.      +               0.21 ,  2.9 ,  0.3  ,  0.2,  0.0  ,
  116.      +              -0.885, -1.1 , -0.3  , -0.2,  0.001,
  117.      +               0.005,  0.14,  0.0  , -0.9, -0.13 , 0.31 /
  118.  
  119. C
  120. C     Print colored words on the screen.
  121. C
  122.       IF( screen.numcolors .LT. numc ) numc = screen.numcolors - 1
  123.       DO i = 1, numc
  124.          CALL settextposition( i, 2, curpos )
  125.          dummy = settextcolor( i )
  126.          WRITE (str, '(I2)') i
  127.          CALL outtext( 'Color ' // str )
  128.       END DO
  129. C
  130. C     Draw a bordered rectangle around the graph.
  131. C
  132.       dummy = setcolor( 1 )
  133.       dummy = rectangle_w( $GBORDER, -1.00, -1.00, 1.00, 1.00 )
  134.       dummy = rectangle_w( $GBORDER, -1.02, -1.02, 1.02, 1.02 )
  135. C
  136. C     Plot the points.
  137. C
  138.       x = -0.90
  139.       DO i = 1, 19
  140.          dummy = setcolor( 2 )
  141.          CALL    moveto_w( x, -1.0, wxy )
  142.          dummy = lineto_w( x,  1.0 )
  143.          CALL    moveto_w( -1.0, x, wxy )
  144.          dummy = lineto_w(  1.0, x )
  145.          dummy = setcolor( 14 )
  146.          CALL    moveto_w( x - 0.1, bananas( i ), wxy )
  147.          dummy = lineto_w( x, bananas( i + 1 ) )
  148.          x     = x + 0.1
  149.       END DO
  150.  
  151.       CALL    moveto_w( 0.9, bananas( i ), wxy )
  152.       dummy = lineto_w( 1.0, bananas( i + 1 ) )
  153.       dummy = setcolor( 3 )
  154.       END
  155.