subroutine intprs( lun, iotty, iosv, ncol ) C----------------------------------------------------------------------- C C* Routine : intprs - initialize the command/line parser C C This routine simply sets the common block for the command/line C parser according to some user specificied values C C Argument | Meaning C =========|=========================================================== C lun | logical unit number to be used for reading C iotty | logical unit number to be used for the tty C iosv | logical unit number for the "save" file C ncol | number of columns for line parsing (usually 82) C C* Author : Mark A. Christon C C----------------------------------------------------------------------- #ifdef DBL implicit double precision (a-h,o-z) #endif common /iaio/ iosave, iunit, itty, ncolum iunit = lun itty = iotty ncolum = ncol iosave = iosv return end subroutine getnum(nchar,msge,data,idata) C********************************************************** C C get numbers C C********************************************************** #ifdef DBL implicit double precision (a-h,o-z) #endif character*4 cmd,msge ityp = 3 call parse(msge,nchar,cmd,data,ityp,lword) idata=data return end subroutine getsym(nchar,msge,cmdr,lword) c********************************************************* c c get symbols c c********************************************************* #ifdef DBL implicit double precision (a-h,o-z) #endif character*8 msge character*(*) cmdr ityp = 1 call parse(msge,nchar,cmdr,data,ityp,lword) return end subroutine gttxsg( txts, lc, lun) C----------------------------------------------------------------------- C C* Routine : gttxsg - read ASCII line from input file C C skip lines with a *, $, or # in the first column C C Argument | Meaning C =========|============================================================ C txts | 80 char. text C lc | line counter C lun | logical unit number C C* Author : R. M. Ferencz C C----------------------------------------------------------------------- #ifdef DBL implicit double precision (a-h,o-z) #endif character *80 txts save nc data nc /0/ 10 read(lun,20) txts nc = nc + 1 if( (txts(1:1) .eq. '*') .or. 2 (txts(1:1) .eq. '$') .or. 3 (txts(1:1) .eq. '#') ) then go to 10 else lc = nc return endif 20 format (a80) end subroutine newlin(msge,nchar) C----------------------------------------------------------------------- C C* Routine : newlin - print prompt, read in a new character string C C Argument | Meaning C =========|============================================================ C msge | 80-character string C nchar | number of characters C C----------------------------------------------------------------------- #ifdef DBL implicit double precision (a-h,o-z) #endif common /iaio/ iosave, iunit, itty, ncolum character*1 cbuf character*8 ftm vax750 character*(*) msge common /ibio/ cbuf(82) common/helpc/ihelp,nu dimension temp(80) c ipmtm is the end-of-transmition character that prevents (cr) c data ipmtm / 20000000000000000000b / cray1 10 continue if(iunit.ne.itty)go to 20 read (unit=msge,fmt=1010)(temp(i),i=1,nchar) c write(iunit,1020)(temp(i),i=1,nchar),ipmtm cray1 write(ftm,1021) nchar vax750 write( * ,ftm )(temp(i),i=1,nchar) vax750 if ( iunit .eq. itty ) then read( * ,1010)(cbuf(i),i=1,80) else read(iunit,1010)(cbuf(i),i=1,80) endif do 15 i=1,80 vax750 15 call strupcase(cbuf(i),cbuf(i)) vax750 do 16 i=5,80 if (cbuf(i).eq.'/') then if (cbuf(i-4).eq.'h'.and.cbuf(i-3).eq.'e'.and.cbuf(i-2).eq.'l' 1 .and.cbuf(i-1).eq.'p') ihelp=ihelp+1 cbuf(i)=' ' endif 16 continue ncolum=1 go to 40 20 continue c read(iunit,1010)(cbuf(i),i=1,80) cray1 c if(iostatus(iunit,ier).ne.0)go to 30 cray1 if ( iunit .eq. itty ) then vax750 read( *,1010,end=30)(cbuf(i),i=1,80) vax750 else vax750 read(iunit,1010,end=30)(cbuf(i),i=1,80) vax750 endif vax750 do 25 i=1,80 vax750 25 call strupcase( cbuf(i), cbuf(i)) vax750 ncolum=1 go to 40 30 continue iunit=itty c write(iunit,1020) ipmtm cray1 go to 10 40 continue if( iosave .gt. 0 ) write (iosave,1010) (cbuf(l),l=1,80) c if(iosave.eq.15) call empty(iosave) cray1 return 1010 format(80a1) c1020 format(80a1) cray1 c1020 format($,1x,80a1) vms c1020 format((a1)) gddm c1020 format(80a1,$) obs c1021 format('('$,1x,i2,'a1)') vms 1021 format('(',i2,'a1,$)') vax750 end subroutine parse(msge,nchar,cmd,dat,ityp,lword) c********************************************************** c c parse line c c********************************************************** #ifdef DBL implicit double precision (a-h,o-z) #endif character*(*) cmd,msge common /iaio/ iosave, iunit, itty, ncolum character*1 cbuf common /ibio/ cbuf(82) character*4 rbuf(20) character*81 temp character*1 iblank,ihat data iblank/' '/,ihat/'^'/ 5 continue if(ncolum.gt.80)call newlin(msge,nchar) c.....find first character of item 10 if(cbuf(ncolum).ne.' ')go to 20 ncolum=ncolum+1 if(ncolum.gt.80)call newlin(msge,nchar) go to 10 c.....find last character of item 20 continue ncol1=ncolum 25 continue if(cbuf(ncolum).eq.' ')go to 30 ncolum=ncolum+1 if(ncolum.gt.80)go to 30 go to 25 30 continue ncol2=ncolum-1 c.....translate the item lchar=ncol2-ncol1+1 go to (40,50,50),ityp 40 lchar=min0(lchar,lword) ncol2=ncol1+lchar-1 write(unit=cmd,fmt=1010)(cbuf(i),i=ncol1,ncol2) return 50 continue do 55 i=1,20 55 rbuf(i)=' ' do 60 i=ncol1,ncol2 i1=20+i-ncol2 rbuf(i1)=cbuf(i) 60 continue write(unit=temp,fmt=1010)(rbuf(i),i=1,20) if(ityp.eq.3)go to 70 read (unit=temp,fmt=1020,err=400) dat return 70 continue read (unit=temp,fmt=1030,err=400) dat return 400 continue if(ityp.eq.2)write(* ,2010) if(ityp.eq.3)write(* ,2020) c iunit=itty ncolum=81 write(* ,1010)(cbuf(i),i=1,80) ic1=ncol1-1 if(ic1.le.0)write(* ,1010)ihat if(ic1.ge.1)write(* ,1010)(iblank,i=1,ic1),ihat go to 5 1010 format(80a1) 1020 format(i20) 1030 format(e20.0) 2010 format(' *** integer decode error ***') 2020 format(' *** floating point decode error ***') end subroutine strupcase( dest, sour ) character*1 dest,sour data ia/65/,iz/90/,idist/32/ is=ichar(sour) if( is .ge. ia .and. is .le. iz ) then id=is+idist dest=char(id) else dest=sour endif return end