program prtobs
c Expects the input file as a directed input,
c e.g.                  a.out < data_ascii
c or if compressed,     zcat data_ascii.Z |a.out '
c output is to standard out so may be redirected or
c output is to station files if activated
c bad record info written to fort.11

        character*3 rectyp
        character*4 elmtyp
        character*2 eunits
	character*1 flag1,flag2,ampm,sbplt,flg1,flg2
        character ibuf*13000
	dimension imo(100),iday(100),ivalue(100),flag1(100),flag2(100)
	dimension jmo(100),jday(100),jvalue(100),flg1(100),flg2(100)
c
	itape=6
        nrecs=0
        lrecs=0
        numval=0
c
	write(itape,24)
   24   format(' Element type FRZD, freeze data, has unique month/day va
     *lues, see format.',//,
     *         ' rec             data             ampm sbplt #daily',
     *  13('    # of   data            '),/,
     *         'type station div type units year  soil  soil values',
     *  13(' mo days  value flag1 flag2'),/,
     *         '                                                   ',
     *  13(' --------------------------'))

c*** read block from storage device
   10   continue
        ib=1
        read(5,'(a)',end=50) ibuf
        nrecs=nrecs+1
c
c*** read next logical record (record type) in block or read next block
   15   continue
c
c*** read variables that identify record,
        read(ibuf(ib:),20,err=10) ibytes,rectyp,idst,idstn,idv,elmtyp,
     *  eunits,iyr,ampm,sbplt,numval
c
c       idst    - state number
c       idstn   - station number
c       idv     - division number
c       elmtyp  - type of element
c       eunits  - units of element
c       iyr     - year
c       imo     - month
c       numval  - number of values present
c
   20   format(i4,a3,i2,i4,i2,a4,a2,i4,2a1,4x,i3)
        if(ibytes.le.0) go to 10
        lrecs=lrecs+1
c       print 2020,nrecs,lrecs,ib,ibytes
 2020   format(4i10)
c
c***    select records here (go to 40 to reject record)
c       if(idstn.lt.       0) go to 40
c
c to write unblocked records as is
c       write(*,'(a)') ibuf(ib:ib+ibytes-1)
c       go to 40
c
c
	do 2021 i=1,13
	imo(i)=99
	iday(i)=99
	ivalue(i)=-99999
	flag1(i)='_'
	flag2(i)='_'
 2021   continue

c*** read data values from selected record
        read(ibuf(ib+34:),21,err=44)
     *  (jmo(j),jday(j),jvalue(j),flg1(j),flg2(J),j=1,numval)
c
c       jmo     - month of value
c       jday    - day of element value or number of days of occurrences
c       jvalue  - data value
c       flg1    - flag 1
c       flg2    - flag 2
c
   21   format(100(2i2,i6,2a1))

        do 2121 i=1,numval
	j=jmo(i)
	if(elmtyp.eq.'FRZD')j=i
	imo(j)=jmo(i)
        iday(j)=jday(i)
        ivalue(j)=jvalue(i)
        flag1(j)=flg1(i)
        flag2(j)=flg2(i)
	if(flag1(j).eq.' ') flag1(j)='_'
	if(flag2(j).eq.' ') flag2(j)='_'
 2121   continue
c
c*** print selected record (
	idnum=idst*10000+idstn
c       print 25,rectyp,idnum,idv,elmtyp,eunits,iyr,ampm,sbplt,numval,
c    *  (imo(j),iday(j),ivalue(j),flag1(j),flag2(j),j=1,13)

	write(itape,25) rectyp,idnum,idv,elmtyp,eunits,iyr,ampm,sbplt,
     *  numval,(imo(j),iday(j),ivalue(j),flag1(j),flag2(j),j=1,13)
   25   format(1x,a3,2x,i6,i4,1x,a4,4x,a2,i5,2a6,i7,
     *       13(i3,i5, i7,2a6))

c
c*** set up character pointers for next record
   40   ib=ib+ibytes
        go to 15
c
c*** error condition dump record
   44   continue
        ie=ib+ibytes-1
	nerr=nerr+1
c       write(11,45) nrecs,lrecs,ib,ibytes,ibuf(ib:ie)
c  45   format(4i10,1x,(a))
	write(11,46) ibuf(ib:ie)
   46   format((a))
        go to 40

   50   continue
	write(itape,*)
     *  nrecs,' recs read, ',lrecs,' selected, ',nerr,' errors:'
	close(11)
   51   read(11,'(a)',end=52) ibuf
	write(itape,'(a)') ibuf
	go to 51
   52   close(itape)
        end