$STORAGE: 2 $NOFLOATCALLS c----------------------------------------------------------------------- c c Daily Appointment subroutine c c part of Mitch Wyle's DTC program c c Input: c line - 72 characters; Format: D [mmddyy [hh:mm>HH:MM [appointment]]] c c Output: c display screen (see below) c c----------------------------------------------------------------------- c SUBROUTINE day(line2) c c Declarations: c CHARACTER LINE2(80) character line(80) CHARACTER*18 LINE16 EQUIVALENCE(LINE(1),LINE16) c input line CHARACTER*2 TEMP2 character temp(2) EQUIVALENCE(TEMP(1),TEMP2) c temporary string converting array character appoin(60) c appointment string character work(60) c scratch array for handling scheduling character esc c escape character integer id c Julian Day integer im c Julian Month integer iye c Julian Year integer rdspfg c flag to reverse sense of display of time character junk(130) integer ctlfg c misc control flags here INTEGER IDYR,IDMO,IDDY COMMON/DEFDAT/IDYR,IDMO,IDDY common/ctls/rdspfg,ctlfg character fname(60) CHARACTER*18 FNAM60 EQUIVALENCE(FNAME(1),FNAM60) integer fnsz common/fn/fnsz,fname c c Initialize: c DO 933 IV=1,80 933 LINE(IV)=LINE2(IV) iterm = 0 c Output terminal unit number esc = 27 c Escape character C call idate(im,id,iye) c initialize to today's date IM=IDMO ID=IDDY IYE=IDYR c c Parse that line c c c Was there a D on the front? If so, trim it off: c IDMX=0 If ( line(1) .eq. 'D' .or.line(1).eq.'d') then Do 1 i=1,70 line(i) = line(i+2) 1 Continue End If c c If the date was specified in command line then c set id, im and iye to the right values: c CALL DATMUN(LINE) Do 22 i=1,6 IDL=I If ( ( line(i) .gt. '9' ) .or. ( line(i) .lt. '0' ) ) goto 33 22 Continue c Six numbers in a row, so decode into numeric date: temp(1) = line(1) temp(2) = line(2) read(temp2,2)im c decode ( 2 , 2 , temp ) im temp(1) = line(3) temp(2) = line(4) c decode ( 2 , 2 , temp ) id read(temp2,2)id temp(1) = line(5) temp(2) = line(6) c decode ( 2 , 2 , temp ) iye read(temp2,2)iye IDDY=ID IDYR=IYE IDMO=IM 2 Format(i2) c c Now discard the date part from line string: c Do 3 i=1,63 line(i) = line(i+7) 3 continue GOTO 3307 33 continue C GOT A DELIMITER NOT A NUMERIC IN 1ST 6 COLS SO MAKE THAT THE START OF LINE C BY CHOPPING OFF ALL THAT'S EARLIER IF(IDL.LE.0.OR.IDL.GT.6)GOTO 3307 DO 3308 I=1,63 LINE(I)=LINE(I+IDL) 3308 CONTINUE 3307 CONTINUE c c Clear the screen, move the cursor to the top part, c set up appointments screen: c write(iterm,4) esc,'[','2','J',esc,'[','0','1',';','0', 1 '1','H' 4 format(1X,79a1) write(iterm,5) im,id,iye 5 format(1X,10X,'Appointments For ',i2,'/',i2,'/',i2,/) Do 8 i=8,16 If ( i .gt. 12 ) then j = i - 12 Else j = i End If write(iterm,6) j 6 format(1x,i2,':00 -') write(iterm,7) j 7 format(1x,i2,':30 -') 8 Continue write(iterm,9) 9 format(1x,'Evening:',/,79('=')) c c Was a time input? Did it accompany an appointment string? c Why do fools fall in love? c IDMX=0 if(line(1).eq.'e')LINE(1)='E' If (((line(1).le.'9').and.(line(1).ge.'0')).OR.LINE(1) 1 .EQ.'E') then c c Parse the time string c IF(LINE(1).NE.'E') THEN If ( line(2) .eq. ':' ) then temp(1) = '0' temp(2) = line(1) READ(TEMP2,2)IHT C decode ( 2 , 2 , temp2 ) iht if ( iht .lt. 5 ) iht = iht + 12 IHHR=IHT iht = iht * 10 If ( line(3) .eq. '3' ) iht = iht + 3 Else If ( line(3) .eq. ':' ) then temp(1) = line(1) temp(2) = line(2) READ(TEMP2,2)IHT C decode ( 2 , 2 , temp2 ) iht If ( iht .lt. 5 ) iht = iht + 12 IHHR=IHT iht = iht * 10 If ( line(4) .eq. '3' ) iht = iht + 3 End If END IF C HANDLE "EV" MODIFIER FOR EVENING APPOINTMENTS IF(LINE(1).EQ.'E')IHT=170 C 170 IS SPECIAL EVENING CODE..... CORRESPONDS TO 5PM... IHMX=1 IDHR=0 IOMX=6 IF (LINE(6).EQ.'>') THEN C IF 2 RANGES EXIST DUPLICATE MESSAGE AFTER EXTRACTING 2ND RANGE C OF HH:MM temp(1)=line(7) temp(2)=line(8) READ(temp2,2)ihmx c DECODE(2,2,LINE(7))IHMX IF(IHMX.LT.5)IHMX=IHMX+12 c DECODE(2,2,LINE(10))IMMX temp(1)=line(10) temp(2)=line(11) READ(temp2,2)immx IF(IMMX.NE.30)IMMX=0 C COUNT HALF HOURS IN GIVEN INTERVAL ... IDHR=(IHMX-IHHR)*2 C FIND NUMBER ENTRIES TO SHOVE OUT... IF(IMMX.NE.0)IDHR=IDHR+1 IF(IHT.NE.(10*IHHR))IDHR=IDHR-1 IDHR=MAX0(1,IDHR) IDMX=IDHR C ABOVE CLAMPS POSITIVE... NO INVALID ENTRIES PLEASE... IOMX=12 END IF c c Now look for space delimiter to trim off the time c of day part, and then extract the appointment: c C USE IOMX SO WE SCAN PAST 2ND RANGE IF ANY... Do 11 io=1,IOMX If ( line(1) .eq. ' ') goto 12 c Found a space; exit loop Do 10 i=1,71 line(i) = line(i+1) 10 Continue 11 Continue 12 Continue c Label to Exit loop c c Was there an appointment string input? c If so, put it in file, and display it on screen. c If not, move cursor to correct time on screen, c then input the appointment, put in file and re-display it. c If ( line(1) .lt. ' ' ) then itemp = iht / 10 if ( itemp .gt. 7 ) itemp = itemp - 7 iy = 2 * itemp + 1 If ( ( ( iht/10 ) * 10 ) .ne. iht ) iy = iy + 1 ix = 10 call dtcat(ix,iy) c close(iterm) C ... SLIGHTLY SCREWY CODE HERE... write(0,1955) 1955 format('+ Enter appt here:') read(0,913,END=914) (line(i),i=1,60) 913 format(1X,60a1) 13 format('+',60a1) 914 CONTINUE End If c copy appointment for use later... Do 1118 ivx=1,60 1118 work(ivx)=line(ivx) iwy=iye iwm=im iwd=id iwht=iht If ( line(1) .ge. ' ' ) then C ADD CLOSE TO GUARANTEE NO FAILURES... CLOSE(1) C If we are using the 'S' command, ONLY add meetings to the indirected C files, not to the current (control) file. IF(CTLFG.NE.1) THEN Open ( 1,file=FNAM60,status='OLD',form='FORMATTED') do 8877 iv=1,9999 c simulate append access by reading to eof read(1,8879,end=8878,err=8878)junk 8879 format(130a1) 8877 continue 8878 continue backspace 1 BACKSPACE 1 IHTSV=IHT IF(IDMX.LT.1)IDMX=1 DO 3005 IVX=1,IDMX write(1,614) iye,im,id,iht,(line(i),i=1,60) IF((IHT/10)*10.EQ.IHT)THEN 614 format(3i2,i3,60a1) C THIS IS AN EVEN HOUR ... ADD THE HALF HOUR IHT=IHT+3 ELSE C IHT IS A HALF HOUR ... MAKE UP TO NEXT HOUR IHT=IHT+7 END IF 3005 CONTINUE IHT=IHTSV 14 format(3i2,i3,60a1,\) write(1,1600) 1600 format(/) close(1) END IF End If End If nunit=1 Open (nunit,file=FNAM60,status='OLD' ,form='FORMATTED') 100 continue c loop back up here to continue reading and c processing input file: read(nunit,200,end=400) ihy,ihm,ihd,iht,(line(k),k=1,60) 200 format(3i2,i3,60a1) if(ihy.eq.99.and.nunit.eq.1)then nunit=2 c null terminate the filename somewhere c lines with 99 in 1st 2 cols are filenames only... c use = as delimiter of filename line(60)=32 kkk=0 do 1068 ii=1,59 if(line(ii).le.31.or.line(ii).eq.'=')kkk=1 if(kkk.gt.0)line(ii)=32 c if(line(ii).eq.'=')line(ii)=32 1068 continue C SKIP WRITING IN SUBSIDIARY FILES IF NOT APPORPRIATE FOR COMMAND... if(CTLFG.eq.0) goto 1119 c **** c on scheduling multiple dates via the S function, use this occasion to c add the record to everyone's calendar file. CLOSE(2) Open ( 2,file=line16,status='OLD',form='FORMATTED') do 8977 iv=1,9999 c simulate append access by reading to eof read(2,8979,end=8978,err=8978)junk 8979 format(130a1) 8977 continue 8978 continue backspace 2 backspace 2 IHTSV=IHT iht=iwht IF(IDMX.LT.1)IDMX=1 DO 3007 IVX=1,IDMX write(2,614) iwy,iwm,iwd,iht,(work(i),i=1,60) IF((IHT/10)*10.EQ.IHT)THEN C IF THIS IS AN EVEN HOUR ... ADD THE HALF HOUR IHT=IHT+3 ELSE C IF THIS IS A HALF HOUR ... MAKE UP TO NEXT HOUR IHT=IHT+7 END IF 3007 CONTINUE IHT=IHTSV write(2,1600) close(2) c **** 1119 continue CLOSE(NUNIT) c7663 continue DO 7660 II=1,40 7660 IF(LINE(II).LE.' ')LINE(II)=' ' IF(LINE(1).EQ.' ')THEN DO 7661 II=1,40 7661 LINE(II)=LINE(II+1) c goto 7663 END IF Open(nunit,file=line16,status='old',form='formatted') goto 100 end if If ((iye .eq. ihy) .and. (im .eq. ihm) .and. (id .eq. ihd)) then itemp = iht / 10 if ( itemp .gt. 7 ) itemp = itemp - 7 iy = 2 * itemp + 1 If (((iht/10)*10) .ne. iht) iy = iy + 1 ix = 10 call dtcat(ix,iy) write(iterm,300) (line(k),k=1,60) 300 format(1X,60a1,\) call dtcat(1,22) End If goto 100 400 continue c no more appointments left in file. if(nunit.ne.1)then 1067 continue close(2) nunit=1 goto 100 end if close(1) return end