module M_history private ! SUBROUTINES: public :: jucmd ! copy a line into history file or edit history if command is "r" and return line public :: getline ! read a line from stdin and call jucmd private :: openbigd ! open history file private :: redol ! edit history private :: notabs ! remove tabs and trail carriage returns and line feeds from lines private :: MODIF ! process modify command to edit a history line private :: CHANGE ! process change command to edit a history line private :: pln ! write message to screen private :: plni ! write message and integer to screen private :: plnr ! write message and real to screen private :: juar ! convert numeric string to numeric value ! FUNCTIONS: private :: inum !(inline) ! should use unused file, not just unit 71 for history ! add option to read in and replace history file contains !xxxxxCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc subroutine jucmd(l) ! if line starts with r word call redol() ! uses unit 71 ! r ! r string ! character(len=*),intent(inout) :: l ! user string integer,save :: iobuf=71 ! unit number to use for redo history buffer integer,save :: iredo ! number of lines read from standard input into redo file logical,save :: lcalled=.false. ! flag whether first time this routine called or not integer,parameter :: READLEN=256 !-----------------------------------------------------------------------======== ! open history file and initialize if(.not.lcalled)then ! open the redo buffer file lcalled=.true. iredo=0 ! number of lines in redo buffer call openbigd(iobuf,' ','scratch',READLEN,ioparc) ! redo buffer if(ioparc.ne.0)then call pln('error creating history file') return endif endif !-----------------------------------------------------------------------======== ilast=len_trim(l) if(ilast.eq.1.and.l(1:1).eq.'r')then ! redo command call redol(l,iobuf,iredo,READLEN,' ') ilast=len_trim(l) elseif(l(1:2).eq.'r ')then ! redo command with a string following call redol(l,iobuf,iredo,READLEN,l(3:max(3,ilast))) ilast=len_trim(l) endif if(ilast.ne.0)then ! put command into redo buffer iredo=iredo+1 write(iobuf,rec=iredo)l endif end subroutine jucmd !xxxxxCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc subroutine openbigd(iunit,fname,sname,irecl,ierr) !@(#) open binary direct access file character(len=*),intent(in) :: fname character(len=*),intent(in) :: sname ilens=len_trim(sname) !----------------------------------------------------------------------- if(sname.eq.'scratch')then open(unit=iunit,status='scratch',form='unformatted',access='direct',recl=irecl,iostat=ierr) else open(unit=iunit,file=fname(:len_trim(fname)),status=sname(:ilens),form='unformatted',access='direct',recl=irecl,iostat=ierr) endif if(ierr.ne.0)then call plni('*openbigd* open error ',ierr) endif end subroutine openbigd !xxxxxCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc subroutine redol(redoline,iobuf,iredo,ibuf0,init) !@(#) redo a previous input line ! redoline ... (o) edited command line to be returned ! iobuf ...... (i) history file unit to read old commands from ! iredo ...... (i) number of lines in history file ! ibuf0 ...... (i) the width of the history file in characters; <= len(redoline) ! init ....... (i) initial command string ! ! to do: ! might want to support a count on change to do the N to the Mth occurrence ! support edit window in change ! prompt to verify each change made with change() ! maybe make .NAME stick into variable $NAME in the calculator ! allow changing the edit characters in a modify character(len=*) :: redoline character(len=*) :: init character(len=256) :: cin, cinbuf ! 1 greater than length of redoline character(len=256) :: numbers save numbers !-----------------------------------------------------------------------======== data numbers/'123456789012345678901234567890123456789012345678901234567890& &12345678901234567890123456789012345678901234567890123456789012345678901234& &56789012345678901234567890123456789012345678901234567890123456789012345678& &901234567890123456789012345678901234567890123456'/ !-----------------------------------------------------------------------======== ipoint=iredo ! initial line in history file to start with icall=0 ! flag if have been thru loop or just got here cin=init ! initialize the directive ibuf=min(ibuf0,len(redoline)) if(ibuf.le.0)return !-----------------------------------------------------------------------======== 1 continue if(ipoint.le.0)then ! if no lines in redo history file redoline=' ' ! make command to 'redo' a blank line since no commands entered else read(iobuf,rec=ipoint,err=999)redoline(1:ibuf) ! get last line in history file as line to redo ! WARNING: OSF1 DIGITAL Fortran 77 Driver V5.2-10 DIGITAL Fortran 77 V5.2-171-428BH ! after this read the following storage was corrupted; switched declaration of ! init and redoline and problem cleared but it is probably corrupting cin and ! doesn't show because of logic. endif !-----------------------------------------------------------------------======== 2 continue ! display buffer and decide on command on first call or read command ilen=max(1,len_trim(redoline(1:ibuf))) ! find length of command to redo write(*,'(a,a)')'!',redoline(:ilen) ! show old command if(icall.ne.0)then ! if not first call read the directive read(5,'(a)',end=999,err=999,iostat=ios)cinbuf call notabs(cinbuf,cin,ilast) elseif(cin.eq.' ')then ! first call and no initial command passed in cin='l -5' ! on first call do this default command if init is blank ilast=4 else ! if initial command was not blank do it instead of default ilast=len_trim(cin) endif icall=icall+1 !-----------------------------------------------------------------------======== if(ilast.eq.0)then ! blank command line; return and execute return !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.' '.or.cin(1:1).eq.'m')then ! modify the string if(cin(1:1) .eq. 'm') then write(*,'(1x,a)')numbers(:len_trim(redoline)) endif call modif(redoline,cin(2:)) !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'c'.or.cin(1:1).eq.'s')then ! change old string to new call change(redoline,cin(1:255),ier,1,ibuf) ! xedit-like change command ! C/STRING1/STRING2/ OR CW/STRING1/STRING2/ (CHANGE IN WINDOW) ! WHERE / MAY BE ANY CHARACTER OTHER THAN W OR BLANK, WHICH IS NOT ! INCLUDED IN STRING1 OR STRING2 !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'u'.or.cin(1:1).eq.'b')then ! up or back through buffer if(cin(2:).eq.' ')then iup=1 else iup=inum(cin(2:)) endif ipoint=max(ipoint-iup,1) goto 1 !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'d'.or.cin(1:1).eq.'f')then ! down or forward through buffer if(cin(2:).eq.' ')then idown=1 else idown=inum(cin(2:)) endif ipoint=min(ipoint+idown,iredo) goto 1 !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'?'.or.cin(1:1).eq.'h')then ! display help call pln('#-------------------------------------------------#') call pln('|REDO MODE OPTIONS (where N is a number): |') call pln('|-------------------------------------------------|') call pln('|LIST HISTORY(and set buffer to last printed line)|') call pln('|l|p N # list from line N. -N shows N last lines|') call pln('|L|P # same as l without line numbers |') call pln('|/string # search for simple string |') call pln('|w file # write entire history to a file |') call pln('|-------------------------------------------------|') call pln('|EDIT BUFFER: |') call pln('|c/oldstring/newstring/ # change/substitute |') call pln('| mod_string # Modify (replace, delete, insert) |') call pln('| # deletes |') call pln('| blank leaves as-is |') call pln('| & replaces with a blank |') call pln('| ^STRING# inserts a string |') call pln('| Any other replaces character |') call pln('|-------------------------------------------------|') call pln('|SET BUFFER TO A LINE: |') call pln('|u N # up/back through buffer |') call pln('|d N # down/forward through buffer |') call pln('|N # load line number |') call pln('|-------------------------------------------------|') call pln('|RETURN TO NORMAL COMMAND MODE: |') call pln('| # return and execute command in buffer |') call pln('|.|q # return a blank line |') call pln('|-------------------------------------------------|') call pln('|HELP: |') call pln('|h|? # display this help text |') call pln('#-------------------------------------------------#') !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'l'.or.cin(1:1).eq.'p')then ! display history buffer file with line numbers if(cin(2:).eq.' ')then istart=iredo-30 ! default is to go back up to 30 else istart=inum(cin(2:)) if(istart.lt.0)then istart=iredo+1+istart endif endif istart=min(max(1,istart),iredo) ! make istart a safe value do 10 i10=istart,iredo read(iobuf,rec=i10,err=999,iostat=ios)redoline(1:ibuf) ix=max(1,len_trim(redoline)) write(*,'(i5.5,1x,a)',err=999)i10,redoline(:ix) 10 continue !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'w'.or.cin(1:1).eq.'D')then ! dump to a file idump=90 if(cin(2:).eq.' ')then open(unit=idump,file='DUMP',err=9991,status='UNKNOWN') else ! messy way to eliminate leading spaces cin=cin(2:) ie=len_trim(cin) do 151 i151=1,ie if(cin(1:1).eq.' ') cin(1:)=cin(2:) 151 continue if(cin.eq.' ')cin='DUMP' ie=len_trim(cin) open(unit=idump,file=cin(:ie),err=9991,status='UNKNOWN') endif do 15 i15=1,iredo read(iobuf,rec=i15,err=9992,iostat=ios)redoline(1:ibuf) ix=max(1,len_trim(redoline)) write(idump,'(a)',err=9993)redoline(:ix) 15 continue close(idump) !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'P'.or.cin(1:1).eq.'L')then ! display history buffer file without line numbers if(cin(2:).eq.' ')then ! default is to go back up to 30 istart=iredo-30 else istart=inum(cin(2:)) if(istart.lt.0)then istart=iredo+1+istart endif endif istart=min(max(1,istart),iredo) ! make istart a safe value do 30 i30=istart,iredo ! easier to cut and paste if no numbers read(iobuf,rec=i30,err=999,iostat=ios)redoline(1:ibuf) ix=max(1,len_trim(redoline)) write(*,'(a)',err=999)redoline(:ix) 30 continue !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'/')then ! display matches in buffer if(ilast.lt.2)goto 2 ! do 20 i20=1,iredo read(iobuf,rec=i20,err=999,iostat=ios)redoline(1:ibuf) if(index(redoline(1:ibuf),cin(2:ilast)).ne.0)then ix=max(1,len_trim(redoline)) write(*,'(i5.5,1x,a)',err=999)i20,redoline(:ix) ipoint=i20 endif 20 continue goto 1 !-----------------------------------------------------------------------======== elseif(cin(1:1).eq.'.'.or.cin(1:1).eq.'q')then ! blank out command and quit goto 999 !-----------------------------------------------------------------------======== else ! assume anything else is a number iread=inum(cin) if(iread.gt.0.and.iread.le.iredo)then read(iobuf,rec=iread,err=999,iostat=ios)redoline(1:ibuf) ipoint=iread endif !-----------------------------------------------------------------------======== endif !-----------------------------------------------------------------------======== goto 2 !-----------------------------------------------------------------------======== 999 continue redoline=' ' return !-----------------------------------------------------------------------======== 9991 continue call pln('*redol* error opening dump file') goto 999 !-----------------------------------------------------------------------======== 9992 continue call pln('*redol* error reading history file') goto 999 !-----------------------------------------------------------------------======== 9993 continue call pln('*redol* error writing dump file') close(idump,err=999) goto 999 !-----------------------------------------------------------------------======== end subroutine redol !-----------------------------------------------------------------------======== !=================================================================================================================================== subroutine notabs(INSTR,OUTSTR,ILEN) ! @(#) convert tabs in input to spaces in output while maintaining columns, assuming a tab is set every 8 characters ! given input string INSTR ! return output string OUTSTR ! o with tabs expanded assuming tabs are set every 8 characters ! o carriage return and line feed characters are replaced with a space ! o ILEN holds the position of the last non-blank character in OUTSTR ! ! ! USES: ! It is often useful to expand tabs in input files to simplify further processing such as tokenizing an input line. ! Some FORTRAN compilers hate tabs in input files; some printers; some editors will have problems with tabs. ! AUTHOR: ! John S. Urban ! ! SEE ALSO: ! GNU/Unix commands expand(1) and unexpand(1) ! IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: instr ! input line to scan for tab characters CHARACTER(LEN=*),INTENT(OUT) :: outstr ! tab-expanded version of INSTR produced INTEGER,INTENT(OUT) :: ilen ! column position of last character put into output string INTEGER,PARAMETER :: tabsize=8 ! assume a tab stop is set every 8th column INTEGER :: ipos ! position in OUTSTR to put next character of INSTR INTEGER :: lenin ! length of input string trimmed of trailing spaces INTEGER :: lenout ! number of characters output string can hold INTEGER :: istep ! counter that advances thru input string INSTR one character at a time CHARACTER(LEN=1) :: c ! character in input line being processed INTEGER :: iade ! ADE (ASCII Decimal Equivalent) of character being tested !=================================================================================================================================== IPOS=1 ! where to put next character in output string OUTSTR lenin=LEN(instr) ! length of character variable INSTR lenin=LEN_TRIM(instr(1:lenin)) ! length of INSTR trimmed of trailing spaces lenout=LEN(outstr) ! number of characters output string OUTSTR can hold OUTSTR=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters !=================================================================================================================================== SCAN_LINE: DO istep=1,lenin ! look through input string one character at a time c=instr(istep:istep) ! get next character iade=ICHAR(c) ! get ADE of the character expand_tabs : SELECT CASE (iade) ! take different actions depending on which character was found CASE(9) ! test if character is a tab and move pointer out to appropriate column ipos = ipos + (tabsize - (MOD(ipos-1,tabsize))) CASE(10,13) ! convert carriage-return and new-line to space ,typically to handle DOS-format files ipos=ipos+1 CASE DEFAULT ! c is anything else other than a tab,newline,or return insert it in output string IF(ipos > lenout)THEN CALL pln("*notabs* output string overflow") EXIT ELSE outstr(ipos:ipos)=c ipos=ipos+1 ENDIF END SELECT expand_tabs enddo SCAN_LINE !=================================================================================================================================== ipos=MIN(ipos,lenout) ! tabs or newline or return characters or last character might have gone too far ilen=LEN_TRIM(outstr(:ipos)) ! trim trailing spaces !=================================================================================================================================== END SUBROUTINE notabs !=================================================================================================================================== !xxxxxCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc SUBROUTINE MODIF(CDUM,CMOD) !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC !@(#) EMULATE THE XEDIT MODIFY EDITOR COMMAND ! ! MODIFY [M] ! ====== ! ACTION- MODIFIES THE LINE CURRENTLY POINTED AT. THE MODIFY DIRECTIVES ! ARE AS FOLLOWS- ! ! DIRECTIVE EXPLANATION ! --------- ------------ ! ^STRING# CAUSES THE STRING OF CHARACTERS BETWEEN THE ^ AND THE ! NEXT # TO BE INSERTED BEFORE THE CHARACTERS POINTED TO ! BY THE ^. AN ^ OR & WITHIN THE STRING IS TREATED AS A ! REGULAR CHARACTER. IF THE CLOSING # IS NOT SPECIFIED, ! XEDIT INSERTS THE REMAINDER OF THE LINE AS IF A # WAS ! SPECIFIED AFTER THE LAST NONBLANK CHARACTER. ! ! THERE ARE TWO EXCEPTIONS. THE COMBINATION ^# CAUSES A # ! TO BE INSERTED BEFORE THE CHARACTER POINTED TO BY THE ! ^, AND AN ^ AS THE LAST CHARACTER OF THE DIRECTIVES ! CAUSES A BLANK TO BE INSERTED. ! ! # (WHEN NOT THE FIRST # AFTER AN ^) CAUSES THE CHARACTER ! ABOVE IT TO BE DELETED. ! ! & REPLACES THE CHARACTER ABOVE IT WITH A SPACE. ! ! (SPACE) A SPACE BELOW A CHARACTER LEAVES IT UNCHANGED. ! ! ANY OTHER CHARACTER REPLACES THE CHARACTER ABOVE IT. ! ! EXAMPLE- ! THE INPUT LINE........ 10 THIS STRING TO BE MORTIFD ! THE DIRECTIVES LINE... ^ IS THE# D# ^IE ! ALTERED INPUT LINE.... 10 THIS IS THE STRING TO BE MODIFIED !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CHARACTER*(*) CDUM,CMOD !STRING TO BE MODIFIED .LE. 160 CHARACTER C*3 PARAMETER (MAXSCRA=255) !LENGTH OF SCRATCH BUFFER CHARACTER*(MAXSCRA) DUM2 !SCRATCH CHARACTER BUFFER LOGICAL LINSRT !FLAG FOR INSERTING DATA ON LINE SAVE C DATA C/'#&^'/ !ASSIGN DEFAULT EDIT CHARACTERS LMAX=MIN0(LEN(CDUM),MAXSCRA) !DETERMINE MAXIMUM LINE LENGTH LMX1=LMAX-1 !MAX LINE LENGTH -1 DUM2=' ' !INITIALIZE NEW LINE LINSRT=.FALSE. !INITIALIZE INSERT MODE IEND=len_trim(CMOD) !DETERMINE END OF MODS I=0 !CHAR COUNTER FOR MOD LINE CMOD IC=0 !CHAR COUNTER FOR CURRENT LINE CDUM ICHAR=0 !CHAR COUNTER NEW LINE DUM2 11 CONTINUE I=I+1 !NEXT CHAR IN MOD LINE IF(ICHAR.GT.LMX1)GOTO 999 !IF TOO MANY CHARS IN NEW LINE IF(LINSRT) THEN !IF INSERTING NEW CHARS IF(I.GT.IEND) CMOD(I:I)=C(1:1) !FORCE END OF INSERT MODE IF(CMOD(I:I).EQ.C(1:1))THEN !IF END OF INSERT MODE LINSRT=.FALSE. !RESET INSERT MODE FLAG IF(IC+1.EQ.I)THEN !NULL INSERT STRING ICHAR=ICHAR+1 !INCRMENT COUNTER FOR NEW LINE DUM2(ICHAR:ICHAR)=C(1:1) !INSERT INSERT MODE TERMINATOR ENDIF DO J=IC,I !LOOP OF NUMBER OF CHARS INSERTED ICHAR=ICHAR+1 !INCRMENT COUNTER FOR NEW LINE IF(ICHAR.GT.LMAX)GOTO 999 !IF AT BUFFER LIMIT, QUIT DUM2(ICHAR:ICHAR)=CDUM(J:J) !APPEND CHARS FROM ORIG LINE ENDDO !...WHICH ALIGN WITH INSERTED CHARS IC=I !RESET CHAR COUNT TO END OF INSERT GOTO 1 !CHECK NEW LINE LENGTH AND CYCLE ENDIF !END OF TERMINATED INSERT LOGIC ICHAR=ICHAR+1 !INCREMENT NEW LINE COUNT DUM2(ICHAR:ICHAR)=CMOD(I:I) !SET NEWLINE CHAR TO INSERTED CHAR ELSE !IF NOT INSERTING CHARACTERS IC=IC+1 !INCREMENT ORIGINAL LINE COUNTER IF(CMOD(I:I).EQ.C(1:1))GOTO 1 !IF DELETE CHAR. NO COPY AND CYCLE IF(CMOD(I:I).EQ.C(3:3))THEN !IF BEGIN INSERT MODE LINSRT=.TRUE. !SET INSERT FLAG TRUE GOTO 1 !CHECK LINE LENGTH AND CONTINUE ENDIF !IF NOT BEGINNING INSERT MODE ICHAR=ICHAR+1 !INCREMENT NEW LINE COUNTER IF(CMOD(I:I).EQ.C(2:2))THEN !IF REPLACE WITH BLANK DUM2(ICHAR:ICHAR)=' ' !SET NEWLINE CHAR TO BLANK GOTO 1 !CHECK LINE LENGTH AND CYCLE ENDIF !IF NOT REPLACE WITH BLANK IF(CMOD(I:I).EQ.' ')THEN !IF BLANK, KEEP ORIGINAL CHARACTER DUM2(ICHAR:ICHAR)=CDUM(IC:IC) !SET NEW CHAR TO ORIGINAL CHAR ELSE !IF NOT KEEPING OLD CHAR DUM2(ICHAR:ICHAR)=CMOD(I:I) !REPLACE ORIGINAL CHAR WITH NEW ENDIF !END CHAR KEEP OR REPLACE ENDIF !END INSERT OR NO-INSERT 1 CONTINUE IF(I.LT.LMAX)GOTO 11 !CHECK FOR END OF LINE REACHED !AND CYCLE IF OK 999 CDUM=DUM2 !SET ORIGINAL CHARS TO NEW CHARS RETURN !RETURN END SUBROUTINE MODIF !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc SUBROUTINE CHANGE(CDUM,CSTRNG,IER,ML,MR) ! CHANGE A CHARACTER STRING !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC !@(#) CHANGE A CHARACTER STRING LIKE XEDIT CHANGE OR C COMMAND ! CDUM CONTAINS LINE TO BE CHANGED ! CSTRNG CONTAINS THE COMMAND CHANGING THE STRING(LESS THE COUNT PARAM) ! IER RETURNS AN ERROR CODE. IF IER = -1 BAD DIRECTIVE ! = 0 NO CHANGES MADE ! > 0 THEN IER CHANGES MADE ! ML SETS THE LEFT MARGIN ! MR SETS THE RIGHT MARGIN ! ! THIS ROUTINE DOES NOT ALLOW FOR SEPARATORS ON THE CHANGE COMMAND ! (...) OR .NOT.CONTAINING (---). ! ! THE COMMAND MUST BE OF THE FORM: ! C/STRING1/STRING2/ OR CW/STRING1/STRING2/ (CHANGE IN WINDOW) ! WHERE / MAY BE ANY CHARACTER OTHER THAN W OR BLANK, WHICH IS NOT ! INCLUDED IN STRING1 OR STRING2 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CHARACTER*(*) CDUM,CSTRNG ! USE STRING LENGTH PARAMETER (MAXSCR=255) ! MAXIMUM SCRATCH LENGTH CHARACTER*(MAXSCR) STR1,STR2,DUM1 ! SCRATCH STRING BUFFERS LMAX=MIN0(LEN(CDUM),MAXSCR) ! MAX LENGTH OF NEW STRING LCDUM=len_trim(CDUM) ! GET NON-BLANK LENGTH OF LINE ! CRACK THE DIRECTIVES LINE STR1=' ' ! INITIALIZE STRINGS STR2=' ' ! INITIALIZE STRINGS LDIR=len_trim(CSTRNG) ! FIND LAST CHARACTER IN DIRECTIVE ID=2 IF(CSTRNG(2:2).EQ.'W')ID=3 ! CHECK FOR WINDOW OPTION ID1=ID+1 ! DELIMITER CHARACTER + 1 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(LDIR.LT.3+ID)GOTO 1001 ! IF BAD DIRECTIVE IF(CSTRNG(ID:ID).NE.CSTRNG(LDIR:LDIR))GOTO 1003 ! IF BAD DELIM IDEL=INDEX(CSTRNG(ID1:LDIR-1),CSTRNG(ID:ID)) ! FIND MID DELIM IF(IDEL.EQ.0)GOTO 1004 ! IF NO MID DELIM IF(IDEL.GT.1)STR1=CSTRNG(ID1:IDEL+ID-1) ! STRING TO BE CHANGED LS1=IDEL-1 ! STRING OF STRING TBC IF(IDEL+ID.LT.LDIR-1)STR2=CSTRNG(IDEL+ID1:LDIR-1) ! NEW STRING LS2=LDIR-IDEL-ID1 ! LENGTH OF NEW STRING IF(LS2.GT.0)THEN IF(INDEX(STR2(:LS2),CSTRNG(ID:ID)).NE.0)GOTO 1005 ! EXTRA DELIMITER ENDIF !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! DIRECTIVES HAVE BEEN CRACKED, NOW IMPLEMENT IF(ID.EQ.2)THEN ! NO WINDOW IL=1 ! IL TO LEFT MARGIN IR=LMAX ! IR TO RIGHT MOST ALLOWED ELSE ! IF WINDOW IS SET IL=ML ! USE LEFT MARGIN IR=MIN0(MR,LMAX) ! USE RIGHT MARGIN OR RIGHT MOST ENDIF ! END OF WINDOW SETTINGS !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(IL.EQ.1)THEN ! IF LEFT MARGIN IS 1 DUM1=' ' ! BEGIN WITH A BLANK LINE ELSE ! IF LEFT MARGIN NOT 1 DUM1=CDUM(:IL-1) ! BEGIN WITH WHAT'S BELOW MARGIN ENDIF !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(LS1.EQ.0)THEN ! c//str2/ means insert str2 at beginning of line (or left margin) ICHAR=LS2 + LCDUM IF(ICHAR.GT.LMAX)GOTO 1002 IF(LS2.GT.0)THEN DUM1(IL:)=STR2(:LS2)//CDUM(IL:LCDUM) ELSE DUM1(IL:)=CDUM(IL:LCDUM) ENDIF CDUM(1:LMAX)=DUM1(:LMAX) IER=1 ! Made one change. Actually, c/// should maybe return 0 RETURN ENDIF !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IER=0 ICHAR=IL IC=IL !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 100 CONTINUE IND=INDEX(CDUM(IC:),STR1(:LS1))+IC-1 IF(IND.EQ.IC-1.OR.IND.GT.IR)GOTO 200 IER=IER+1 IF(IND.GT.IC)THEN LADD=IND-IC IF(ICHAR-1+LADD.GT.LMAX)GOTO 1002 DUM1(ICHAR:)=CDUM(IC:IND-1) ICHAR=ICHAR+LADD ENDIF IF(ICHAR-1+LS2.GT.LMAX)GOTO 1002 IF(LS2.NE.0)THEN DUM1(ICHAR:)=STR2(:LS2) ICHAR=ICHAR+LS2 ENDIF IC=IND+LS1 GOTO 100 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 200 IF(IER.EQ.0)RETURN LADD=LCDUM-IC IF(ICHAR+LADD.GT.LMAX)GOTO 1002 DUM1(ICHAR:)=CDUM(IC:max(ic,LCDUM)) CDUM=DUM1(:LMAX) RETURN !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 1001 call pln('*change* bad directive') goto 999 1002 call pln('*change* new line will be too long') goto 999 1003 call pln('*change* unmatched delimiters') goto 999 1004 call pln('*change* missing middle delimiter') goto 999 1005 call pln('*change* extra delimiter') goto 999 999 continue IER=-1 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC RETURN END SUBROUTINE CHANGE !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc subroutine pln(inline) implicit none character(len=*),intent(in) :: inline write(*,'(a)')inline end subroutine pln !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc subroutine plni(inline,int) implicit none character(len=*),intent(in) :: inline integer,intent(in) :: int character(len=256) :: scratch_line write(scratch_line,'(a,i0)')inline,int call pln(scratch_line) end subroutine plni !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc subroutine plnr(inline,val) implicit none real,intent(in) :: val character(len=*),intent(in) :: inline character(len=256) :: scratch_line write(scratch_line,'(a,g20.13)')inline,val call pln(scratch_line) end subroutine plnr !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCcccccccc integer function inum(inline) ! @(#) returns an integer number from a numeric character string. ! return 0 for a blank string integer,parameter :: IBIG=2147483647 ! assumed overflow value (2**31-1) integer,parameter :: SMALL=0.01 ! and epsilon value character(len=*),intent(in) :: inline if(inline.eq.' ')then inum=0 elseif(inline.eq.'*')then inum=-99999 else call juar(inline,valu,ierr) ! on most machines int() would catch the overflow, but this is safer if(valu.gt.IBIG)then call plnr('*inum* integer overflow 2**31-1 <',valu) inum=IBIG elseif(valu.gt.0)then inum=int(valu+SMALL) else inum=int(valu-SMALL) endif endif end function inum !=======================================================================-------- subroutine juar(inline,valu,ierr) ! @(#) returns real value from numeric character string NOT USING CALCULATOR ! Copyright(c) 1989 John S. Urban all rights reserved ! ! returns a real value from a numeric character string. ! ! o works with any g-format input, including integer, real, and ! exponential. ! ! if an error occurs in the read, iostat is returned in ierr and ! value is set to zero. if no error occurs, ierr=0. implicit none ! character(len=*),intent(in) :: inline real,intent(out) :: valu integer,intent(out) :: ierr character(len=13) :: frmt ierr=0 write(frmt,101)len(inline) 101 format( '(bn,g',i5,'.0)' ) read(inline,fmt=frmt,iostat=ierr)valu if(ierr.ne.0)then valu=0.0 call pln('*juar* - cannot produce number from this string') call pln(inline) endif end subroutine juar !=======================================================================-------- subroutine getline(line) character(len=256) :: line write(*,'(a)',advance='no')'>' ! write a prompt read(*,'(a)',iostat=ios) line if(ios.eq.0)then ! good read if(line(1:1).eq.'^')then line='r '//line(2:254) endif call jucmd(line) else ! bad read from input endif return end subroutine getline !=======================================================================-------- end module M_history