c c program sbuv_ftp_convibm.f c invoked by script home/stokes/sbuvconv/sbuv_ftp_unix.scr c by J. Stokes (HSTX) 1/94 c c -- program converts IMB sbuv pmf record to UNIX record c this reads the data set sent by NOAA by ftp (one data set c containing all data for month at time) c updated 7/95 (jvs) to make a satellite variable be part c of output name. c character*60 outfile, hdrfil, crname character str*4, ebcasc character*2 daychr,monchr,yrchr character*8 date character*5 satl integer rtcode, nrec, op, opt, nsize, kk integer ibuf(0:7000-1), iubuf(0:7000-1) real rbuf(0:7000-1), rubuf(0:7000-1) real*4 hdrrec(2000) double precision dbuf, dubuf integer lstday(12)/31,28,31,30,31,30,31,31,30,31,30,31/ logical ex logical first/'true'/,frshdr/'true'/ equivalence (ibuf,rbuf), (ibuf(66),dbuf), (rubuf(66),dubuf) c write (6,*) ' Reblock from IBM format to UNIX format' write(6,*)' core name of output data set ' read(5,'(a)')satl lens=index(satl,' ')-1 read(5,'(a)')crname len=index(crname,' ')-1 write(6,*)len,crname c**read input data set member of data set rtcode = -1 op = 0 nsize = 0 call readn11(op,opt,nsize,ibuf,rtcode) if(rtcode.eq.999)then write(6,*)rtcode,' from readn11 - file not there' stop endif op=1 nsize=207 kk=nsize nhrec=0 ndrec=0 100 call readn11(op,opt,nsize,ibuf,rtcode) if (rtcode.eq.nsize) then c c**first word is integer so no conversion is necessary; check for c header and trailer records by checking value of first word c call tunifs (rbuf(1), rubuf(1)) if(rubuf(1).lt.2.0)then do 60 j=1,kk-1 call tunifs(rbuf(j),rubuf(j)) 60 continue if(rubuf(1).eq.1.)then iyear=rubuf(9) iday=rubuf(7) if(iyear.gt.1900.)iyear=iyear-1900 call setdat(iyear,iday,date,idom,im) if(frshdr)then write(6,*)' first header time ', & iyear,iday,date,idom,im write(monchr,'(i2)')im if(monchr(1:1).eq.' ')monchr(1:1)='0' write(yrchr,'(i2)')iyear hdrfil=crname(1:len)//'Y'//yrchr//'/M'//monchr & //'/SBUV2_INFO.19'//yrchr//'_'//monchr inquire(file=hdrfil,exist=ex) if(ex)then open(unit=9,file=hdrfil,form='unformmated', & status='old',access='append') else open(unit=9,file=hdrfil,form='unformmated', & status='unknown') write(6,*)hdrfil endif ims=im iyears=iyear frshdr=.false. endif if (im.ne.ims .or. iyear.ne.iyears)then close(unit=9) write(monchr,'(i2)')im if(monchr(1:1).eq.' ')monchr(1:1)='0' write(yrchr,'(i2)')iyear hdrfil=crname(1:len)//'Y'//yrchr//'/M'//monchr & //'/SBUV2_INFO.19'//yrchr//'_'//monchr inquire(file=hdrfil,exist=ex) if(ex)then open(unit=9,file=hdrfil,form='unformmated', & status='old',access='append') write(6,*)' next header file ' write(6,*)hdrfil else open(unit=9,file=hdrfil,form='unformmated', & status='unknown') write(6,*)' next header file ' write(6,*)hdrfil endif iyears=iyear ims=im write(6,*)' # of header records ',nhrec, & (rubuf(j),j=9,10) nhrec=0 endif endif if(frshdr .and. rubuf(1).ne.1)go to 100 nhrec=nhrec+1 write(9)ibuf(0),(rubuf(j),j=1,kk-1) go to 100 endif c c**data records converted here c ndrec = ndrec + 1 do 200 j = 2, kk-1 if(j .eq. 66)then call tunifd(dbuf,dubuf) go to 200 endif if(j .eq. 67)go to 200 call tunifs (rbuf(j), rubuf(j)) 200 continue yyddd=rubuf(3) if(yyddd.lt.1.0)then write(6,*)rubuf(1),yyddd go to 100 endif if(first)then iyear=yyddd/1000. jday=yyddd-(iyear*1000) call setdat(iyear,jday,date,idom,im) write(6,*)yyddd,rubuf(1) write(6,*)' first time ',iyear,iday,date,idom,im write(monchr,'(i2)')im if(monchr(1:1).eq.' ')monchr(1:1)='0' write(daychr,'(i2)')idom if(daychr(1:1).eq.' ')daychr(1:1)='0' write(yrchr,'(i2)')iyear outfile=crname(1:len)//'Y'//yrchr//'/M' & //monchr//'/s'//yrchr//monchr//daychr//'.' & //satl(1:lens)//'s' inquire(file=outfile,exist=ex) if(ex)then open (8,file=outfile,form='unformatted', & status='old',access='append') else open (8,file=outfile,form='unformatted', & status='unknown') endif write(6,*)outfile write (8) ibuf(0),(rubuf(j),j=1,kk-1) yyddds=yyddd first=.false. go to 100 endif if(yyddd .eq. yyddds)then write(8)ibuf(0),(rubuf(j),j=1,kk-1) else write (6,*)'# of records = ',ndrec-1, & yyddds,im,idom,iyear ndrec=1 close(8) iyear=int(yyddd/1000.) jday=yyddd-(iyear*1000) c**********check change of year if(int(yyddds/1000.) .eq. iyear .and. jday .eq. 1) & then iyear=iyear+1 rubuf(3)=iyear*1000 + jday endif call setdat(iyear,jday,date,idom,im) write(monchr,'(i2)')im if(monchr(1:1).eq.' ')monchr(1:1)='0' write(daychr,'(i2)')idom if(daychr(1:1).eq.' ')daychr(1:1)='0' write(yrchr,'(i2)')iyear outfile=crname(1:len)//'Y'//yrchr//'/M'//monchr// & '/s'//yrchr//monchr//daychr//'.' & //satl(1:lens)//'s' open (8,file=outfile,form='unformatted', & status='unknown') write(8)ibuf(0),(rubuf(j),j=1,kk-1) yyddds=yyddd endif goto 100 endif write (6,*)'# of records = ',ndrec,yyddd,im,idom,iyear close (8) write(6,*)' # of header records ',nhrec,(rubuf(j),j=9,10) close (9) stop c**error opening files 400 continue write(6,*)' error opening file ', hdrfile,' on jukebox' end C** C C**SUBROUTINE SETDAT SUBROUTINE SETDAT(IYEAR,IDAY,DATE,ID,IM) INTEGER*4 IYEAR,iday,id,im CHARACTER*8 DATE,MON(12) DIMENSION IMON(13),IMONL(13) DATA IMON/1,32,60,91,121,152,182,213,244,274,305,335,366/ DATA IMONL/1,32,61,92,122,153,183,214,245,275,306,336,367/ DATA MON/' JANUARY','FEBRUARY',' MARCH',' APRIL', 1 ' MAY',' JUNE',' JULY',' AUGUST', 2 'SEPTEMBR',' OCTOBER','NOVEMBER','DECEMBER'/ C IF(JMOD(IYEAR,4).EQ.0) GO TO 200 DO 100 I=1,12 IF(IDAY.GE.IMON(I+1)) GO TO 100 ID=IDAY-IMON(I)+1 IM=I GO TO 400 100 CONTINUE C 200 CONTINUE DO 300 I=1,12 IF(IDAY.GE.IMONL(I+1)) GO TO 300 ID=IDAY-IMONL(I)+1 IM=I GO TO 400 300 CONTINUE C 400 CONTINUE DATE=MON(I) RETURN END