Lynn McGuire wrote:

Here is the source of lower.for, of unknown authorship, acquired from
the Internet years ago:

c Converted to lower case 91-10-28
c WARNING--DO NO UPSHIFT THIS PROGRAM SOURCE*************
c --SPECIFICALLY ROUTINES GETNXT & WORK***********
c
c UPPER CASE FORTRAN TO lower case converter
c Convert a fortran source file:
c downshift non-comments,non-strings,non-holleriths
c Vers 0.00 - converted from UPPER source
c Vers 0.1 - Fix same comment bug that was in UPPER
c COnverted to VP2200. Deleted ALTER, UPALL.
C .21 - Lines starting with # are treated as comments.
C They cannot be continued.
c
implicit none
integer smax ,nstore
parameter (smax=5000)
character*1 ctue(100)
character*2000 cline,qline,zline
character*80 store(smax),cbuf,fname,oname
character dates*8,vers*4
logical end,have,decl
integer i,lcount,len,qlen,lines,comm(smax),tabs
c
vers='0.21'
write(0,40) vers
40 format(' Lower ',a,' Converts FORTRAN source to lower CASE.',/
& ' Will not shift inside strings comments or ',
& 'Holleriths.')
call getopts(fname,oname)
call openf(fname,oname)
call fdate(dates)
write(2,42) dates
42 format('c Converted to lower case ',a8)
c
call init(ctue)
lcount=0
c READ FIRST LINE INTO TEMPORARY BUFFER
read(1,43,end=9999) cbuf
43 format(a80)
c USED TO INDICATE THAT WE ALREADY HAVE NEXT LINE READ INTO BUF
have=.true.
c LCOUNT indicates how many lines processed.
lcount=1
c
c Read next line, concatenating continuation lines.
c Comments are written out immediately or if between ctuation
c lines are stored (yuk).
c
50 call getnxt(cline,len,cbuf,have,end,lines,lcount,
& ctue,store,nstore,comm)
if(end) goto 999
tabs=0
call dotab(cline,qline,len,qlen,tabs)
call sqze(qline,zline,qlen)
call clssfy(zline,decl)
if(decl) then
call low(qline,1,len)
else
call work(qline,len,lcount)
endif
call output(qlen,qline,ctue,store,nstore,comm)
goto 50
c==============
999 continue
write(0,80)lcount
80 format(1x,i6,' LINES CONVERTED')
stop
9999 write(0,*)'UNEXPECTED END OF FILE on unit 1'
stop
end
c
subroutine getnxt(cline,len,cbuf,have,end,lines,lcount
& ,ctue,store,nstore,comm)
c GET NEXT LINE. OUTPUT COMMENTS IMMEDIATELY if possible.
c
implicit none
integer smax ,nstore
parameter (smax=5000)
character*2000 cline
character*80 cbuf,store(smax)
character*1 ctue(100),c
integer len,lines,lcount,comm(smax),ll,lastnb,l
logical end,have,first
c
c if no lines in buf then already reached EOF
if(.not.have) goto 999
10 c=cbuf(1:1)
if(c.eq.'C'.or.c.eq.'c'.or.c.eq.'*'.or.c.eq.'#') then
if(c.eq.'C') cbuf(1:1)='c'
c
ll=lastnb(cbuf,1,80)
write(2,40) cbuf(1:ll)
40 format(a)
c
read(1,40,end=999) cbuf
lcount=lcount+1
have=.true.
goto 10
endif
c
c BUF IS NOT A COMMENT. transfer into cline
c
cline(1:72)=cbuf(1:72)
len=72
lines=1
nstore=0
l=1
first=.true.
c
c SEE IF NEXT LINE IS A CONTINUATION; if so concatenate & read again
c
20 read(1,40,end=99) cbuf
lcount=lcount+1
l=l+1
have=.true.
c=cbuf(1:1)
if(c.eq.'C'.or.c.eq.'c'.or.c.eq.'*'.or.c.eq.'#') then
c Is a comment. Store it.
if(c.eq.'C') cbuf(1:1)='c'
c
if(nstore.lt.smax) then
nstore=nstore+1
store(nstore)=cbuf
comm(nstore)=l
else if(first) then
write(0,*)'More than ',smax,' consecutive comments'
write(0,*)'**** REMAINDER WILL BE SKIPPED ********'
first=.false.
endif
goto 20
endif
c
if(cbuf(6:6).eq.' ') return
c The ugly tab again... next line not actually a continuation.
if(ichar(cbuf(1:1)).eq.9) return
if(ichar(cbuf(2:2)).eq.9) return
if(ichar(cbuf(3:3)).eq.9) return
if(ichar(cbuf(4:4)).eq.9) return
if(ichar(cbuf(5:5)).eq.9) return
if(ichar(cbuf(6:6)).eq.9) return
if(lines.gt.100) stop ' ERROR IN GETNXT. TOO MANY CTUATION LINES'
c STORE CONTINUATION CHARACTER SEPARATELY
call lower(cbuf(6:6))
ctue(lines)=cbuf(6:6)
cline(1+len:66+len)=cbuf(7:72)
len=len+66
if(len.gt.2000) stop 'LEN ERROR IN GETNXT'
lines=lines+1
goto 20
c EOF.
c Haven't any lines in BUF, but have a line in cline to be upshifted
99 have=.false.
return
999 len=0
have=.false.
end=.true.
return
end
c
subroutine work(cline,len,lcount)
c
c Process the line: upshift non-comments,non-strings,non-holleriths
c
implicit none
character cline*2000,c*1,q*1
integer class,case,value,count,lcount,len,i,n
common /ctable/nonpr,l_alpha,u_alpha
& ,specl,czero,nznum,ignore,quote
& ,lookup(0:255)
integer nonpr,l_alpha,u_alpha
& ,specl,czero,nznum,ignore,quote,lookup,kchar
c
case=0
q=' '
do 100 i=7,len
c=cline(i:i)
c Determine class of character c
kchar=ichar(c)
class=lookup(kchar)
if(class.eq.nonpr) then
write(0,*)'UNPRINTABLE CHARACTER AT COLUMN ',i,' LINE ',
& lcount,' ASCII VALUE ',ichar(c)
else if(kchar.eq.9) then
write(0,*)'TAB CHARACTER AT COLUMN ',i, 'LINE ', lcount
endif
c IF(C.NE.' ')WRITE(6,*)'I ',I,'C',C,' CLASS',CLASS,' CASE ',CASE
c
if(case.eq.1) then
c in string,looking for terminal quote
c end of string
if(c.eq.q) case=5
else if(case.eq.2) then
c Have just encountered a special. Look for 1-9
if(class.eq.nznum) then
case=3
c Start accumulating value of holler. qual.
n=value(c)
else if(class.eq.quote) then
c Not holler qual - is start of a string. eg ('
case=1
q=c
else if(class.eq.l_alpha.or.class.eq.u_alpha.or.
& class.eq.czero) then
case=0
else if(class.eq.specl.or.class.eq.ignore) then
c another special but not '. CASE stays 2
case=2
else
case=0
endif
else if(case.eq.3) then
c look for rest of probable Holler. qualifier
if(class.eq.nznum.or.class.eq.czero) then
n=10*n+value(c)
else if(c.eq.'H'.or.c.eq.'h') then
c A HOLLERITH!
case=4
count=0
cline(i:i)='h'
else if(class.eq.quote) then
c Wasn't a Holler. Is a string
case=1
q=c
c Not a 'string', not Holler.
else if(class.eq.specl) then
case=2
else if(class.eq.l_alpha.or.class.eq.u_alpha) then
case=0
endif
else if(case.eq.4) then
c we are in a hollerith. Skip n charactes
count=count+1
c last hollerith char
if(count.gt.n) case=0
endif
c
if(case.eq.0) then
if(class.eq.quote) then
c Start string
case=1
q=c
c
else if(class.eq.specl) then
case=2
else
if(class.eq.u_alpha) then
cline(i:i)=char(kchar+32)
endif
endif
else if(case.eq.5) then
case=0
endif
100 continue
c
return
end
c
subroutine dotab(cline,q,len,qlen,tabs)
implicit none
character cline*2000,q*500,c*1,qfound*1
logical instr
integer i,len,qlen,j,tabs,kchar,class,lastnb
common /ctable/nonpr,l_alpha,u_alpha,
& specl,czero,nznum,ignore,quote,lookup(0:255)
integer nonpr,l_alpha,u_alpha
& ,specl,czero,nznum,ignore,quote,lookup
j=0
lastnb=0
instr=.false.
do 2 i=1,len
c=cline(i:i)
class=lookup(ichar(c))
kchar=ichar(c)
c Is this an ascii tab ?
if(.not.instr.and.(class.eq.quote)) then
instr=.true.
qfound=c
else if(instr.and.c.eq.qfound) then
instr=.false.
endif
if(.not.instr) then
if(j.gt.5.and.kchar.eq.9) then
j=j+1
q(j:j)=' '
lastnb=lastnb+1
else if(kchar.ne.9) then
j=j+1
q(j:j)=c
if(class.ne.ignore) lastnb=j
c Replace first tab by 5-j spaces.
else if(j.le.5) then
tabs=tabs+1
q(j+1:6)=' '
j=6
if(class.ne.ignore) lastnb=j
endif
else
j=j+1
q(j:j)=c
lastnb=lastnb+1
endif
2 continue
c write(6,*)'j=',j,' len=',len,' lastnb=',lastnb
j=lastnb
qlen=len
c Line length now len+j-6
c Check that line still fits.
if(j.gt.len) then
qlen=len+66
cline(j+1:qlen)=' '
else if(j.lt.len) then
cline(j+1:len)=' '
endif
return
end
c
integer function value(c)
implicit none
integer n
c Return numeric value of character numeric
character*1 c
n=ichar(c)-48
if(n.lt.0.or.n.gt.9) then
write(0,*)'************************'
write(0,*)'VALUE ERROR',n,c,ichar(c)
write(0,*)'************************'
n=0
endif
value=n
return
end
c
subroutine output(len,cline,ctue,store,nstore,comm)
implicit none
integer smax ,nstore
parameter (smax=5000)
character*80 store(smax)
character cline*2000
character*1 ctue(100)
integer len,m,k,j,l,ios,comm(smax),istore,lastnb,ll
c
ll=lastnb(cline,1,72)
write(2,40,err=99,iostat=ios) cline(1:ll)
40 format(a)
c
m=1
l=2
istore=1
if(len.gt.72)then
20 k=73+66*(m-1)
if(k.gt.len) goto 80
if(istore.le.nstore.and.comm(istore).eq.l) then
c write out comments that were stored.
ll=lastnb(store(istore),1,80)
write(2,'(A)') store(istore)(1:ll)
istore=istore+1
else
j=min(k+65,len)
ll=lastnb(cline,k,k+65)
write(2,45,err=99,iostat=ios) ctue(m),cline(k:ll)
45 format(5x,a1,a)
m=m+1
endif
l=l+1
c
goto 20
endif
80 if(istore.le.nstore) then
do 85 j=istore,nstore
ll=lastnb(store(j),1,80)
write(2,'(A)') store(j)(1:ll)
85 continue
endif
return
c
99 write(0,*)'ERROR ON OUTPUT,IOS=',ios
stop
end
c
integer function lastnb(c,start,len)
character*(*) c
integer start
do 1 i=len,start,-1
if(c(i:i).ne.' ') then
lastnb=i
return
endif
1 continue
lastnb=start
return
end
c
subroutine lower(c)
c Convert to lower case
character*1 c
integer j
j=ichar(c)
if ( j.ge.65.and.j.le.90)c=char(j+32)
return
end
c
subroutine low(cbuf,start,send)
c Convert to lower case
character cbuf*(*)
integer i,j,start,send
do 1 i=start,send
j=ichar(cbuf(i:i))
if ( j.ge.65.and.j.le.90) cbuf(i:i)=char(j+32)
1 continue
return
end
c
subroutine init(ctue)
implicit none
character*1 ctue(100)
integer j
common /ctable/nonpr,l_alpha,u_alpha
& ,specl,czero,nznum,ignore,quote,lookup(0:255)
integer nonpr,l_alpha,u_alpha
& ,specl,czero,nznum,ignore,quote,lookup
c these are our character classes
nonpr=0
l_alpha=1
u_alpha=7
specl=2
czero=3
nznum=4
ignore=5
quote=6
c
c Lookup array used to return class OF CHARACTER
c
do 1 j=0,255
if(j.le.31) then
lookup(j)=nonpr
else if ((j.ge.65.and.j.le.90)) then
lookup(j)=u_alpha
else if ((j.ge.97.and.j.le.122)) then
lookup(j)=l_alpha
else if(j.ge.49.and.j.le.57) then
c NON-ZERO NUMERIC
lookup(j)=nznum
else
c OTHER SPECIALS AND DUD CHARACTERS
lookup(j)=specl
endif
1 continue
c TAB
lookup(9)= ignore
c SPACE
lookup(32)= ignore
c Means that quote is not a special.
lookup(34)= quote
lookup(39)= quote
c CHARACTER ZERO
lookup(48)=czero
c
c This is so if line gets extended into another record (by expanding
c tabs) there will be continuation chars.
c
do 2 j=1,100
2 ctue(j)='&'
c
return
end
c
subroutine sqze(cline,qline,len)
c Remove all blanks
character cline*2000,qline*500
character*1 c,q
integer nlen,len,i,j,kchar
logical instr,qfound
common /ctable/nonpr,l_alpha,u_alpha
& ,specl,czero,nznum,ignore,quote
& ,lookup(0:255)
integer nonpr,l_alpha,u_alpha
& ,specl,czero,nznum,ignore,quote,lookup
c
qfound=.false.
instr=.false.
qline(1:6)=cline(1:6)
nlen=6
j=6
c
do 5 i=7,len
c=cline(i:i)
kchar=ichar(c)
c down shift for classify.
if(kchar.ge.65.and.kchar.le.90) c=char(kchar+32)
class=lookup(kchar)
if(qfound) then
if(c.eq.q) qfound=.false.
else if(class.eq.quote) then
q=c
qfound=.true.
endif
c
if(qfound.or.(c.ne.' ')) then
j=j+1
nlen=nlen+1
qline(j:j)=c
endif
5 continue
do 10 i=nlen+1,len
10 qline(i:i)=' '
c Retain line length as is.
return
end
c
subroutine clssfy(cline,decl)
c Classify statement as a certain very limited class of declarations
c which can confuse with holleriths - real*4 habcd is the problem
c
implicit none
character cline*2000
logical decl
decl=.false.
c 7890123456
if(cline(7:16).eq.'character*') then
decl=.true.
c 789012345
else if(cline(7:15).eq.'logical*1') then
decl=.true.
else if(cline(7:15).eq.'logical*4') then
decl=.true.
else if(cline(7:15).eq.'integer*4') then
decl=.true.
else if(cline(7:15).eq.'integer*8') then
decl=.true.
else if(cline(7:15).eq.'complex*8') then
decl=.true.
else if(cline(7:16).eq.'complex*16') then
decl=.true.
else if(cline(7:16).eq.'complex*32') then
decl=.true.
c 789012
else if(cline(7:12).eq.'real*4') then
decl=.true.
else if(cline(7:12).eq.'real*8') then
decl=.true.
else if(cline(7:13).eq.'real*16') then
decl=.true.
endif
return
end
c
subroutine getopts(infile,oname)
implicit none
character*80 infile,oname
integer*2 istat
integer nargs,narg
narg=nargs()
if(narg.le.1) then
write(6,*)'Usage: lower source.f output.f'
stop
endif
c
call getarg(1,infile,istat)
call getarg(2,oname,istat)
return
end
c
subroutine fdate(date)
character*8 date
integer*2 iy,im,id
call getdat(iy,im,id)
write(date,10)iy,im,id
10 format(i2,'-',i2,'-',i2)
return
end
c
subroutine openf(fname,oname)
character*80 fname,oname,ans*1
open(unit=1,file=fname,status='old',iostat=ierr,err=900)
C & action='read')
c
open(unit=2,file=oname,status='unknown',iostat=ierr,err=902)
return
900 write(6,*)'Open failure unit 1:',fname
return
902 write(6,*)'Open failure unit 2:',oname
return
end