c*****TAKES RED GREEN BLUE AS INPUT AND COMPUTES A INTEGER NUMBER
c*****THAT IS SAVED IN A DISK FILE AND IN MEMORY.
c*****THE STORED MEMORY ARRAY IS THEN PLOTTED ON THE SCREEN.
c*****OR A DISK FILE IS READ AND PLOTTED ON YHE SCREEN.
      integer rgb,red,gr,bl,jshade(300)
      character resp,ifile*56
      rgb(red,gr,bl)=(#3f3f3f.and.(red.or.ishft(bl,16).or.ishft(gr,8)))

      open(10,file='color.dat',status='unknown')
      
      write(*,'(a\)') ' want to create colors(y);n reads color file:'
      read (*,'(a)') resp
      if(resp.eq.'y'.or.resp.eq.'Y') go to 5
        write(*,'(a\)') ' enter input file name:'
        read (*,'(a)') ifile
        open(10,file=ifile,status='old')
        k=62
        read(10,*) (jshade(i),i=1,k)
        go to 40
5     k = 0
10    write(*,'(a\)') ' enter red grn blu : '
      read *,ir,ig,ib
      if(ir.eq.99) go to 30
      icolor=rgb(ir,ig,ib)
      k = k + 1
      jshade(k) = icolor
      go to 10
30    write(10,'((5x,''&'',7(i8,'','')))') (jshade(i),i=1,k)
40    call tcol(jshade,k)
      stop
      end
c*******************************************************************************
c      include 'c:\contour\graph.fi'
      include 'fgraph.fi'
      subroutine tcol(ikol,nclr)
c      include 'c:\contour\graph.fd'
      include 'fgraph.fd'
      common/scalef/ iwc0,jwc0,nxhpix,nyhpix,xpix,ypix,xscr,yscr
      integer*2 mode
      mode = 19
      call setcrt(mode)
      call pcolor(ikol,nclr)
      iwc0=1
      jwc0=198
      iclr=0
      is=1
      ie=65
10    j=0
      do 30 k=1,25
      iclr=iclr+1
      do 20 m=1,5
      j=j+1
      call onepix(is,j,iclr,ie)
20    continue
      if(iclr.eq.nclr) go to 40
      j=j+1
30    continue
      is=is+ 67
      ie=is+ 64
      go to 10
40    pause
      mode = 3
      call setcrt(mode)
      stop
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine onepix(ii,jj,iclr,ncol)
      common/scalef/ iwc0,jwc0,nxhpix,nyhpix,xpix,ypix,xscr,yscr

      itemp = iwc0 + ii-1
      itemp1 =iwc0 + (ncol-1)
      jtemp = jwc0 - (jj-1)

      call mcolor(iclr)
      call makel(itemp,jtemp,itemp1,jtemp)

      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine pcolor(kol,nclr)
      include 'c:\contour\graph.fd'
      include 'fgraph.fd'
      integer*4 remappalette
      integer*4 kol(1)
      do 20 i=1,nclr
      istat=remappalette(i,kol(i))
       if(istat.eq.-1) then
         print *,'error remapping the pallete'
         print *,'index no. ',i,' value: ',kol(i)
         stop
       endif
20    continue
      return
      end
       subroutine setcrt(mode)
       integer*2 setvideomode,mode,istat
* arguments to setvideomode()
	INTEGER*2 $MAXRESMODE,$MAXCOLORMODE,$DEFAULTMODE,$TEXTBW40,
     +            $TEXTC40,$TEXTBW80,$TEXTC80,$MRES4COLOR,$MRESNOCOLOR,
     +            $HRESBW,$TEXTMONO,$HERCMONO,$MRES16COLOR,$HRES16COLOR,
     +            $ERESNOCOLOR,$ERESCOLOR,$VRES2COLOR,$VRES16COLOR,
     +            $MRES256COLOR,$ORESCOLOR
	PARAMETER($MAXRESMODE   =-3)    ! graphics mode with highest resolution
	PARAMETER($MAXCOLORMODE =-2)    ! graphics mode with most colors
	PARAMETER($DEFAULTMODE  =-1)    ! restore screen to original mode
	PARAMETER($TEXTBW40      =0)    ! 40 x 25 text, 16 grey
	PARAMETER($TEXTC40       =1)    ! 40 x 25 text, 16/8 color
	PARAMETER($TEXTBW80      =2)    ! 80 x 25 text, 16 grey
	PARAMETER($TEXTC80       =3)    ! 80 x 25 text, 16/8 color
	PARAMETER($MRES4COLOR    =4)    ! 320 x 200, 4 color
	PARAMETER($MRESNOCOLOR   =5)    ! 320 x 200, 4 grey
	PARAMETER($HRESBW        =6)    ! 640 x 200, BW
	PARAMETER($TEXTMONO      =7)    ! 80 x 25 text, BW
	PARAMETER($HERCMONO      =8)    ! 720 x 348, BW for HGC
	PARAMETER($MRES16COLOR   =13)   ! 320 x 200, 16 color
	PARAMETER($HRES16COLOR   =14)   ! 640 x 200, 16 color
	PARAMETER($ERESNOCOLOR   =15)   ! 640 x 350, BW
	PARAMETER($ERESCOLOR     =16)   ! 640 x 350, 4 or 16 color
	PARAMETER($VRES2COLOR    =17)   ! 640 x 480, BW
	PARAMETER($VRES16COLOR   =18)   ! 640 x 480, 16 color
	PARAMETER($MRES256COLOR  =19)   ! 320 x 200, 256 color
	PARAMETER($ORESCOLOR     =64)   ! 640 x 400, 1 of 16 colors (Olivetti)


       istat = setvideomode(mode)
       if(istat.eq.0) then
       print *,'desired video mode not supported'
       endif
       return
       end
