      integer rgb,red,gr,bl,ishade(50),jshade(300)
      rgb(red,gr,bl)=(#3f3f3f.and.(red.or.ishft(bl,16).or.ishft(gr,8)))

      open(10,file='shade.dat',status='unknown')
      
      k = 0
10    write(*,'(2a\)') ' enter no. shades,start & incr',
     & '(99 0 0 to quit): '
      read *,nshade,s,sinc
      if(nshade.eq.99) go to 30
      write(*,'(a\)') ' enter red grn blu : '
      read *,ir,ig,ib
      icolor=rgb(ir,ig,ib)
      print *,icolor
      do 20 i = 1,nshade
      call cshade(icolor,s,ishade(i))
      s=s+sinc
20    continue
      write(10,'((5x,''&'',7(i8,'','')))') (ishade(i),i=1,nshade)
      do 25 i = 1,nshade
      k = k + 1
      jshade(k) = ishade(i)
25    continue
      go to 10
30    call tcol(jshade,k)
      stop
      end
c*******************************************************************************
	subroutine cshade( icolor, brite, ishade )
c    transform color value to lighter or darker shade.
c  primary colors range from 0 ( no color ) to icmax ( saturated ).
c  'icolor' ( input color ) is defined midway in the brightness range, 
c           where at least one primary is icmax and one primary is zero.
c  'brite'  range is -1 (black) to 1 (white) with zero as no change.
c  'icmx'   optional saturation, include for gray shades where 
c           icolor(1:3)= ( icmax/2, icmax/2, icmax/2 ).
c
c  colors are lightened by reducing color values, keeping the same ratio.
c  colors are darkened by adding complementary color.
c
      integer rgb,red,gr,bl
      dimension jcolor(3)
      rgb(red,gr,bl)=(#3f3f3f.and.(red.or.ishft(bl,16).or.ishft(gr,8)))

	if ( brite .eq. 0 ) then
       ishade=icolor
       return
       endif

	bright = -brite
       jcolor(1)=#00003f.and.icolor
       jcolor(2)=ishft((#003f00.and.icolor),-8)
       jcolor(3)=ishft((#3f0000.and.icolor),-16)
c
	if ( bright .gt. 0 ) then
c  lighten color
	  ratio = 1.0 - bright
         do i = 1, 3
 	    jcolor(i) = nint( ratio * float( jcolor(i) ) )
         enddo
         ishade = rgb(jcolor(1),jcolor(2),jcolor(3))
         print *,'neg inp',jcolor
c
       else
c  darken color with complementary color
       icmax = max( jcolor(1), jcolor(2), jcolor(3) )
	do i = 1, 3
	  icomp = int( -bright * float( icmax - jcolor(i) ) )
	  jcolor(i) = jcolor(i) + icomp
	enddo
       ishade = rgb(jcolor(1),jcolor(2),jcolor(3))
         print *,'pos inp',jcolor
       endif
c
	return
	end
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)
c      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
