home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / fort_lib / os2grf.for < prev    next >
Text File  |  1991-01-17  |  6KB  |  195 lines
  1. $NOTRUNCATE
  2. $DEFINE  INCL_VIO
  3. $DEFINE  INCL_DOSPROCESS
  4.  
  5.       INCLUDE 'BSESUB.FI'
  6.       INCLUDE 'BSEDOS.FI'
  7.  
  8.       INTERFACE TO SUBROUTINE RColor [PASCAL] (NBtPln)
  9.       INTEGER*2 NBtPln [NEAR,VALUE]
  10.       END
  11.       INTERFACE TO SUBROUTINE WColor [PASCAL] (NBtPln)
  12.       INTEGER*2 NBtPln [NEAR,VALUE]
  13.       END
  14.       INTERFACE TO SUBROUTINE RBtPln(VGASeg,BtPlnD)
  15.       INTEGER*4  VGASeg [NEAR,VALUE]
  16.       INTEGER*1  BtPlnD(38400)   ! VGA
  17. C     INTEGER*1  BtPlnD(28000)   ! EGA
  18.       END
  19.       INTERFACE TO SUBROUTINE WBtPln(VGASeg,BtPlnD)
  20.       INTEGER*4  VGASeg [NEAR,VALUE]
  21.       INTEGER*1  BtPlnD(38400)   ! VGA
  22. C     INTEGER*1  BtPlnD(28000)   ! EGA
  23.       END
  24.  
  25.  
  26.  
  27.       SUBROUTINE GMode(SetMode)
  28. ************************************************************************
  29. *     set dispaly mode to SetMode
  30. ************************************************************************
  31.  
  32.       INCLUDE 'BSESUB.FD'
  33.  
  34.       LOGICAL              SetMode, First / .TRUE. /
  35.       INTEGER*2            SaveMode, ReturnCode
  36.       RECORD /VIOMODEINFO/ NewMode, OldMode
  37.  
  38.       IF( SetMode )  THEN
  39. * --- enter grafics mode
  40.          IF( First )  THEN
  41. * --- save old video mode
  42.             OldMode.cb  =  12
  43.             SaveMode    = VioGetMode( OldMode, 0 )
  44.             First       = .False.
  45.          END IF
  46.          NewMode.cb     =  12
  47.          NewMode.fbType =   3
  48.          NewMode.color  =   4
  49.          NewMode.col    =  80
  50.          NewMode.row    =  25
  51.          NewMode.hres   = 640
  52.          NewMode.vres   = 480   ! VGA
  53. C        NewMode.vres   = 350   ! EGA
  54.          ReturnCode     = VioSetMode( NewMode, 0 )
  55.          IF( ReturnCode .NE. 0 )  THEN
  56.             WRITE(*,'(A,I6.5)') ' %%% VioSetMode ERROR:',ReturnCode
  57.             STOP
  58.          END IF
  59.       ELSE
  60. *     restore old video-mode
  61.          ReturnCode     = VioSetMode( OldMode, 0 )
  62.          IF( ReturnCode .NE. 0 )  THEN
  63.             WRITE(*,'(A,I6.5)') ' %%% VioSetMode ERROR:',ReturnCode
  64.             STOP
  65.          END IF
  66.          CALL Wait( 500 )
  67.       END IF
  68.  
  69.       END
  70.  
  71.  
  72.  
  73.       SUBROUTINE Wait( MilliSeconds )
  74.  
  75.       INCLUDE 'BSEDOS.FD'
  76.  
  77.       INTEGER*2  ReturnCode
  78.       INTEGER*4  MilliSeconds
  79.  
  80.       ReturnCode = DosSleep( MilliSeconds )
  81.  
  82.       END
  83.  
  84.  
  85.  
  86.       SUBROUTINE VioAddr(VioMemAddr)
  87. ************************************************************************
  88. *     retrieves the address of the physical video buffer
  89. ************************************************************************
  90.  
  91.       INCLUDE 'BSESUB.FD'
  92.  
  93.       INTEGER*2            ReturnCode
  94.       INTEGER*4            VioMemAddr
  95.       RECORD /VIOPHYSBUF/  Phys
  96.  
  97.       Phys.pBuf  = 10 * 2**16
  98.       Phys.cb    = 480 * 640 / 8   ! VGA
  99. *     Phys.cb    = 350 * 640 / 8   ! EGA
  100.       ReturnCode = VioGetPhysBuf(Phys,0)
  101.       IF( ReturnCode .NE. 0 )  THEN
  102.          WRITE(*,'(A,I6.5)') ' %%% VioGetPhysBuf ERROR:',ReturnCode
  103.          STOP
  104.       END IF
  105. * --- create a far pointer
  106.       VioMemAddr = JFIX(Phys.asel(1)) * 2**16
  107.  
  108.       END
  109.  
  110.  
  111.  
  112.       SUBROUTINE ScrLck(Flag)
  113. ************************************************************************
  114. *     locks (Flag=.TRUE.) and unlocks (Flag=.FALSE.) the screen
  115. ************************************************************************
  116.  
  117.       INCLUDE 'BSESUB.FD'
  118.  
  119.       LOGICAL    FLAG
  120.       INTEGER*2  ReturnCode, WaitFlag, Status, VioHandle
  121.       DATA       WaitFlag /1/ ,  VioHandle /0/
  122.  
  123.       IF( Flag )  THEN
  124. * --- wait until the physical screen is available
  125. * --- then lock the screen, that graphics output is possible
  126.          ReturnCode = VioScrLock(WaitFlag, Status, VioHandle)
  127.          IF( ReturnCode .NE. 0 )  THEN
  128.             WRITE(*,'(A,I6.5)') ' %%% VioScrLock ERROR:',ReturnCode
  129.             STOP
  130.          END IF
  131.       ELSE
  132. * --- unlocks the physical screen
  133.          ReturnCode = VioScrUnlock(VioHandle)
  134.          IF( ReturnCode .NE. 0 )  THEN
  135.             WRITE(*,'(A,I6.5)') ' %%% VioScrUnlock ERROR:',ReturnCode
  136.             STOP
  137.          END IF
  138.       END IF
  139.  
  140.       END
  141.  
  142.  
  143.  
  144.       SUBROUTINE SRScrn(VGASeg)
  145. ************************************************************************
  146. *     save and restore screen when the task is switch between
  147. *     foreground and background
  148. *     VGASeg is the address of the physical video buffer
  149. *     this subroutine is normally started in a separate thread
  150. ************************************************************************
  151.  
  152.       INCLUDE 'BSESUB.FD'
  153.  
  154.       INTEGER*4  VGASeg
  155.       INTEGER*2  ReturnCode, Indicator, Notify, Handle
  156.       INTEGER*1  Plane0(38400), Plane1(38400), Plane2(38400),   ! VGA
  157.      &           Plane3(38400)
  158. *     INTEGER*1  Plane0(28000), Plane1(28000), Plane2(28000),   ! EGA
  159. *    &           Plane3(28000)
  160.  
  161.       DATA  Indicator / 0 / ,  Handle / 0 /
  162.  
  163. 1000  C O N T I N U E
  164.       ReturnCode = VioSavRedrawWait( Indicator, Notify, Handle )
  165.       IF( ReturnCode .NE. 0 )  THEN
  166.          WRITE(*,'(A,I6.5)') ' %%% VioSavRedrawWait ERROR:',ReturnCode
  167.          STOP
  168.       END IF
  169.  
  170.       IF( Notify .EQ. 0 )  THEN
  171. * --- save screen
  172.          CALL RColor(0)
  173.          CALL RBtPln(VGASeg,Plane0)
  174.          CALL RColor(1)
  175.          CALL RBtPln(VGASeg,Plane1)
  176.          CALL RColor(2)
  177.          CALL RBtPln(VGASeg,Plane2)
  178.          CALL RColor(3)
  179.          CALL RBtPln(VGASeg,Plane3)
  180.       ELSE
  181. * --- restore screen
  182.          CALL GMode(.TRUE.)
  183.          CALL WColor(0)
  184.          CALL WBtPln(VGASeg,Plane0)
  185.          CALL WColor(1)
  186.          CALL WBtPln(VGASeg,Plane1)
  187.          CALL WColor(2)
  188.          CALL WBtPln(VGASeg,Plane2)
  189.          CALL WColor(3)
  190.          CALL WBtPln(VGASeg,Plane3)
  191.       END IF
  192.       GO TO 1000
  193.  
  194.       END
  195.