home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.update.uu.se
/
ftp.update.uu.se.2014.03.zip
/
ftp.update.uu.se
/
pub
/
rainbow
/
msdos
/
decus
/
RB101
/
year.for
< prev
Wrap
Text File
|
1995-05-19
|
4KB
|
192 lines
$STORAGE: 2
$NOFLOATCALLS
c-----------------------------------------------------------------------
c
c Year-at-a-glance subroutine
c
c part of Mitch Wyle's DTC program
c
c Input:
c line - 72 character string; Format: Y [yy]
c
c Output:
c display screen (see below)
c
c-----------------------------------------------------------------------
c
SUBROUTINE year(line)
c
c Declarations:
c
character line(84)
c input line
character temp(2)
character*2 temp2
equivalence(temp(1),temp2)
c temporary string converting array
character esc
c escape character
integer id
c Julian Day
integer im
c Julian Month
integer iye
c Julian Year
integer iyo
c y offset for where to put month data
integer ix
c x coord of cursor
integer iy
c y coord of cursor
integer img
c month loop index goes from 1 to 12
integer jg
c index offset defined by img
integer ii
c implied do loop index variable
INTEGER IDYR,IDMO,IDDY
COMMON/DEFDAT/IDYR,IDMO,IDDY
character monthn(9)
c string month name
real badf77
c Maybe error in array subscripts
character wknam(21)
c string containing names of days of week
real badftn
c Hoolay kan
character ihold
c hold the screen
c
c Initialize:
c
Do 121 ii=1,21
wknam(ii) = ' '
121 continue
wknam(1) = 'S'
wknam(2) = 'u'
wknam(4) = 'M'
wknam(5) = 'o'
wknam(7) = 'T'
wknam(8) = 'u'
wknam(10)= 'W'
wknam(11)= 'e'
wknam(13)= 'T'
wknam(14)= 'h'
wknam(16)= 'F'
wknam(17)= 'r'
wknam(19)= 'S'
wknam(20)= 'a'
wknam(21)= '|'
iterm = 0
c Output terminal unit number
esc = 27
c Escape character
IM=IDMO
ID=IDDY
IYE=IDYR
C call idate(im,id,iye)
c initialize to today's date
If (line(1) .eq. 'Y') then
Do 1 i=1,70
c Trim of the 'Y' from the
line(i) = line(i+2)
c command line
1 Continue
End If
If ( ( line(1) .ge. '0' ) .and. ( line(2) .le. '9' ) ) then
temp(1) = line(1)
temp(2) = line(2)
read(temp2,2)iye
c decode ( 2 , 2 , temp ) iye
IDYR=IYE
End If
2 Format(i2)
Temp(1)=32
Temp(2)=32
write(iterm,3) esc,'<',esc,'[','2','J'
c Clear screen invoke ANSI
write(iterm,3) esc,'[','?','3','h'
c set screen to 132 col
write(temp2,2)iye
c encode ( 2 , 2 , temp ) iye
ix = 30
iy = 11
call dtcat(ix,iy)
c Display this year in double
write(iterm,3) '1',
1 ' ','9',' ',temp(1),' ',temp(2)
c in the middle of the screen
iy = 12
call dtcat(ix,iy)
c write(iterm,3) esc,'#','4','1',
c 1 ' ','9',' ',temp(1),' ',temp(2)
c double size
Do 4 img = 1,12
c for each month:
call gaby(img,monthn)
c Find out name, and display it
jg = img - 1
c x coord of cursor for month
if (jg .gt. 5) jg = jg - 6
c name in outstring
ix = ( jg * 22 ) + 1
c
if (img .gt. 6) then
c First six months on top
iy = 13
c last six months on bottom
else
c half of screen
iy = 2
end if
call dtcat(ix,iy)
c Position cursor and:
write(iterm,3) (monthn(ii),ii=1,9)
3 format(1x,21a1,\)
c Write out the name.
If (img .gt. 6) then
c Write out day of week
iy = 14
c Header names also, one
else
c line below month names
iy = 3
end if
call dtcat(ix,iy)
write(iterm,3) (wknam(ii),ii=1,21)
If (img .gt. 6) then
c Write out numbers for
iy = 15
c Days in each month:
iyo = 12
else
iy = 4
iyo = 1
end if
call dany(ib,il,img,iye)
c Now position the month
ix = ix - 1
c Off by 1. CORRECT IT
ixspa = 0
ixo = 0
iyspa = 0
call mischy(ib,il,ix,ixspa,iyo,iyspa)
4 Continue
c return next line read in and allow main pgm to decode...
read(0,80,END=914)line
80 format(84a1)
914 write(0,3) esc,'[','?','3','l'
return
end