c program rdascii c c Read ascii data file generated by tgcmproc: c character*80 fname character*80 hdr(4),labx,laby character*1 ans dimension xx(100),yy(100),f(100,100) data lurd/9/ c do 200 iii=1,1000 write(6,"(' ')") write(6,"('Enter file name (zzz to stop): ',$)") read(5,*) fname if (fname(1:3).eq.'zzz') stop 'bye' open(lurd,file=fname,status='OLD',err=901) write(6,"('Ask about printing for every frame in the', + ' file? (y/n): ',$)") read(5,*) ans iprompt = 0 if (ans.eq.'y') iprompt = 1 nfr = 0 c c Read data from each frame: c 100 continue do i=1,4 read(lurd,"(a)",end=900) hdr(i) enddo read(lurd,"(a)") labx read(labx,"(3x,i4)") nx if (nx.gt.1) read(lurd,"(6e13.5)") (xx(i),i=1,nx) read(lurd,"(a)") laby read(laby,"(3x,i4)") ny if (ny.gt.1) read(lurd,"(6e13.5)") (yy(i),i=1,ny) c if (nx.gt.1.and.ny.gt.1) then read(lurd,"(6e13.5)") ((f(i,ii),i=1,nx),ii=1,ny) elseif (nx.eq.1.and.ny.gt.1) then read(lurd,"(6e13.5)") (f(1,i),i=1,ny) elseif (ny.eq.1.and.nx.gt.1) then read(lurd,"(6e13.5)") (f(i,1),i=1,nx) endif nfr = nfr+1 c c Conditionally echo to stdout: c write(6,"(' ')") c write(6,"(a)") histvol(1:lenstr(histvol)) c write(6,"(a)") field(1:lenstr(field)) c write(6,"('Frame ',i4)") iframe c write(6,"(a)") lab(1:lenstr(lab)) do i=1,4 write(6,"(a)") hdr(i) enddo write(6,"(a)") labx(1:lenstr(labx)) if (nx.gt.1) then if (nfr.eq.1.or.iprompt.gt.0) then write(6,"('Print x-axis values? (y/n/q): ',$)") read(5,*) ans else ans = 'n' endif if (ans.eq.'y') write(6,"(6e13.5)") (xx(i),i=1,nx) if (ans.eq.'q') goto 902 endif write(6,"(a)") laby(1:lenstr(laby)) if (ny.gt.1) then if (nfr.eq.1.or.iprompt.gt.0) then write(6,"('Print y-axis values? (y/n/q): ',$)") read(5,*) ans else ans = 'n' endif if (ans.eq.'y') write(6,"(6e13.5)") (yy(i),i=1,ny) if (ans.eq.'q') goto 902 endif if (nfr.eq.1.or.iprompt.gt.0) then write(6,"('Print data values? (y/n/q): ',$)") read(5,*) ans else ans = 'n' endif if (ans.eq.'y') then if (nx.gt.1.and.ny.gt.1) then write(6,"(6e13.5)") ((f(i,ii),i=1,nx),ii=1,ny) elseif (nx.eq.1.and.ny.gt.1) then write(6,"(6e13.5)") (f(1,i),i=1,ny) elseif (ny.eq.1.and.nx.gt.1) then write(6,"(6e13.5)") (f(i,1),i=1,nx) endif endif if (ans.eq.'q') goto 902 goto 100 c stop 900 continue write(6,"('EOF encountered on file ',a,' (lu ',i3,')')") + fname,lurd 902 close(lurd) goto 200 901 write(6,"('Error opening file ',a)") fname 200 continue stop end c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c function lenstr(str) character*(*) str c c Return index to last non-blank char in str c length = len(str) do i=length,1,-1 if (str(i:i).ne.' ') then lenstr = i return endif enddo lenstr = 0 return end c subroutine clearstr(str) c c Set given string to all blanks c character*(*) str length = len(str) do i=1,length str(i:i) = ' ' enddo return end