************************************************************************** program drm2sac * This program transforms DRM2A binary data into the sac data. * * modeified by Koichiro OBANA 1995/05 * from drm2zoo revised by Shin Aoi * original:mkt.for:coded by K.Hatayama 1993/06/16 * * ------------- only for 'mkt' data & only for 3 ch data * * revised by Shin Aoi 1994/03/05 * * drm2ascii ----------------- for any no. of CH * * drm2zoo ver.00.00 1994/08/02 * *************************************************************************** parameter(ver_no=00.10) parameter(maxdat=200000) parameter(maxid=200) parameter(maxch=8) parameter(maxkai=100) parameter(maxix=20) * parameter(rabsxn=10.0,rabsye=10.0,rabszu=10.0) *-------------------rabs :(v/kine) <------------sensor integer istd(maxid),ndata(maxid),npret(maxid) integer mdata(maxid) c integer ido(maxix) integer*2 id(8) integer idata(maxdat,maxch) c integer sdata(maxdat) * character*30 filehd,filedt,pfile character cdate0(maxid)*12,ctadj(maxid)*12 character cfstt*16 character*30 fname(8) integer fact2(11:18) real fact1(11:18) character homdir*30 character comp(11:18)*1,stcode(11:18)*3,nsewud(11:18)*5 character vora(11:18)*8,zerord(11:18)*11 c character myname*20 character sensor*10,rcrder*10,aliasf*10 c character datfmt*10 character conly*30 * write(*,*)'drm2zoo:ver.',ver_no ************************************************************************ **for14bit datfmt='16i5' **for16bit datfmt='10i7' c datfmt='10i7' c read(datfmt(1:2),'(i2)')ix ************************************************************************ * with ID lackth=0 * without ID lackth=556284 lackth=0 ************************************************************************ *------------------------------------------------------------------- * read parameter file *------------------------------------------------------------------- * write(*,*) 'where is the parameter file ? ' * read(*,'(a)') pfile * if(pfile.eq.' ')pfile='drm2zoo.wky' pfile='drm2sac.com' * pfile='drm2zoo.wky' open(31,file=pfile) call rd_prm(namemy, - sensor,rcrder,aliasf,mch, - comp,stcode,nsewud,vora,zerord, - fact1,fact2,homdir,nhomd) do 9999 kai=1,maxkai read(31,'(a30)') filehd write(*,'(a30)') filehd read(31,'(a30)') filedt write(*,'(a30)') filedt c read(31,*) if(filehd.eq.'quit')goto 9997 if(filedt.eq.'quit')goto 9997 read(31,'(a30)') conly ionly1=0 ionly2=0 if(conly.eq.'only')read(31,*)ionly1,ionly2 write(*,*)'ionly1,ionly2=',ionly1,ionly2 c read(31,*) *------------------------------------------------------------------- * read header & read id *------------------------------------------------------------------- call rd_hder(filehd,nch,nsamp,rlsb,nid,iextrg) write(6,*)nch,mch * if(nch.ne.mch)goto 995 if(nch.gt.mch)goto 995 * mch=nch if(nid.gt.maxid)goto 996 write(*,*) 'number of id=',nid call rd_id(maxid,nid,filehd,iextrg, - cdate0,istd,ctadj,ndata,npret) ntotal=0 do i=1,nid mdata(i)=ndata(i) ntotal=ntotal+mdata(i) end do write(*,*) 'number of id=',nid write(*,*) 'number of all data=',ntotal * if(ionly1.ne.0 .and.ionly2.ne.0 .and. ionly1.le.ionly2)then iid0=ionly1 iid1=ionly2 else iid0=1 iid1=nid end if do 9998 iid=iid0,iid1 write(*,*) 'now id=',iid,'/',nid write(*,*) 'acquisition time=',cdate0(iid)(1:12) *------------------------------------------------------------------- * make output file name *------------------------------------------------------------------- do ich=1,nch fname(ich)=cdate0(iid)(3:4)//cdate0(iid)(5:6)//cdate0(iid)(7:8) - //cdate0(iid)(9:10)//'.'//stcode(ich+10) * if(cdate0(iid)(3:4).eq.'10')fname(ich)(1:1)='a' * if(cdate0(iid)(3:4).eq.'11')fname(ich)(1:1)='b' * if(cdate0(iid)(3:4).eq.'12')fname(ich)(1:1)='c' fname(ich)=homdir(1:nhomd-1)//fname(ich)(1:12) write(*,*)fname(ich) end do *------------------------------------------------------------------- * obtain the time of the first data *------------------------------------------------------------------- call frsttm(istd(iid),cdate0(iid),npret(iid),nsamp,cfstt) * *------------------------------------------------------------------- * / OBTAIN THE ABSOLUTE SENSITIVITY ;(MKINE/DIGIT) / * SCALE(1)=RLSB/RABSXN;SCALE(2)=RLSB/RABSYE;SCALE(3)=RLSB/RABSZU *--------------------SCALE :(MKINE/DIGIT) *------------------------------------------------------------------- * write header on output files *------------------------------------------------------------------- write(*,*) ' file will be created on ', - homdir(1:nhomd-1),' directory ' do ich=1,nch * iunit=30+ich l=10+ich c open(unit=l,file=fname(l-10),form='formatted',status='new') factor=1.0e-3*rlsb/fact1(l)/fact2(l) if(ndata(iid).gt.maxdat)then write(*,*)' ### too many data. ### ' write(*,*)' You can get ascii data only the ' write(*,*)' limit of the capacity of this program.' write(*,*)'iid=',iid write(*,*)'ndata(iid)=',ndata(iid) write(*,*)'maxdat',maxdat ndata(iid)=maxdat end if c call wrtzoo(l,stcode(l),nsewud(l),vora(l),nsamp, c - ndata(iid),npret(iid), c - factor,sensor,rcrder,aliasf,zerord(l), c - datfmt,myname,namemy,cfstt,ctadj(iid), c - filedt,iid,fname(l-10) ) end do *------------------------------------------------------------------- * read data file & transform to ascii data *------------------------------------------------------------------- open(41,file=filedt,status='old',access='direct',recl=2*nch) c ngyou=int(real(ndata(iid))/real(ix)) c ngyoua=mod(ndata(iid),ix) nstr=0 do i=1,iid-1 nstr=nstr+mdata(i) end do nstr=nstr+1 irec1=nstr irec2=nstr+ndata(iid) * do j=irec1,irec2 read(41,rec=j,err=999) (id(jch),jch=1,nch) do ich=1,nch *******************************: id(ich)=ishftc(id(ich),8,16) idata(j-irec1+1,ich)=id(ich) end do * if(j.gt.0 .and. j.ge.lackth)then * do ich=1,nch-1 * idata(j-irec1+1,ich+1)=id(ich) * end do * idata(j-irec1+1,1)=id(nch) * else * do ich=1,nch * idata(j-irec1+1,ich)=id(ich) * end do * end if end do *------------------------------------------------------------------- * write ascii data of NS&EW&UD-component on output file *------------------------------------------------------------------- do 8000 ich=1,nch c iunit=10+ich * c do i=1,ngyou c do j=1,ix c ido(j)=idata(j+(i-1)*ix,ich) c end do c write(iunit,'('//datfmt//')') (ido(l),l=1,ix) c end do * c i=ngyou+1 c do j=1,ix c if(j.le.ngyoua) then c ido(j)=idata(j+(i-1)*ix,ich) c else c ido(j)=99999 c endif c end do c c write(iunit,'('//datfmt//')') (ido(l),l=1,ix) c close(iunit) write(6,*) 'ndata = ',ndata(iid) c do isamp=1,ndata(iid) c sdata(isamp)=idata(isamp,ich) c end do ******************************************************** call mksacf(rlsb,nsewud(ich),cfstt, - idata(1,ich),fname(ich),ndata(iid)) c - sdata,fname(ich),ndata(iid)) ******************************************************** 8000 continue close(41) 9998 continue 9999 continue close(31) stop * 995 write(*,*) ' nch=',nch,'mch=',mch write(*,*) ' channnel size is differet. ' stop 996 write(*,*) ' nid=',nid,'maxid=',maxid write(*,*) ' ### nid > maxid ### ' stop 999 write(*,*) 'error occured in reading binary data !!!;irec=', - irec1+j-1 stop 9997 write(*,*) ' Thank you ! ' stop end * *#################################################################### subroutine mksacf(rlsb,nsewud,cfstt, - sdata,fname,ndata) ********************************************************************* parameter(maxdat=200000) character fname*30,nsewud*5 character cfstt*16 c character irchar*10 integer fnamel,ndata,sdata(maxdat) c integer iunit integer nudata real strt,rdata(maxdat) fnamel=index(fname,' ') *************************************** nudata=int(ndata/10) c nudata=60000 c open(iunit,file=fname(1:fnamel-1),status='old') c read(iunit,'(a)')(irchar,i=1,6) c read(iunit,'(a18,f6.3)')irchar,strt c read(iunit,'(a)')(irchar,i=1,14) * read(iunit,'('//datfmt//')') (sdata(i),i=1,ndata) c read(iunit,'(10i7)')(sdata(i),i=1,ndata) * read(iunit,'(i7,63x)')(sdata(i),i=1,int(ndata/10)) c write(*,*)int(ndata/10),ndata c flag=0.0 do i=1,nudata rdata(i)=real(sdata((i-1)*10+1))*rlsb end do 999 continue c write(*,*)ndata call newhdr call setihv('iftype','itime',nerr) call setlhv('leven',.true.,nerr) strt=0.0 call setfhv('b',strt,nerr) call setfhv('delta',0.01,nerr) call setnhv('npts',nudata,nerr) c close(iunit) call setkhv('kstnm',fname(fnamel-3:fnamel-1),nerr) c call setkhv('kcmpnm',nsewud,nerr) call wsac0(fname(1:fnamel-1)//'.sacf', * xdummy,rdata,nerr) return end ********************************************************************* subroutine rd_prm(namemy, - sensor,rcrder,aliasf,mch, - comp,stcode,nsewud,vora,zerord, - fact1,fact2,homdir,nhomd) * ReaD PaRaMeter file ********************************************************************* c character myname*20 character homdir*30 character sensor*10,rcrder*10,aliasf*10 character comp(11:18)*1,stcode(11:18)*3,nsewud(11:18)*5 character vora(11:18)*8,zerord(11:18)*11 real fact1(11:18) integer fact2(11:18) ********************************************************************* c read(31,'(a20)') myname c itmp=0 c do i=1,20 c write(*,*)i,myname(i:i) c if(myname(i:i).eq.' ')then c itmp=i c else c goto 40 c end if c end do c 40 continue ******************************************** c do j=itmp+1,20 c myname(j-itmp:j-itmp)=myname(j:j) c end do c do j=21-itmp,20 c myname(j-itmp:j-itmp)=' ' c end do c jtmp=index(myname(1:20-itmp),' ') c namemy=index(myname(jtmp+1:20-itmp),' ') c if(namemy.eq.0)then c namemy=20 c else c namemy=(jtmp-1)+1+(namemy-1) c end if * write(*,'(x,a20,3i10)')myname,jtmp-1,namemy c write(*,'(a20)') myname ******************************************* read(31,'(a10,a10,a10)') sensor,rcrder,aliasf write(*,'(x,3a)') sensor,rcrder,aliasf read(31,*) mch write(*,*) mch do i=11,10+mch read(31,'(a1,x,a3,x,a5,x,a8,x,a11,x,e14.7,x,i5)') - comp(i),stcode(i),nsewud(i),vora(i),zerord(i), - fact1(i),fact2(i) end do read(31,*) read(31,'(a30)') homdir write(*,'(a30)') homdir nhomd=0 do i=1,30 if(homdir(i:i).eq.' ')then nhomd=i else goto 44 end if end do 44 continue do j=nhomd+1,30 homdir(j-nhomd:j-nhomd)=homdir(j:j) end do nhomd=index(homdir(1:30),' ') return end * ********************************************************************* subroutine rd_hder(filehd,nch,nsamp,rlsb, - nid,iextrg) * ReaD HeaDER ********************************************************************* character filehd*30 character chdr*80 * character chdr*80,cnid*6 * integer nc(8) open(21,file=filehd,status='old') * 10 continue read(21,'(a)',iostat=ios) chdr * write(*,*)'chdr' if(ios.eq.0) then if(chdr(1:6) .eq.'DEVICE') goto 50 if(chdr(1:12).eq.'CHANNEL_SIZE') then write(*,*)'CHANNEL_SIZE' goto 51 end if if(chdr(1:16).eq.'SAMPLE_FREQUENCY') goto 52 if(chdr(1:11).eq.'INPUT_RANGE') goto 53 if(chdr(1:9) .eq.'ID_VOLUME') goto 54 if(chdr(1:14).eq.'STOP_CONDITION') goto 55 * if(chdr(1:9) .eq.'FILE_NAME') goto 56 * if(chdr(1:8).eq.'X_OFFSET') goto 57 endif 60 continue if(ios.eq.0) goto 10 goto 70 * 50 continue if(chdr(8:11).eq.'DRM2') then goto 60 else goto 998 endif * 51 continue read(chdr(14:14),'(i1)') nch write(*,*)'nch=',nch goto 60 * 52 continue * read(chdr(18:20),'(i3)') nsamp * if(chdr(21:21).eq.'K') nsamp=nsamp*1000 nsamp=1000 goto 60 * 53 continue if(chdr(13:14).eq.'1V') then rlsb=0.0375 elseif(chdr(13:14).eq.'2V') then rlsb=0.075 elseif(chdr(13:14).eq.'5V') then rlsb=0.1875 elseif(chdr(13:15).eq.'10V') then rlsb=0.375 ENDIF *-----------------rlsb: (mv/digit) goto 60 * 54 continue backspace(21) read(21,'(a10,i6)')chdr,nid write(*,*)'nid=',nid goto 60 * 55 continue if(chdr(16:18).eq.'EXT') iextrg=1 if(chdr(16:20).eq.'COUNT') iextrg=0 GOTO 60 * * 57 continue * backspace(21) * read(21,'(a9,i7)')chdr,npri * npri=-npri * write(*,*)'npri=',npri * goto 60 70 continue c nch=8 c nid=6 close(21) return 998 write(*,*) 'error occured !! --this is not a drm2 data !' stop end * ********************************************************************* subroutine rd_id(maxid,nid,filehd,iextrg, - cdate0,istd,ctadj,ndata,npret) * ReaD ID ********************************************************************* integer istd(maxid),ndata(maxid),npret(maxid) character*12 cdate0(maxid),ctadj(maxid) character chdr*80,filehd*30 ********************************************************************* open(21,file=filehd,status='old') * do 100 iid=1,nid * 80 continue read(21,'(a)',iostat=ios) chdr if(ios.eq.0) then if(chdr(1:2).eq.'ID') then backspace(21) read(21,'(a3,i8)')chdr,idnum * write(*,*)'idnum=',idnum if(idnum.eq.iid) goto 90 endif endif if(ios.eq.0) goto 80 * 90 continue read(21,'(a)') chdr if(chdr(1:4).eq.'TIME') then cdate0(iid)(1:12)=chdr(6:17) else goto 997 endif * * read(21,'(a)') chdr * if(chdr(1:17).eq.'START_TIME_DETAIL') then * backspace(21) * read(21,'(a18,i8)')chdr,istd(iid) * write(*,*)'istd(iid)',istd(iid) * else * goto 997 * endif * if(iextrg.eq.1)read(21,'(a)') chdr * * read(21,'(a)') chdr * if(chdr(1:11).eq.'TIME_ADJUST') then * ctadj(iid)(1:12)=chdr(13:24) * else * goto 997 * endif * read(21,'(a)') chdr if(chdr(1:17).eq.'SAMPLE_DATA_COUNT') then backspace(21) read(21,'(a18,i8)')chdr,ndata(iid) else goto 997 endif ******************************************* c read(21,'(a)') chdr c if(chdr(1:20).eq.'START_PRE_REAL_COUNT') then c backspace(21) c read(21,'(a21,i5)')chdr,npret(iid) * * else * goto 997 c endif ************************************* * 100 continue close(21) return 997 write(*,*) 'error occured in reading id !!!' stop end * ********************************************************************* subroutine frsttm(istd,cdate0,npret,nsamp,cfstt) * FiRST TiMe ********************************************************************* character cdate0*12 character cdate1*16,cfstt*16 ********************************************************************* thund=100.0*real(istd)/real(32768) ithund=nint(thund) cdate1='19'//cdate0(1:12)//'##' if(ithund.ge.10) then write(cdate1(15:16),'(i2)') ithund else write(cdate1(15:15),'(i1)') 0 write(cdate1(16:16),'(i1)') ithund endif * write(*,*)cdate1 write(*,*)ithund write(*,*)istd,'/32768' read(cdate1( 9:10),'(i2)') itrit1 read(cdate1(11:12),'(i2)') itrit2 read(cdate1(13:14),'(i2)') itrit3 if(ithund.eq.100)then itrit4=100 else read(cdate1(15:16),'(i2)') itrit4 end if itrit0=itrit1*60*60*100+itrit2*60*100+itrit3*100+itrit4 if(itrit0.ge.npret) then write(*,*)'npret,nsamp=',npret,nsamp ifstt0=itrit0-npret*100/nsamp ifstt1=int(ifstt0/60/60/100) itama1=mod(ifstt0,60*60*100) ifstt2=int(itama1/60/100) itama2=mod(itama1,60*100) ifstt3=int(itama2/100) ifstt4=mod(itama2,100) cfstt(1:8)=cdate1(1:8) if(ifstt1.lt.10) then write(cfstt( 9: 9),'(i1)') 0 write(cfstt(10:10),'(i1)') ifstt1 else write(cfstt( 9:10),'(i2)') ifstt1 endif if(ifstt2.lt.10) then write(cfstt(11:11),'(i1)') 0 write(cfstt(12:12),'(i1)') ifstt2 else write(cfstt(11:12),'(i2)') ifstt2 endif if(ifstt3.lt.10) then write(cfstt(13:13),'(i1)') 0 write(cfstt(14:14),'(i1)') ifstt3 else write(cfstt(13:14),'(i2)') ifstt3 endif if(ifstt4.lt.10) then write(cfstt(15:15),'(i1)') 0 write(cfstt(16:16),'(i1)') ifstt4 else write(cfstt(15:16),'(i2)') ifstt4 endif else write(*,*) 'input the time of the first data by yourself !!' write(*,*) ';(YYYYMMDDHHMMSS##)' write(*,*) cdate1 write(*,*) 'npret=',npret read(5,'(i12)') ifstt write(cfstt(1:16),'(i16)') ifstt endif return end * ********************************************************************* subroutine wrtzoo(l,stcode,nsewud,vora,nsamp, - ndata,npret, - factor,sensor,rcrder,aliasf,zerord, - datfmt,myname,namemy,cfstt,ctadj, - filedt,iid,fname) * WRiTe ZOO format ********************************************************************* character stcode*3,nsewud*5 character vora*8,zerord*11 character sensor*10,rcrder*10,aliasf*10 character factf*10,datfmt*10 character myname*20 character cfstt*16 character ctadj*12 character filedt*30 character*30 fname *01 write(l,'(a15)') 'ZOOEGM94 FORMAT' *02 write(l,'(a3)') stcode *03 write(l,'(a16)') - cfstt(1:4)//'/'//cfstt(5:6)//'/'//cfstt(7:8)//' ' - //cfstt(9:10)//':'//cfstt(11:12) *04 write(l,'(a5,a)') nsewud,vora *05 write(l,'(i10)') nsamp *06 write(l,'(i10)') ndata *07 write(l,'(a24)') - 'T'//cfstt(1:4)//'/'//cfstt(5:6)//'/'//cfstt(7:8)//' ' - //cfstt(9:10)//':'//cfstt(11:12)//':'//cfstt(13:14)//'.' - //cfstt(15:16)//'0' ** *08 write(l,'(a24)') - 'C'//cfstt(1:4)//'/'//ctadj(3:4)//'/'//ctadj(5:6) - //' '//ctadj(7:8)//':'//ctadj(9:10)//':' - //ctadj(11:12)//'.'//'000' *09 write(l,'(f10.3)') 1.*npret/nsamp *10 factf='E14.7' if(vora(1:1).eq.'v' .or. vora(1:1).eq.'V') - write(l,'(a10,a5)') factf,'m/s' if(vora(1:1).eq.'a' .or. vora(1:1).eq.'A') - write(l,'(a10,a5)') factf,'m/s/s' if(vora(1:1).eq.'t' .or. vora(1:1).eq.'T') - write(l,'(a10,a5)') factf,'-----' *11 ** write(l,'(E14.7)') 1.0e-6*resol/fact1(l)/fact2(l) ** write(l,'('//factf//')') 1.0e-3*rlsb/fact1(l)/fact2(l) write(l,'('//factf//')') factor *12 write(l,'(a4)') datfmt *13 write(l,'(3a10)') sensor,rcrder,aliasf *14 write(l,'(a)') myname(1:namemy) *15 write(l,'(a)') zerord *16 write(l,'(i10)') 5 write(l,*) write(l,'(a,a)')'***Original data file is ',filedt write(l,'(a,i3)')'***record no. is ',iid write(l,'(a,a)')'***Name of this file is ',fname write(l,*) return end