DataMuseum.dk

top - download

    Length: 14244 (0x37a4)
    Types: TextFile
    Names: »demo.subs.f«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/euug-87hel/sec1/utep/demo.subs.f« 

TextFile

******************************************************************************
*
* subroutine mountn(iclrf,iclrb) does the following:
*                     +draw the mountains with red & yellow colors on 
*                      a window(0,10,0,10),in calling program the
*                      mountains can be positioned by adjusting the
*                      viewport on the screen.
*****************************************************************************
	subroutine mountn(iclrf,iclrb)
	integer iclrf,iclrb
	call sec(iclrf)
	call clr
	call scl(1.5,1.5)
	call triang
c
	call clr
	call tlt(1.5,0.0)
	call triang
c
	call clr
	call scl(2.0,2.0)
	call tlt(2.5,0.0)
	call triang
c
	call clr
	call move(4.5,0.0)
	call line(5.5,0.0)
	call scl(1.5,1.5)
	call tlt(5.5,0.0)
	call triang
c
	call clr
	call scl(2.0,2.0)
	call tlt(7.0,0.0)
	call triang
c
	call clr
	call tlt(9.0,0.0)
	call triang
c
	call clr
	call move(10.0,1.0)
	call line(9.5,1.5)
	call line(9.25,1.25)
	call line(9.0,2.0)
	call line(8.75,1.75)
	call line(8.25,2.75)
	call line(7.25,1.75)
	call line(7.0,2.0)
	call line(6.5,1.5)
	call line(6.25,1.75)
	call line(5.5,0.75)
	call line(5.25,1.0)
	call line(4.75,0.5)
	call line(4.25,1.25)
	call line(4.0,1.0)
	call move(3.25,1.5)
	call line(2.5,2.5)
	call line(2.0,1.5)
	call line(1.75,1.75)
	call line(1.25,1.0)
	call line(0.5,2.25)
	call line(0.0,1.5)
c
c add color
	call move(0.75,1.25)
	call ifl
	call move(1.25,0.25)
	call ifl
	call move(2.0,0.5)
	call ifl
	call move(2.75,0.25)
	call ifl
	call move(3.5,1.75)
	call ifl
	call move(6.0,0.5)
	call ifl
	call move(6.25,0.25)
	call ifl
	call move(7.25,0.25)
	call ifl
	call move(8.0,0.5)
	call ifl
	call move(8.5,0.5)
	call ifl
	call move(9.5,0.5)
	call ifl
	call move(9.75,0.25)
	call ifl
c use another color for the rest of the mountains
	call sec(iclrb)
	call move(9.0,1.0)
	call ifl
	call move(9.9,0.5)
	call ifl
	call move(8.0,2.25)
	call ifl
	call move(7.0,0.25)
	call ifl
	call move(7.0,1.25)
	call ifl
	call move(5.25,0.5)
	call ifl
	call move(4.75,0.25)
	call ifl
	call move(2.5,2.25)
	call ifl
	call move(1.75,1.5)
	call ifl
	call move(0.25,1.0)
	call ifl
c
	return
	end
***************************************************************************
*
* subroutine river(iclr) does the following:
*                  + draw the river in cyan on a window(0,10,0,10)
*                    calling program can position river by using
*                    transformation or adjusting viewport on screen.
*************************************************************************
	subroutine river(iclr)
	integer iclr
	call sec(iclr)
	call move(0.0,0.0)
	call line(5.0,0.0)
	call line(5.0,0.75)
	call line(5.25,1.0)
	call line(5.25,1.75)
	call line(5.75,2.5)
	call line(5.75,3.0)
	call line(5.5,3.25)
	call line(5.5,3.75)
	call line(5.75,4.0)
	call line(5.75,4.5)
	call line(6.0,5.0)
	call line(6.0,5.75)
	call line(6.25,6.0)
	call line(6.5,7.0)
	call line(6.5,7.5)
	call line(6.75,8.5)
	call line(6.75,9.0)
	call line(7.0,9.5)
	call line(7.0,10.0)
	call line(5.0,10.0)
	call line(4.5,9.5)
	call line(4.5,9.0)
	call line(4.25,8.75)
	call line(4.25,8.5)
	call line(3.75,8.0)
	call line(3.75,7.25)
	call line(3.5,7.0)
	call line(3.5,6.25)
	call line(3.25,6.0)
	call line(3.25,5.5)
	call line(3.0,5.0)
	call line(3.0,4.5)
	call line(2.75,4.0)
	call line(2.25,3.5)
	call line(2.25,3.25)
	call line(2.0,3.0)
	call line(2.0,2.5)
	call line(1.5,2.0)
	call line(1.25,2.0)
	call line(1.0,1.75)
	call line(1.0,1.25)
	call line(0.5,0.75)
	call line(0.5,0.5)
	call line(0.0,0.0)
c add color
	call move(2.0,1.0)
	call ifl
c
	return
	end
*****************************************************************************
*
* subroutine sunris(isclr,irclr) does the following:
*                   + draw the sun & its rays on a window(0,10,0,10)
*                     (color is yellow), calling program can position 
*                    the sun by using transformation or adjusting 
*                    the viewport on the screen.
*****************************************************************************
	subroutine sunris(isclr,irclr)
	integer isclr,irclr
c draw the sun and color it with yellow.
	call move(5.0,5.0)
	call sec(isclr)
	call dcl(1.0)
	call ifl
c draw the yellow rays coming out of the sun.
	call sec(irclr)
	call move(5.0,6.5)
	call line(5.0,8.0)
	call move(6.0,7.0)
	call line(6.5,7.75)
	call move(6.0,6.0)
	call line(7.0,7.0)
	call move(6.5,5.5)
	call line(7.5,5.75)
	call move(6.5,4.5)
	call line(7.5,4.25)
	call move(6.0,4.0)
	call line(7.0,3.0)
	call move(6.0,3.0)
	call line(6.5,2.25)
	call move(5.0,3.5)
	call line(5.0,2.0)
	call move(4.0,3.0)
	call line(3.5,2.25)
	call move(4.0,4.0)
	call line(3.0,3.0)
	call move(3.5,4.5)
	call line(2.5,4.25)
	call move(3.5,5.0)
	call line(2.0,5.0)
	call move(3.5,5.5)
	call line(2.5,5.75)
	call move(4.0,6.0)
	call line(3.0,7.0)
	call move(4.0,7.0)
	call line(3.5,7.75)
c
	return
	end
*************************************************************************
*
* subroutine sunset does the following:
*                    + draw the sun in red.
*                    + draw the stars in white.
************************************************************************
	subroutine sunset
c
	call clr
	call move(5.0,7.25)
	call sec(7)
	call dcl(0.75)
	call ifl
c
	call clr
	call scl(0.1,0.1)
	call tlt(9.0,9.5)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(8.5,7.5)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(6.5,7.0)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(6.0,9.5)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(5.0,6.0)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(4.0,9.0)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(3.0,8.0)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(2.0,7.5)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(1.5,8.75)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(0.5,9.25)
	call star(7)
	call clr
	call scl(0.1,0.1)
	call tlt(0.25,7.5)
	call star(7)
	return
	end
****************************************************************************
*
* subroutine namesr does the following:
*                     + draw the word SUNRISE on a window(0,10,0,10)
*                       and the calling program can position it by
*                       using transformations or adjusting viewport
*                       on the screen.
****************************************************************************
	subroutine namesr
c
	call move(0.75,1.0)
	call line(0.0,1.0)
	call line(0.0,0.5)
	call line(0.75,0.5)
	call line(0.75,0.0)
	call line(0.0,0.0)
c
	call move(1.0,1.0)
	call line(1.0,0.0)
	call line(1.75,0.0)
	call line(1.75,1.0)
c
	call move(2.0,0.0)
	call line(2.0,1.0)
	call line(2.75,0.0)
	call line(2.75,1.0)
c
	call move(3.0,0.0)
	call line(3.0,1.0)
	call line(3.75,1.0)
	call line(3.75,0.5)
	call line(3.0,0.5)
	call move(3.5,0.5)
	call line(3.75,0.0)
c
	call move(4.0,1.0)
	call line(4.5,1.0)
	call move(4.25,1.0)
	call line(4.25,0.0)
	call move(4.0,0.0)
	call line(4.5,0.0)
c
	call move(5.75,1.0)
	call line(5.0,1.0)
	call line(5.0,0.5)
	call line(5.75,0.5)
	call line(5.75,0.0)
	call line(5.0,0.0)
c
	call move(6.75,1.0)
	call line(6.0,1.0)
	call line(6.0,0.0)
	call line(6.75,0.0)
	call move(6.0,0.5)
	call line(6.75,0.5)
c
	return
	end

************************************************************************
*
* subroutine namess does the following:
*                     + draw the word SUNSET on the completed image.
*
***********************************************************************
	subroutine namess
c
	call move(0.75,1.0)
	call line(0.0,1.0)
	call line(0.0,0.5)
	call line(0.75,0.5)
	call line(0.75,0.0)
	call line(0.0,0.0)
c
	call move(1.0,1.0)
	call line(1.0,0.0)
	call line(1.75,0.0)
	call line(1.75,1.0)
c
	call move(2.0,0.0)
	call line(2.0,1.0)
	call line(2.75,0.0)
	call line(2.75,1.0)
c
	call move(3.75,1.0)
	call line(3.0,1.0)
	call line(3.0,0.5)
	call line(3.75,0.5)
	call line(3.75,0.0)
	call line(3.0,0.0)
c
	call move(4.74,1.0)
	call line(4.0,1.0)
	call line(4.0,0.0)
	call line(4.75,0.0)
	call move(4.0,0.5)
	call line(4.75,0.5)
c
	call move(5.0,1.0)
	call line(6.0,1.0)
	call move(5.5,1.0)
	call line(5.5,0.0)
	return
	end
***************************************************************************
*
* subroutine image does the following:
***************************************************************************
	subroutine image
	common/tbl/itable(10,2)
	common/contr/icnt
c
	itable(4,1)=icnt
	call bondry
	itable(4,2)=icnt-1
	call clr
	itable(3,1)=icnt
	call ground(2)
	itable(3,2)=icnt-1
c
	itable(1,1)=icnt
	call sky(6)
	itable(1,2)=icnt-1
c
	itable(5,1)=icnt
	call clr
	call scl(0.5,0.5)
	call tlt(2.0,0.0)
	call river(4)
	itable(5,2)=icnt-1
c
	itable(7,1)=icnt
	call clr
	call tlt(0.0,7.5)
	call cloud(7)
	itable(7,2)=icnt-1
c
	itable(8,1)=icnt
	call clr
	call sec(3)
	call scl(0.5,0.5)
	call tlt(0.0,9.5)
	call namesr
	itable(8,2)=icnt-1
c
	itable(9,1)=icnt
	call clr
	call scl(0.5,0.5)
	call tlt(0.0,9.5)
	call namess
	itable(9,2)=icnt-1
c
	itable(10,1)=icnt
	call sunset
	itable(10,2)=icnt-1
c
	call vwport(0.0,10.0,5.0,10.0)
	itable(6,1)=icnt
	call mountn(11,10)
	itable(6,2)=icnt-1
c
	call vwport(0.0,10.0,0.0,10.0)
	itable(2,1)=icnt
	call msris(9,3,4.0,1.0,1.0)
	itable(2,2)=icnt-1
c
	do 20 i=1,8
	call show(i)
20	continue
	call pause
	return
	end
*******************************************************************************
*
* subroutine msris(iclr1,iclr2,txx,tyy,sxx) does the following:
*******************************************************************************
	subroutine msris(iclr1,iclr2,txx,tyy,sxx)
	integer iclr1,iclr2
	real txx,tyy,sxx
c
	call clr
	call scl(sxx,sxx)
	call tlt(txx,tyy)
	call sunris(iclr1,iclr2)
	return
	end
******************************************************************************
*
* subroutine ground(iclr) does the following:
*******************************************************************************
	subroutine ground(iclr)
	integer iclr
c
	call clr
	call dfr(iclr,0.0,0.0,10.0,5.0)
	return
	end
*******************************************************************************
*
* subroutine sky(iclr) does the following:
*******************************************************************************
	subroutine sky(iclr)
	integer iclr
c
	call clr
	call dfr(iclr,0.0,5.0,10.0,10.0)
	return
	end
****************************************************************************
*
* subroutine cloud(iclr) does the following:
****************************************************************************
	subroutine cloud(iclr)
	integer iclr
c
	call sec(iclr)
	call move(0.5,1.0)
	call dcl(0.5)
	call ifl
	call move(0.25,1.0)
	call ifl
c
	call move(1.75,1.0)
	call dcl(1.0)
	call ifl
c
	call move(3.0,1.0)
	call dcl(0.75)
	call ifl
	return
	end
*******************************************************************************
*
* subroutine show(iseg) does the following:
*******************************************************************************
	subroutine show(iseg)
	integer iseg
	common/tbl/itable(10,2)
	integer ibeg,iend
c
	ibeg=itable(iseg,1)
	iend=itable(iseg,2)
	call intrprt(ibeg,iend)
	return
	end
******************************************************************************
*
* subroutine image2 does the following:
******************************************************************************
	subroutine image2
	common/tbl/itable(10,2)
	common/contr/icnt
c
	call clr
c
	call vwport(0.0,10.0,0.0,10.0)
c
	icnt=itable(2,1)
	call msris(3,3,2.5,3.0,1.0)
	itable(2,2)=icnt-1
c
	icnt=itable(7,1)
	call clr
	call tlt(1.0,7.5)
	call cloud(7)
	itable(7,2)=icnt-1
	call show(1)
	call show(2)
	call show(4)
	call show(6)
	call show(7)
	call pause
	return
	end
****************************************************************************
*
* subroutine image3 does the following:
***************************************************************************
	subroutine image3
	common/tbl/itable(10,2)
	common/contr/icnt
c
	call clr
	call vwport(0.0,10.0,0.0,10.0)
	icnt=itable(1,1)
	call sky(0)
	itable(1,2)=icnt-1
	call show(1)
c
	icnt=itable(2,1)
	call msris(3,3,0.0,3.0,1.0)
	itable(2,2)=icnt-1
c
	icnt=itable(1,1)
	call sky(6)
	itable(1,2)=icnt-1
c
	icnt=itable(7,1)
	call clr
	call tlt(6.0,7.5)
	call cloud(7)
	itable(7,2)=icnt-1
c
	call show(1)
	call show(2)
	call show(4)
	call show(6)
	call show(7)
	call pause
c
	return
	end
******************************************************************************
*
* subroutine image4 does the following:
******************************************************************************
	subroutine image4
	common/tbl/itable(10,2)
	common/contr/icnt
c
	call clr
	call vwport(0.0,10.0,0.0,10.0)
	icnt=itable(1,1)
	call sky(0)
	itable(1,2)=icnt-1
	call show(1)
c
	icnt=itable(2,1)
	call msris(19,9,-4.0,2.0,1.0)
	itable(2,2)=icnt-1
c
	icnt=itable(1,1)
	call sky(21)
	itable(1,2)=icnt-1
c
	icnt=itable(7,1)
	call clr
	call tlt(6.0,7.5)
	call cloud(6)
	itable(7,2)=icnt-1
c
	do 20 i=1,7
	call show(i)
20	continue
	call show(9)
	call pause
	return
	end
******************************************************************************
*
* subroutine image5 does the following:
*****************************************************************************
	subroutine image5
	common/tbl/itable(10,2)
	common/contr/icnt
c
	call clr
	call vwport(0.0,10.0,0.0,10.0)
	icnt=itable(3,1)
	call ground(15)
	itable(3,2)=icnt-1
c
	icnt=itable(1,1)
	call sky(0)
	itable(1,2)=icnt-1
c
	icnt=itable(5,1)
	call clr
	call scl(0.5,0.5)
	call tlt(2.0,0.0)
	call river(12)
	itable(5,2)=icnt-1
c
	icnt=itable(7,1)
	call clr
	call tlt(6.0,7.5)
	call cloud(8)
	itable(7,2)=icnt-1
c
	call vwport(0.0,10.0,5.0,10.0)
	icnt=itable(6,1)
	call mountn(10,11)
	itable(6,2)=icnt-1
c
	call show(1)
	do 20 i=3,7
	call show(i)
20	continue
	call show(4)
	call show(10)
c
	call pause
	return
	end
**************************************************************************
*
* subroutine pause does the following:
*************************************************************************
	subroutine pause
	character*1 answer
c
	do 30 i=1,4
	write(0,10)
10	format(5x,'To continue press G ')
	read(5,20)answer
20	format(a1)
	if(answer.eq.'G'.or.answer.eq.'g')then
	  i=5
	else
	  call error(1)
	endif
30 	continue
	return
	end