c SCRLIB: a library of screen management routines for creating c forms-oriented displays for F77 programs. c It allows the rapid creation of a screen of fields which may be c randomly edited before return to the user program. c SCRLIB may be used under both RT-11 and TSX+. It checks for which c one and allows for it. c In its original form SCRLIB allows for up to 40 fields on a screen. c This is controlled by a single parameter inside SCRLIB.INC, and can c be changed if desired to reduce the code space required, as can the c maximum string length. c c subroutine EDITIT c The master routine which takes over from the user program to do c the full-screen editing. include 'SCRLIB.INC' integer*2 escf !State variable for ESC strings integer*2 ibuff !Pointer within field OK=.true. do 10 i=1,maxind revers=.true. call sayC(iX(i),iY(i),field(i)) !Paint the fields in 10 continue type 1000,esc 1000 format('+',A,'=',$) !Application mode keypad call goxy(iX(1),iY(1)) buff=field(1) ind=1 !Field number ibuff=1 !Pointer within buffer changd=.false. !Current field status escf=0 call snglon() !tell O/S to honor bits 12 & 14, to c ! pass ESC, rctrlo, etc. 20 jch=ittinR() !Get next character from KB c NB: under RT-11 this will tight-loop, while under TSX+ it will c do the equivalent of a SPND/RSUM. Either is OK. c jch=(byt1,byt2)=(ans,ans2) in common, so we now have ans set by jch c c case ans=: put escf=1, loop if(ans.eq.esc)then escf=1 goto 20 endif c case escf=1 & ans=[: put escf=2, loop (key mode reset) c case escf=1 & ans=O: put escf=2, loop (key mode set) if(escf.eq.1)then if(ans.eq.'['.or.ans.eq.'O')then escf=2 else escf=0 !Invalid sequence discarded endif goto 20 endif c case escf=2 if(escf.eq.2)then c case ans=A: Up-arrow, do it (incl buffer), loop if(ans.eq.'A')then call uparrw(ibuff) c case ans=B: Down-arrow, do it (incl buffer), loop elseif(ans.eq.'B')then call dnarrw(ibuff) c case ans=C: Right-arrow, do it, loop elseif(ans.eq.'C')then call rtarrw(ibuff) c case ans=D: Left-arrow, do it, loop elseif(ans.eq.'D')then call lfarrw(ibuff) c case ans=M: finish, buffer, return elseif(ans.eq.'M')then call carret(ibuff) !First treat as , then exit ind=0 !Reset for the subsequent GETx calls call snglof() !Back to normal mode return c case invalid esc sequence: ignore it else endif escf=0 !End of sequence: reset counter goto 20 !and loop endif c Not in an ESC sequence: see what it is c case ans=: left-arrow, space, left-arrow, loop if(ans.eq.DEL)then if(ibuff.gt.1)then !But only if NOT at left end iend=L(ind) do 30 i=ibuff-1,iend-1 buff(i:i)=buff(i+1:i+1) 30 continue buff(iend:iend)=' ' !Pad out with blanks changd=.true. revers=.true. call sayC(iX(ind),iY(ind),buff) !Repaint field ibuff=ibuff-1 call goXY(iX(ind)+ibuff-1,iY(ind)) endif c case ans=: end of this field, depending on editing done elseif(ans.eq.CR)then call carret(ibuff) c case ans=: discard elseif(ans.eq.LF)then continue c case ans < : No good! bell, loop elseif(ans.lt.' ')then type 1010,bell 1010 format('+',a1,$) c else put character in buffer, loop else buff(ibuff:ibuff)=ans changd=.true. type 1020,esc,ans,esc !Character in revers video 1020 format('+',A,'[7m',A,A,'[0m',$) ibuff=ibuff+1 if(ibuff.gt.L(ind))call dnarrw(ibuff) endif goto 20 end c Respond to Left Arrow Key c Move within a field c subroutine LFARRW(ibuff) c Called by EDITIT include 'SCRLIB.INC' if(ibuff.le.1)goto 10 ibuff=ibuff-1 type 1000,esc 1000 format('+',a1,'[1D',$) 10 return end c Respond to Right Arrow Key c Move within a field c subroutine RTARRW(ibuff) c Called by EDITIT include 'SCRLIB.INC' if(ibuff.ge.L(ind))goto 10 ibuff=ibuff+1 type 1000,esc 1000 format('+',a1,'[1C',$) 10 return end c Respond to Up Arrow Key c Move from field to field, leaving editing changes made to data c subroutine UPARRW(ibuff) c Called by EDITIT include 'SCRLIB.INC' if(changd)then call convrt(OK) else OK=.true. endif if(OK)then ind=ind-1 !Next field up if(ind.lt.1)ind=maxind !Wrap to bottom from top buff=field(ind)(1:L(ind)+1) !Include | at end changd=.false. !New field ibuff=1 else if(ibuff.gt.L(ind))ibuff=1 endif call goXY(iX(ind)+ibuff-1,iY(ind)) !Go to it return end c Respond to Down Arrow Key c subroutine DNARRW(ibuff) c Called by EDITIT include 'SCRLIB.INC' if(changd)then call convrt(OK) !Update the variables else OK=.true. endif if(OK)then ind=ind+1 !Next field down if(ind.gt.maxind)ind=1 !Wrap bottom to top buff=field(ind)(1:L(ind)+1) !Include | at end changd=.false. !New field ibuff=1 else if(ibuff.gt.L(ind))ibuff=1 !No error message: CONVRT did endif call goXY(iX(ind)+ibuff-1,iY(ind)) !Go to it return end c Respond to Carraige Return c This "enters" the changed data into the field and jumps to the next c field. c subroutine CARRET(ibuff) c Called by EDITIT include 'SCRLIB.INC' integer*2 ibuff if(changd)then !If any changes made, then: iend=L(ind) do 10 i=ibuff,iend !Pad out with blanks buff(i:i)=' ' 10 continue if(intf(ind).or.realf(ind)) buff(ibuff:ibuff)=',' !Delimit number buff(iend+1:iend+1)='|' !Put in trailing '|' c revers=.true. call sayC(iX(ind),iY(ind),buff) !Clarify display, overwrite endif call dnarrw(ibuff) return end c Check what has been typed in is OK, update field and variables c subroutine CONVRT(OK) c Called by UpArrw, DnArrw include 'SCRLIB.INC' common /confn/string character*42 string real*4 Pmax(12) real*4 Nmax(12) data Pmax/10.,100.,1000.,1.e4,1.e5,1.e6, 1 1.e7,1.e8,1.e9,1.e10,1.e11,1.e12/ data Nmax/-1.,-10.,-100.,-1000.,-1.e4,-1.e5, 1 -1.e6,-1.e7,-1.e8,-1.e9,-1.e10,-1.e11/ if(.not.OK)then !Clear previous error message call goXY(1,24) type 1000,esc !Clear away any error messages on line 24 1000 format('+',A,'[2K',$) endif !Caller will restore cursor if(intf(ind))then read(buff,frmt(ind),err=10,end=10) nvar(ind) call sayJ(iX(ind),iY(ind),nvar(ind),frmt(ind)) field(ind)=string !string from SayJ elseif(realf(ind))then j=L(ind) buff(j+1:j+1)=',' !Just in case, to limit the string read(buff,1010,err=20,end=20) F !TRY to convert it 1010 format(F14.0) ! with a very general format i=L(ind)-LDP(ind)-1 !Now check that the number is within if(F.le.Nmax(i).or.F.ge.Pmax(i))goto 20 !allowed range fvar(ind)=F !OK, save it call sayF(iX(ind),iY(ind),fvar(ind),frmt(ind)) field(ind)=string !string from SayF else revers=.true. call sayC(iX(ind),iY(ind),buff) field(ind)=buff endif OK=.true. return 10 call goXY(1,24) !X,Y type 1020,esc,bell 1020 format('+',A,'[2K',A,'CONVRT-F-conversion to integer failed',$) OK=.false. return 20 call goXY(1,24) type 1030,esc,bell 1030 format('+',A,'[2K',A,'CONVRT-F-conversion to real failed',$) OK=.false. return end subroutine SayDat(ix,iy,day,month,year) c Special format routine for displaying Dates integer*2 ix,iy,day,month,year call sayI(ix,iy,day,'(I2)') type 1000 1000 format('+','/',$) call sayI(ix+3,iy,month,'(I2)') type 1000 call sayI(ix+6,iy,year,'(I2)') return end c Special format single variable response routines: allow editing c only in that field. c subroutine RespnS(jx,jy,string,flag) c Single character string variable returned in UPPER case character*42 string integer*2 jx,jy character*1 flag include 'SCRLIB.INC' character*1 resp equivalence (resp,byt1) !from SCRLIB.INC, along with jch call sayC(jx,jy,string) if(flag(1:1).lt.' ')flag(1:1)=' ' 10 type 1010,esc,flag,esc,esc !Show last or default reply 1010 format('+',A,'[1;7m', A, A,'[0m', A,'[D',$) ! and backspace call snglon() !tell TSX+ to honor bits 12 & 14, etc jch=ittinR() !Get a character from KB w'out echo call snglof() !Revert to normal, ASAP c Ignore any control characters, including LF, but accept CR if(jch.lt."040.and.jch.ne."015)goto 10 if(jch.eq."015)goto 20 !Special case: call ucase(resp) !Uppercase it type 1020,esc,resp !Echo to user 1020 format('+',A,'[7m', A,$) type 1030,esc !Turn OFF reverse video 1030 format('+',A,'[0m',$) if(resp.gt.' ')flag=resp !If not a null response, return new return ! char, else return default. 20 jch=ittinR() !get any trailing return end subroutine RespnI(jx,jy,string,I) c Return an I*2 number to a prompt integer*2 jx,jy,I character*42 string include 'SCRLIB.INC' 10 call errset(56,.true.,.false.,.true.,.false.,) call sayC(jx,jy,string) type 1010,esc,esc !Reverse video for 6 places 1010 format('+',A1,'[1;7m', ' ', A1,'[6D',$) ! and backspace read(5,1000,err=20) I 1000 format(I) call ttnv return 20 call goXY(1,24) type 1020,bell 1020 format('+',A,'RESPNI-F-Invalid integer*2 response',$) call isleep(0,0,2,0) goto 10 end