program read c c code to read ds463.1 DATSAV, variable length c parameter (many=38) dimension indc(many) dimension numv(many) character*2840 line character val(200)*8 character idfix*6,yr*4,mo*2,da*2,hr*2,mn*2 character lat*6,lon*7,type*5,elev*5,icall*5,qc*4 character dir*3,dirqc*1,dirty*1,spd*4,spdqc*1 character sky*5,skyqc*1,skyc*1,cavok*1,vis*6,visqc*1 character viso*1,visoqc*1,t*5,tqc*1,td*5,tdqc*1 character slp*5,slpqc*1 character rem*520 character lineout*520 character ind(many)*3, rfmt(many)*48, wfmt(many)*64 character sec*3 data numv/ 1, 4, 4, 3, 5, 2, 4, * 3, 3, 5, 5, 4, 4, 13, 4, * 5, 2, 2, 3, 4, 5, 7, * 3, 4, 3, 2, 5, 4, 4, * 4, 6, 11, 1, 1, 4, * 2, 2, 2/ data indc/ 3, 10, 5, 7, 15, 6, 9, * 6, 6, 8, 8, 10, 13, 24, 11, * 14, 7, 5, 11, 12, 15, 14, * 8, 10, 8, 7, 11, 11, 11, * 8, 13, 22, 3, 3, 16, * 6, 6, 6/ data ind/ 'ADD', 'AA1', 'AC1', 'AG1', 'AJ1', 'HL1', 'AL1', * 'MW1', 'AW1', 'AYI', 'AZ1', 'ED1', 'GA1', 'GF1', 'GD1', * 'GG1', 'GJ1', 'IA1', 'IA2', 'KA1', 'MA1', 'MD1', * 'ME1', 'OA1', 'OC1', 'SA1', 'UA1', 'UG1', 'UG2', * 'WA1', 'WG1', 'WD1', 'REM', 'EQD', 'Q01', * 'SYN', 'AWY', 'MET'/ data rfmt/ * '(a3)', ADD * '(a3,a2,a4,a1)', AA1-4 * '(a3,2a1)' , AC1 * '(a3,a1,a3)', AG1 * '(a3,a4,a1,a6,a1)', AJ1 * '(a3,a3)', HL1 * '(a3,a2,a3,a1)', AL1-4 * '(a3,a2,a1)', MW1-7 * '(a3,a2,a1)', AW1 * '(a3,2a1,a2,a1)', AYI-2 * '(a3,2a1,a2,a1)', AZ1-2 * '(a3,a2,a1,a4)', ED1 * '(a3,a2,a6,a2)', GA1-6 * '(a3,3(a2,a1),a5,a1,2(a2,a1))', GF1 * '(a3,a1,a6,a1)', GD1-4 * '(a3,a2,a5,2a2)', GG1-6 * '(a3,a4)', GJ1 * '(a3,a2)', IA1 * '(a3,a3,a5)', IA2 * '(a3,a3,a1,a5)', KA1-2 * '(a3,2(a5,a1))', MA1 * '(a3,2a1,a3,a1,a4,a1)', MD1 * '(a3,a1,a4)', ME1 * '(a3,a1,a2,a4)', OA1-3 * '(a3,a4,a1)', OC1 * '(a3,a4)', SA1 * '(a3,a1,a2,a3,a2)', UA1 * '(a3,a2,2a3)', UG1 * '(a3,a2,2a3)', UG2 * '(a3,a1,a3,a1)', WA1 * '(a3,5a2)', WG1 * '(a3,a2,a3,a2,3a1,a2,a1,2a3)', WD1 * '(a3)', REM * '(a3)', EQD * '(a3,a6,a1,a6)', Q01-99 * '(2a3,a)', SYN * '(2a3,a)', AWY * '(2a3,a)'/ MET data wfmt/ * '(5x,a3)', ADD * '(5x,a3,5x,a2,3x,a4,6x,a1)', AA1-4 * '(5x,a3,6x,a1,6x,a1,4x,a3)', AC1 * '(5x,a3,6x,a1,4x,a3)', AG1 * '(5x,a3,3x,a4,6x,a1,1x,a6,6x,a1)', AJ1 * '(5x,a3,4x,a3)', HL1 * '(5x,a3,5x,a2,4x,a3,6x,a1)', AL1-4 * '(5x,a3,5x,a2,6x,a1)', MW1-7 * '(5x,a3,5x,a2,6x,a1)', AW1 * '(5x,a3,6x,a1,6x,a1,5x,a2,6x,a1)', AYI-2 * '(5x,a3,6x,a1,6x,a1,5x,a2,6x,a1)', AZ1-2 * '(5x,a3,5x,a2,6x,a1,3x,a4)', ED1 * '(5x,a3,5x,a2,1x,a6,5x,a2)', GA1-6 * '(5x,a3,3(5x,a2,6x,a1),2x,a5,6x,a1,2(5x,a2,6x,a1))', GF1 * '(5x,a3,6x,a1,1x,a6,6x,a1)', GD1-4 * '(5x,a3,5x,a2,2x,a5,5x,a2,5x,a2)', GG1-6 * '(5x,a3,3x,a4)', GJ1 * '(5x,a3,5x,a2)', IA1 * '(5x,a3,4x,a3,2x,a5)', IA2 * '(5x,a3,4x,a3,6x,a1,2x,a5)', KA1-2 * '(5x,a3,2(2x,a5,6x,a1))', MA1 * '(5x,a3,6x,a1,6x,a1,4x,a3,6x,a1,3x,a4,6x,a1)', MD1 * '(5x,a3,6x,a1,3x,a4)', ME1 * '(5x,a3,6x,a1,5x,a2,3x,a4)', OA1-3 * '(5x,a3,3x,a4,6x,a1)', OC1 * '(5x,a3,3x,a4)', SA1 * '(5x,a3,6x,a1,5x,a2,4x,a3,5x,a2)', UA1 * '(5x,a3,5x,a2,4x,a3,4x,a3)', UG1 * '(5x,a3,5x,a2,4x,a3,4x,a3)', UG2 * '(5x,a3,6x,a1,4x,a3,6x,a1)', WA1 * '(5x,a3,5(5x,a2))', WG1 * '(5x,a3,5x,a2,4x,a3,5x,a2,3(6x,a1),5x,a2,6x,a1,2(4x,a3)', WD1 * '(5x,a3)', REM * '(5x,a3)', EQD * '(5x,a3,1x,a6,6x,a1,1x,a6)', Q01-99 * '(5x,a3,4x,a3,1x,(a))', SYN * '(5x,a3,4x,a3,1x,(a))', AWY * '(5x,a3,4x,a3,1x,(a))'/ MET c write(6,'(a3,3x,a48)') (ind(i)(1:3),rfmt(i)(1:48),i=1,many) c write(6,'(a3,3x,a64)') (ind(i)(1:3),wfmt(i)(1:64),i=1,many) 100 continue read (*,'(a)',err=2000, end=5000) line read (line(1:), 1010,err=2000) * ntvc,idfix,yr,mo,da,hr,mn, lat,lon,type,elev,icall,qc, * dir,dirqc,dirty,spd,spdqc, sky,skyqc,skyc,cavok,vis,visqc, * viso,visoqc,t,tqc,td,tdqc, slp,slpqc 1010 format (i4,a6,a4,4a2,a6,a7,3a5,a4,a3,2a1,a4,a1, * a5,3a1,a6,a1,2a1,a5,a1,a5,a1,a5,a1,a3) c select reports here c if(idfix.ne.'724690') go to 100 c if(yr.ne.'1973') go to 100 c if(mo.ne.'01') go to 100 c if(da.ne.'01') go to 100 c if(hr.ne.'00') go to 100 nrec=nrec+1 ntc=ntvc+99 c write(*,*)' ' c write(*,'(a)') line(1:ntc) write (6, 50) ntvc 50 format (1x,/, * ' MANDATORY CHARACTERS: 99',5X,'ADDITIONAL CHARACTERS: ',I3,/, * ' MAN: stano year mo da hr mn lat lon type elev call' * ' qc dir 1 2 spd 1 sky 1 2 3 vis 1 2 3 t 1 dp 1 ' * ' slp 1') write (6, 1060) * idfix,yr,mo,da,hr,mn, lat,lon,type,elev,icall,qc, * dir,dirqc,dirty,spd,spdqc, sky,skyqc,skyc,cavok,vis,visqc, * viso,visoqc,t,tqc,td,tdqc, slp,slpqc 1060 format(' MAN: ',a6,1x,a4,4(1x,a2),1x,a6,1x,a7,3(1x,a5),1x,a4, * 1x,a3,2(1x,a1),1x,a4,1x,a1,1x,a5,3(1x,a1),1x,a6,1x,a1, * 2(1x,a1),3(1x,a5,1x,a1)) if(ntc.lt.100) go to 100 ib=100 999 continue sec(1:3)=line(ib:ib+2) if(sec.ne.'ADD'.and.sec.ne.'EQD'.and.sec.ne.'REM') go to 1050 write(*,*) sec,':' write(lineout,1061) sec,idfix,yr,mo,da,hr,mn 1061 format(1x,a3,': ',a6,1x,a4,4(1x,a2)) if(sec.ne.'REM') write(6,1062) sec,idfix,yr,mo,da,hr,mn 1062 format(1x,a3,': ',a6,1x,a4,4(1x,a2),2x,14(' ------')) if(sec.eq.'REM') write(6,1063) sec,idfix,yr,mo,da,hr,mn 1063 format(1x,a3,': ',a6,1x,a4,4(1x,a2),2x,3(' ------'), * 11('-------')) 1050 continue if(sec(1:2).eq.'AA') sec(1:3)='AA1' if(sec(1:2).eq.'AL') sec(1:3)='AL1' if(sec(1:2).eq.'MW') sec(1:3)='MW1' if(sec(1:2).eq.'AY') sec(1:3)='AYI' if(sec(1:2).eq.'AZ') sec(1:3)='AZ1' if(sec(1:2).eq.'GA') sec(1:3)='GA1' if(sec(1:2).eq.'GD') sec(1:3)='GD1' if(sec(1:2).eq.'GG') sec(1:3)='GG1' if(sec(1:2).eq.'KA') sec(1:3)='KA1' if(sec(1:2).eq.'OA') sec(1:3)='OA1' if(sec(1:1).eq.'Q' ) sec(1:3)='Q01' do 1000 k=1,many if(sec.eq.ind(k)(1:3)) go to 1500 1000 continue write(lineout(31:),*) 'unknown ',sec(1:3) write(6,'(a)') lineout(1:136) go to 100 1500 continue if(sec(1:3).ne.'SYN'.and. sec(1:3).ne.'AWY'.and. * sec(1:3).ne.'MET') go to 1750 read(line(ib+3:ib+5),'(i3)',err=2000) indc(k) indc(k)=indc(k)+6 numv(k)=(indc(k)+3)/4 read(line(ib:),rfmt(k),err=2000) (val(i),i=1,2) read(line(ib+3:),'(i3)',err=2000) istop read(line(ib+6:),'(a)',err=2000) rem(1:istop) write(lineout(31:),wfmt(k)(1:64)) (val(i),i=1,2), rem(1:istop) write(6,'(a)') lineout(1:47+istop) go to 1800 1750 continue read(line(ib:ib-1+indc(k)),rfmt(k),err=2000)(val(i),i=1,numv(k)) if(sec.eq.'ADD'.or.sec.eq.'EQD'.or.sec.eq.'REM') go to 1800 write(lineout(31:),wfmt(k)(1:64)) (val(i),i=1,numv(k)) write(6,'(a)') lineout(1:136) 1800 ib=ib+indc(k) if(ib.ge.ntc) go to 100 go to 999 c 2000 continue write(*,*)'error ',line(1:) go to 100 5000 continue write(*,*)' total reports ',nrec c end